Also build 32bit release artifact

.github/release.yaml

@@ -1,109 +0,0 @@
-name: Create Release
-
-on:
-  push:
-    tags:
-      - 'v*'
-
-jobs:
-  draft_release:
-    name: Create Release
-    runs-on: ubuntu-latest
-    outputs:
-      upload_url: ${{ steps.create_release.outputs.upload_url }}
-
-    steps:
-      - name: Create Release
-        id: create_release
-        uses: actions/create-release@v1
-        env:
-          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-        with:
-          tag_name: ${{ github.ref }}
-          release_name: Release ${{ github.ref }}
-          body: |
-            Changes in this Release
-            - First Change
-            - Second Change
-          draft: true
-          prerelease: false
-
-  release-mac:
-    name: Create Release for macOS
-    needs: draft_release
-    runs-on: ${{ matrix.os }}
-    env:
-      MACOSX_DEPLOYMENT_TARGET: 10.13
-    strategy:
-      matrix:
-        os:
-          - macOS-10.15
-    steps:
-      - name: Checkout code
-        uses: actions/checkout@v2
-
-      - uses: haskell/actions/setup@v1.2
-        with:
-          ghc-version: 8.10.4
-          cabal-version: 3.4.0.0
-
-      - name: create ~/.local/bin
-        run: mkdir -p "$HOME/.local/bin"
-        shell: bash
-
-      - name: Add ~/.local/bin to PATH
-        run: echo "$HOME/.local/bin" >> $GITHUB_PATH
-        shell: bash
-
-      - name: Update cabal cache
-        run: cabal update
-        shell: bash
-
-      - name: Install cabal dependencies
-        run: cabal build --only-dependencies
-        shell: bash
-
-      - name: Build
-        run: cabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
-        shell: bash
-
-      - name: Install
-        run: cp "$(cabal list-bin exe:ghcup)" ~/.local/bin/ghcup
-        shell: bash
-
-      - name: Strip
-        run: strip ~/.local/bin/ghcup
-        shell: bash
-
-      - name: Run tests
-        run: cabal test --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" all
-        shell: bash
-
-      - name: Install git
-        run: brew install git
-
-      - name: set HOME
-        run: echo "HOME=$HOME" >> $GITHUB_ENV
-        shell: bash
-
-      - name: Set ASSET_PATH
-        run: echo "ASSET_PATH=$HOME/.local/bin/ghcup" >> $GITHUB_ENV
-        shell: bash
-
-      - name: Upload Release Asset
-        id: upload-release-asset
-        uses: actions/upload-release-asset@v1
-        env:
-          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-        with:
-          upload_url: ${{ needs.draft_release.outputs.upload_url }}
-          asset_path: ${{ env.ASSET_PATH }}
-          asset_name: ghcup-${{ matrix.os }}
-          asset_content_type: application/octet-stream
-
-      - if: always()
-        uses: actions/upload-artifact@v2
-        with:
-          name: plan.json
-          path: ./dist-newstyle/cache/plan.json
-

.github/workflows/release.yaml

@@ -1,109 +0,0 @@
-name: Create Release
-
-on:
-  push:
-    tags:
-      - 'v*'
-
-jobs:
-  draft_release:
-    name: Draft Release
-    runs-on: ubuntu-latest
-    outputs:
-      upload_url: ${{ steps.create_release.outputs.upload_url }}
-
-    steps:
-      - name: Create Release
-        id: create_release
-        uses: actions/create-release@v1
-        env:
-          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-        with:
-          tag_name: ${{ github.ref }}
-          release_name: Release ${{ github.ref }}
-          body: |
-            Changes in this Release
-            - First Change
-            - Second Change
-          draft: true
-          prerelease: false
-
-  release-mac:
-    name: Create Release
-    needs: draft_release
-    runs-on: ${{ matrix.os }}
-    env:
-      MACOSX_DEPLOYMENT_TARGET: 10.13
-    strategy:
-      matrix:
-        os:
-          - macOS-10.15
-    steps:
-      - name: Checkout code
-        uses: actions/checkout@v2
-
-      - uses: haskell/actions/setup@v1.2
-        with:
-          ghc-version: 8.10.4
-          cabal-version: 3.4.0.0
-
-      - name: create ~/.local/bin
-        run: mkdir -p "$HOME/.local/bin"
-        shell: bash
-
-      - name: Add ~/.local/bin to PATH
-        run: echo "$HOME/.local/bin" >> $GITHUB_PATH
-        shell: bash
-
-      - name: Update cabal cache
-        run: cabal update
-        shell: bash
-
-      - name: Install cabal dependencies
-        run: cabal build --only-dependencies --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
-        shell: bash
-
-      - name: Build
-        run: cabal build --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
-        shell: bash
-
-      - name: Install
-        run: cp "$(cabal list-bin exe:ghcup)" ~/.local/bin/ghcup
-        shell: bash
-
-      - name: Strip
-        run: strip ~/.local/bin/ghcup
-        shell: bash
-
-      - name: Run tests
-        run: cabal test --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" all
-        shell: bash
-
-      - name: Install git
-        run: brew install git
-
-      - name: set HOME
-        run: echo "HOME=$HOME" >> $GITHUB_ENV
-        shell: bash
-
-      - name: Set ASSET_PATH
-        run: echo "ASSET_PATH=$HOME/.local/bin/ghcup" >> $GITHUB_ENV
-        shell: bash
-
-      - name: Upload Release Asset
-        id: upload-release-asset
-        uses: actions/upload-release-asset@v1
-        env:
-          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
-        with:
-          upload_url: ${{ needs.draft_release.outputs.upload_url }}
-          asset_path: ${{ env.ASSET_PATH }}
-          asset_name: ghcup-${{ matrix.os }}
-          asset_content_type: application/octet-stream
-
-      - if: always()
-        uses: actions/upload-artifact@v2
-        with:
-          name: plan.json
-          path: ./dist-newstyle/cache/plan.json
-

.github/workflows/shimgen.yaml

@@ -1,29 +0,0 @@
-name: Shimgen CI
-
-on:
-  push:
-    branches: [ master ]
-  pull_request:
-    branches: [ master ]
-
-jobs:
-  build-shimgen:
-
-    runs-on: ${{ matrix.os }}
-    strategy:
-      fail-fast: false
-      matrix:
-        os: [windows-latest]
-
-    steps:
-    - uses: actions/checkout@v2
-    - uses: ilammy/msvc-dev-cmd@v1
-
-    - name: compile
-      run: cl /O1 scoop-better-shimexe/shim.c
-
-    - uses: actions/upload-artifact@v2
-      with:
-        name: shim.exe
-        path: shim.exe
-

.gitignore

@@ -1,15 +1,2 @@
-.ghci
-.vim
-codex.tags
 dist-newstyle/
-cabal.project.local
 .stack-work/
-bin/
-/*.prof
-/*.ps
-/*.hp
-tags
-TAGS
-/tmp/
-.entangled
-release/

.gitlab-ci.yml

@@ -1,125 +1,63 @@
-stages:
-  - hlint
-  - test
-  - release
-
 variables:
   GIT_SSL_NO_VERIFY: "1"
 
   # Commit of ghc/ci-images repository from which to pull Docker images
-  DOCKER_REV: 8d0224e6b2a08157649651e69302380b2bd24e11
+  DOCKER_REV: cefaee3c742af193e0f7783f87edb0d35374515c
 
 ############################################################
 # CI Step
 ############################################################
 
 .debian:
-  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb10:$DOCKER_REV"
+  image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb9:$DOCKER_REV"
   tags:
     - x86_64-linux
   variables:
     OS: "LINUX"
-    ARCH: "64"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
-    CROSS: ""
 
 .alpine:64bit:
-  image: "alpine:3.12"
+  image: "alpine:edge"
   tags:
     - x86_64-linux
   variables:
     OS: "LINUX"
-    ARCH: "64"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
+    BIT: "64"
 
 .alpine:32bit:
-  image: "i386/alpine:3.12"
+  image: "i386/alpine:edge"
   tags:
     - x86_64-linux
   variables:
     OS: "LINUX"
-    ARCH: "32"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
-
-.linux:armv7:
-  image: "registry.gitlab.haskell.org/ghc/ci-images/armv7-linux-deb10:$DOCKER_REV"
-  tags:
-    - armv7-linux
-  variables:
-    OS: "LINUX"
-    ARCH: "ARM"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
-  retry: 2
-
-.linux:aarch64:
-  image: "registry.gitlab.haskell.org/ghc/ci-images/aarch64-linux-deb10:$DOCKER_REV"
-  tags:
-    - aarch64-linux
-  variables:
-    OS: "LINUX"
-    ARCH: "ARM64"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
+    BIT: "32"
 
 .darwin:
   tags:
     - x86_64-darwin
   variables:
     OS: "DARWIN"
-    ARCH: "64"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
 
-.darwin:aarch64:
+.freebsd:
   tags:
-    - aarch64-darwin-m1
-  variables:
-    OS: "DARWIN"
-    ARCH: "ARM64"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
-
-.freebsd13:
-  tags:
-    - x86_64-freebsd13
+    - x86_64-freebsd
   variables:
     OS: "FREEBSD"
-    ARCH: "64"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
-
-.freebsd12:
-  tags:
-    - x86_64-freebsd12
-  variables:
-    OS: "FREEBSD"
-    ARCH: "64"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
-
-.windows:
-  tags:
-    - new-x86_64-windows
-  variables:
-    OS: "WINDOWS"
-    ARCH: "64"
-    CABAL_DIR: "$CI_PROJECT_DIR/cabal"
-  retry: 2
 
 .root_cleanup:
   after_script:
-    - bash ./.gitlab/after_script.sh
+    - BUILD_DIR=$CI_PROJECT_DIR
+    - echo "Cleaning $BUILD_DIR"
+    - cd $HOME
+    - test -n "$BUILD_DIR"
+    - shopt -s extglob
+    - rm -Rf "$BUILD_DIR"/!(out)
+    - exit 0
 
 .test_ghcup_version:
   script:
-    - bash ./.gitlab/script/ghcup_version.sh
+    - ./.gitlab/script/ghcup_version.sh
   variables:
-    JSON_VERSION: "0.0.6"
-  artifacts:
-    expire_in: 2 week
-    paths:
-      - test/golden
-      - dist-newstyle/cache/
-    when: on_failure
-
-# .test_ghcup_scoop:
-  # script:
-    # - cl /O1 scoop-better-shimexe/shim.c
+    JSON_VERSION: "0.0.1"
 
 .test_ghcup_version:linux:
   extends:
@@ -128,27 +66,6 @@ variables:
   before_script:
     - ./.gitlab/before_script/linux/install_deps.sh
 
-.test_ghcup_version:linux32:
-  extends:
-    - .test_ghcup_version
-    - .alpine:32bit
-  before_script:
-    - ./.gitlab/before_script/linux/alpine/install_deps.sh
-
-.test_ghcup_version:armv7:
-  extends:
-    - .test_ghcup_version
-    - .linux:armv7
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps.sh
-
-.test_ghcup_version:aarch64:
-  extends:
-    - .test_ghcup_version
-    - .linux:aarch64
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps.sh
-
 .test_ghcup_version:darwin:
   extends:
     - .test_ghcup_version
@@ -157,279 +74,75 @@ variables:
   before_script:
     - ./.gitlab/before_script/darwin/install_deps.sh
 
-.test_ghcup_version:darwin:aarch64:
+.test_ghcup_version:freebsd:
   extends:
     - .test_ghcup_version
-    - .darwin:aarch64
-    - .root_cleanup
-  script: |
-    set -Eeuo pipefail
-    function runInNixShell() {
-      time nix-shell $CI_PROJECT_DIR/.gitlab/shell.nix \
-        -I nixpkgs=https://github.com/angerman/nixpkgs/archive/75f7281738b.tar.gz \
-        --argstr system "aarch64-darwin" \
-        --pure \
-        --keep CI_PROJECT_DIR \
-        --keep MACOSX_DEPLOYMENT_TARGET \
-        --keep JSON_VERSION \
-        --keep ARTIFACT \
-        --keep OS \
-        --keep ARCH \
-        --keep CABAL_DIR \
-        --keep GHC_VERSION \
-        --keep CABAL_VERSION \
-        --run "$1" 2>&1
-    }
-    runInNixShell ./.gitlab/before_script/darwin/install_deps.sh 2>&1
-    runInNixShell ./.gitlab/script/ghcup_version.sh 2>&1
-
-.test_ghcup_version:freebsd12:
-  extends:
-    - .test_ghcup_version
-    - .freebsd12
+    - .freebsd
     - .root_cleanup
   before_script:
     - ./.gitlab/before_script/freebsd/install_deps.sh
 
-.test_ghcup_version:freebsd13:
-  extends:
-    - .test_ghcup_version
-    - .freebsd13
-    - .root_cleanup
-  before_script:
-    - ./.gitlab/before_script/freebsd/install_deps.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
-
-# .test_ghcup_scoop:windows:
-  # extends:
-    # - .windows
-    # - .test_ghcup_scoop
-    # - .root_cleanup
-
 .release_ghcup:
   script:
-    - bash ./.gitlab/script/ghcup_release.sh
+    - ./.gitlab/script/ghcup_release.sh
   artifacts:
     expire_in: 2 week
     paths:
       - out
-      - dist-newstyle/cache/
   only:
     - tags
-  variables:
-    JSON_VERSION: "0.0.6"
-
-######## stack test ########
-
-test:linux:stack:
-  stage: test
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps_minimal.sh
-  script:
-    - ./.gitlab/script/ghcup_stack.sh
-  extends:
-    - .debian
-  needs: []
-
-######## bootstrap test ########
-
-test:linux:bootstrap_script:
-  stage: test
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps_minimal.sh
-  script:
-    - ./.gitlab/script/ghcup_bootstrap.sh
-  variables:
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-  extends:
-    - .debian
-    - .root_cleanup
-  needs: []
-
-test:windows:bootstrap_powershell_script:
-  stage: test
-  script:
-    - ./scripts/bootstrap/bootstrap-haskell.ps1 -InstallDir $CI_PROJECT_DIR -BootstrapUrl $CI_PROJECT_DIR/bootstrap-haskell -InBash
-  after_script:
-    - "[Environment]::SetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', $null, [System.EnvironmentVariableTarget]::User)"
-    - "[Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)"
-    - "[Environment]::SetEnvironmentVariable('CABAL_DIR', $null, [System.EnvironmentVariableTarget]::User)"
-    - bash ./.gitlab/after_script.sh
-  variables:
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-  extends:
-    - .windows
-  needs: []
 
 ######## linux test ########
 
-test:linux:
-  stage: test
+test:linux:recommended:
   extends: .test_ghcup_version:linux
   variables:
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-  needs: []
-
-test:linux:hls:
-  stage: test
-  extends:
-    - .test_ghcup_version
-    - .debian
-  variables:
-    GHC_VERSION: "8.10.7"
-    HLS_TARGET_VERSION: "1.4.0"
-    CABAL_VERSION: "3.6.0.0"
-  needs: []
-  when: manual
-  allow_failure: true
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps.sh
-  script:
-    - ./.gitlab/script/ghcup_hls.sh
-
-test:linux:cross-armv7:
-  stage: test
-  extends:
-    - .test_ghcup_version
-    - .debian
-  variables:
-    GHC_VERSION: "8.10.5"
-    GHC_TARGET_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-    CROSS: "arm-linux-gnueabihf"
-  needs: []
-  when: manual
-  allow_failure: true
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps.sh
-  script:
-    - ./.gitlab/script/ghcup_cross.sh
-
-test:linux:git:hadrian:
-  stage: test
-  extends:
-    - .test_ghcup_version
-    - .debian
-  variables:
-    GHC_VERSION: "8.10.6"
-    GHC_GIT_TAG: "ghc-9.0.1-release"
-    GHC_GIT_VERSION: "9.0.1"
-    CABAL_VERSION: "3.4.0.0"
-    CROSS: ""
-  needs: []
-  when: manual
-  allow_failure: true
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps.sh
-  script:
-    - ./.gitlab/script/ghcup_git.sh
-
-
-######## linux 32bit test ########
-
-test:linux:32bit:
-  stage: test
-  extends: .test_ghcup_version:linux32
-  variables:
-    GHC_VERSION: "8.10.6"
+    GHC_VERSION: "8.6.5"
     CABAL_VERSION: "3.2.0.0"
-  needs: []
 
-######## arm tests ########
-
-test:linux:armv7:
-  stage: test
-  extends: .test_ghcup_version:armv7
+test:linux:latest:
+  extends: .test_ghcup_version:linux
   variables:
-    GHC_VERSION: "8.10.4"
-    CABAL_VERSION: "3.4.0.0"
-    CROSS: ""
-  when: manual
-  needs: []
+    GHC_VERSION: "8.8.3"
+    CABAL_VERSION: "3.2.0.0"
+  allow_failure: true
 
-test:linux:aarch64:
-  stage: test
-  extends: .test_ghcup_version:aarch64
-  variables:
-    GHC_VERSION: "8.10.4"
-    CABAL_VERSION: "3.4.0.0"
-    CROSS: ""
-  when: manual
-  needs: []
 
 ######## darwin test ########
 
-test:mac:
-  stage: test
+test:mac:recommended:
   extends: .test_ghcup_version:darwin
   variables:
-    GHC_VERSION: "8.10.4"
-    CABAL_VERSION: "3.4.0.0"
-  needs: []
+    GHC_VERSION: "8.6.5"
+    CABAL_VERSION: "3.2.0.0"
 
-test:mac:aarch64:
-  stage: test
-  extends: .test_ghcup_version:darwin:aarch64
+test:mac:latest:
+  extends: .test_ghcup_version:darwin
   variables:
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-  needs: []
+    GHC_VERSION: "8.8.3"
+    CABAL_VERSION: "3.2.0.0"
   allow_failure: true
 
 
 ######## freebsd test ########
 
-test:freebsd12:
-  stage: test
-  extends: .test_ghcup_version:freebsd12
+test:freebsd:recommended:
+  extends: .test_ghcup_version:freebsd
   variables:
-    GHC_VERSION: "8.10.4"
-    CABAL_VERSION: "3.4.0.0"
-  allow_failure: true # freebsd runners are unreliable
-  when: manual
-  needs: []
+    GHC_VERSION: "8.6.5"
+    CABAL_VERSION: "3.2.0.0"
 
-test:freebsd13:
-  stage: test
-  extends: .test_ghcup_version:freebsd13
+test:freebsd:latest:
+  extends: .test_ghcup_version:freebsd
   variables:
-    GHC_VERSION: "8.10.4"
-    CABAL_VERSION: "3.4.0.0"
-  allow_failure: true # freebsd runners are unreliable
-  when: manual
-  needs: []
+    GHC_VERSION: "8.8.3"
+    CABAL_VERSION: "3.2.0.0"
+  allow_failure: true
 
-######## windows test ########
-
-test:windows:
-  stage: test
-  extends: .test_ghcup_version:windows
-  variables:
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-  needs: []
-
-# test:windows:scoop:
-  # stage: test
-  # extends: .test_ghcup_scoop:windows
-  # needs: []
 
 ######## linux release ########
 
 release:linux:64bit:
-  stage: release
-  needs: ["test:linux"]
   extends:
     - .alpine:64bit
     - .release_ghcup
@@ -437,56 +150,25 @@ release:linux:64bit:
     - ./.gitlab/before_script/linux/alpine/install_deps.sh
   variables:
     ARTIFACT: "x86_64-linux-ghcup"
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
+    GHC_VERSION: "8.8.3"
+    CABAL_VERSION: "3.2.0.0"
 
 
 release:linux:32bit:
-  stage: release
-  needs: ["test:linux:32bit"]
   extends:
     - .alpine:32bit
     - .release_ghcup
   before_script:
     - ./.gitlab/before_script/linux/alpine/install_deps.sh
   variables:
-    ARTIFACT: "i386-linux-ghcup"
-    GHC_VERSION: "8.10.6"
+    ARTIFACT: "x86_64-linux-ghcup"
+    GHC_VERSION: "8.8.3"
     CABAL_VERSION: "3.2.0.0"
 
-release:linux:armv7:
-  stage: release
-  needs: ["test:linux:armv7"]
-  extends:
-    - .linux:armv7
-    - .release_ghcup
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps.sh
-  variables:
-    ARTIFACT: "armv7-linux-ghcup"
-    GHC_VERSION: "8.10.4"
-    CABAL_VERSION: "3.4.0.0"
-    CROSS: ""
-
-release:linux:aarch64:
-  stage: release
-  needs: ["test:linux:aarch64"]
-  extends:
-    - .linux:aarch64
-    - .release_ghcup
-  before_script:
-    - ./.gitlab/before_script/linux/install_deps.sh
-  variables:
-    ARTIFACT: "aarch64-linux-ghcup"
-    GHC_VERSION: "8.10.4"
-    CABAL_VERSION: "3.4.0.0"
-    CROSS: ""
 
 ######## darwin release ########
 
 release:darwin:
-  stage: release
-  needs: ["test:mac"]
   extends:
     - .darwin
     - .release_ghcup
@@ -495,104 +177,21 @@ release:darwin:
     - ./.gitlab/before_script/darwin/install_deps.sh
   variables:
     ARTIFACT: "x86_64-apple-darwin-ghcup"
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
+    GHC_VERSION: "8.8.3"
+    CABAL_VERSION: "3.2.0.0"
     MACOSX_DEPLOYMENT_TARGET: "10.7"
 
-release:darwin:aarch64:
-  stage: release
-  needs: ["test:mac:aarch64"]
-  extends:
-    - .darwin:aarch64
-    - .release_ghcup
-    - .root_cleanup
-  script: |
-    set -Eeuo pipefail
-    function runInNixShell() {
-      time nix-shell $CI_PROJECT_DIR/.gitlab/shell.nix \
-        -I nixpkgs=https://github.com/angerman/nixpkgs/archive/75f7281738b.tar.gz \
-        --argstr system "aarch64-darwin" \
-        --pure \
-        --keep CI_PROJECT_DIR \
-        --keep MACOSX_DEPLOYMENT_TARGET \
-        --keep JSON_VERSION \
-        --keep ARTIFACT \
-        --keep OS \
-        --keep ARCH \
-        --keep CABAL_DIR \
-        --keep GHC_VERSION \
-        --keep CABAL_VERSION \
-        --run "$1" 2>&1
-    }
-    runInNixShell ./.gitlab/before_script/darwin/install_deps.sh 2>&1
-    runInNixShell ./.gitlab/script/ghcup_release.sh 2>&1
-  variables:
-    ARTIFACT: "aarch64-apple-darwin-ghcup"
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-    MACOSX_DEPLOYMENT_TARGET: "10.7"
-  allow_failure: true
-
 
 ######## freebsd release ########
 
-release:freebsd12:
-  stage: release
-  needs: ["test:freebsd12"]
+release:freebsd:
   extends:
-    - .freebsd12
+    - .freebsd
     - .release_ghcup
     - .root_cleanup
   before_script:
     - ./.gitlab/before_script/freebsd/install_deps.sh
   variables:
     ARTIFACT: "x86_64-portbld-freebsd-ghcup"
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-  allow_failure: true
+    GHC_VERSION: "8.6.5"
 
-release:freebsd13:
-  stage: release
-  needs: ["test:freebsd13"]
-  extends:
-    - .freebsd13
-    - .release_ghcup
-    - .root_cleanup
-  before_script:
-    - ./.gitlab/before_script/freebsd/install_deps.sh
-  variables:
-    ARTIFACT: "x86_64-portbld-freebsd-ghcup"
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-  allow_failure: true
-
-######## windows release ########
-
-release:windows:
-  stage: release
-  needs: ["test:windows"]
-  extends:
-    - .windows
-    - .release_ghcup
-    - .root_cleanup
-  before_script:
-    - bash ./.gitlab/before_script/windows/install_deps.sh
-  variables:
-    ARTIFACT: "x86_64-mingw64-ghcup"
-    GHC_VERSION: "8.10.6"
-    CABAL_VERSION: "3.4.0.0"
-
-######## hlint ########
-
-hlint:
-  stage: hlint
-  extends:
-    - .debian
-  script:
-    - curl -sSL https://raw.github.com/ndmitchell/hlint/master/misc/run.sh | sh -s -- -r lib/ test/
-  allow_failure: true
-  artifacts:
-    expire_in: 2 week
-    paths:
-      - report.html
-    when: on_failure

.gitlab/after_script.sh

@@ -1,15 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-BUILD_DIR=$CI_PROJECT_DIR
-echo "Cleaning $BUILD_DIR"
-cd $HOME
-test -n "$BUILD_DIR"
-shopt -s extglob
-rm -Rf "$BUILD_DIR"/!(out)
-if [ "${OS}" = "WINDOWS" ] ; then
-	rm -Rf /c/ghcup
-fi
-
-exit 0

.gitlab/before_script/darwin/install_deps.sh

@@ -4,29 +4,11 @@ set -eux
 
 . "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
 
-mkdir -p "${TMPDIR}"
-
-if [ $ARCH = 'ARM64' ] ; then
-	curl -sSfL https://downloads.haskell.org/~ghcup/aarch64-apple-darwin-ghcup > ./ghcup-bin
-	chmod +x ghcup-bin
-else
-	curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./ghcup-bin
-	chmod +x ghcup-bin
-	./ghcup-bin upgrade -i -f
-fi
+curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./ghcup-bin
+chmod +x ghcup-bin
 
 ./ghcup-bin install ${GHC_VERSION}
 ./ghcup-bin set ${GHC_VERSION}
 ./ghcup-bin install-cabal ${CABAL_VERSION}
 
-if [ $ARCH = 'ARM64' ] ; then
-	cabal update
-	mkdir vendored
-	cd vendored
-	cabal unpack network-3.1.2.1
-	cd network*
-	autoreconf -fi
-	cd ../..
-fi
-
 exit 0

.gitlab/before_script/freebsd/install_deps.sh

@@ -6,14 +6,18 @@ set -eux
 
 . "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
 
-mkdir -p "${TMPDIR}"
-
 curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > ./ghcup-bin
 chmod +x ghcup-bin
 
-./ghcup-bin -v upgrade -i -f
-./ghcup-bin -v install ${GHC_VERSION}
-./ghcup-bin -v set ${GHC_VERSION}
-./ghcup-bin -v install-cabal ${CABAL_VERSION}
+mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
+# ./ghcup-bin install ${GHC_VERSION}
+# ./ghcup-bin install-cabal ${CABAL_VERSION}
+# ./ghcup-bin set ${GHC_VERSION}
+
+# install cabal-3.2.0.0
+curl -sSfL -o cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz&dl=1'
+tar xf cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz
+cp cabal "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
+chmod +x "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
 
 exit 0

.gitlab/before_script/linux/alpine/install_deps.sh

@@ -4,15 +4,10 @@ set -eux
 
 . "$( cd "$(dirname "$0")" ; pwd -P )/../../../ghcup_env"
 
-mkdir -p "${TMPDIR}"
-
 apk add --no-cache \
 	curl \
 	gcc \
 	g++ \
-	binutils \
-	binutils-gold \
-	bsd-compat-headers \
 	gmp-dev \
 	ncurses-dev \
 	libffi-dev \
@@ -21,38 +16,45 @@ apk add --no-cache \
 	tar \
 	perl
 
-if [ "${ARCH}" = "32" ] ; then
-	curl -sSfL https://downloads.haskell.org/ghcup/i386-linux-ghcup > ./ghcup-bin
+ln -s libncurses.so /usr/lib/libtinfo.so
+ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6
+if [ "${BIT}" = "32" ] ; then
+	curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4 > ./ghcup-bin
 else
-	curl -sSfL https://downloads.haskell.org/ghcup/x86_64-linux-ghcup > ./ghcup-bin
+	curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4 > ./ghcup-bin
 fi
 chmod +x ghcup-bin
-./ghcup-bin upgrade -i -f
+./ghcup-bin upgrade
 ./ghcup-bin install ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+# ./ghcup-bin install-cabal ${CABAL_VERSION}
+# install cabal-3.2.0.0
+if [ "${BIT}" = "32" ] ; then
+	curl -sSfL -o cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz&dl=1'
+	tar xf cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz
+	cp cabal-install-3.2.0.0-i386-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
+else
+	curl -sSfL -o cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz&dl=1'
+	tar xf cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz
+	cp cabal-install-3.2.0.0-x86_64-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
+fi
+chmod +x "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
+
 
 # utils
 apk add --no-cache \
-	bash \
-	git
+	bash
 
 ## Package specific
 apk add --no-cache \
 	zlib \
 	zlib-dev \
 	zlib-static \
-	bzip2 \
-	bzip2-dev \
-	bzip2-static \
 	gmp \
 	gmp-dev \
 	openssl-dev \
 	openssl-libs-static \
 	xz \
-	xz-dev \
-	ncurses-static
+	xz-dev
+
+
 
-if [ "${ARCH}" = "32" ] ; then
-	apk add --no-cache \
-		bsd-compat-headers
-fi

.gitlab/before_script/linux/install_deps.sh

@@ -2,26 +2,15 @@
 
 set -eux
 
+sudo apt-get update -y
+sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev
+
 . "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
 
-mkdir -p "${TMPDIR}"
+curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > ./ghcup-bin
+chmod +x ghcup-bin
 
-sudo apt-get update -y
-sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https gcc autoconf automake build-essential
-
-if [ "${CROSS}" = "arm-linux-gnueabihf" ] ; then
-	sudo apt-get install -y gcc-arm-linux-gnueabihf
-	sudo dpkg --add-architecture armhf
-	sudo apt-get update -y
-	sudo apt-get install -y libncurses-dev:armhf
-fi
-
-export BOOTSTRAP_HASKELL_NONINTERACTIVE=1
-export BOOTSTRAP_HASKELL_GHC_VERSION=$GHC_VERSION
-export BOOTSTRAP_HASKELL_CABAL_VERSION=$CABAL_VERSION
-export BOOTSTRAP_HASKELL_VERBOSE=1
-
-curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh
-
-rm "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
+./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin set ${GHC_VERSION}
+./ghcup-bin install-cabal ${CABAL_VERSION}
 

.gitlab/before_script/linux/install_deps_minimal.sh

@@ -1,10 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
-
-mkdir -p "${TMPDIR}"
-
-sudo apt-get update -y
-sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget

.gitlab/before_script/windows/install_deps.sh

@@ -1,21 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-. "$( cd "$(dirname "$0")" ; pwd -P )/../../ghcup_env"
-
-mkdir -p "${TMPDIR}" "${CABAL_DIR}"
-
-mkdir -p "$GHCUP_INSTALL_BASE_PREFIX/ghcup/bin"
-
-CI_PROJECT_DIR=$(pwd)
-curl -o ghcup.exe https://downloads.haskell.org/~ghcup/x86_64-mingw64-ghcup.exe
-chmod +x ghcup.exe
-
-./ghcup.exe install ${GHC_VERSION}
-./ghcup.exe set ${GHC_VERSION}
-./ghcup.exe install-cabal ${CABAL_VERSION}
-
-rm ./ghcup.exe
-
-exit 0

.gitlab/ghcup_env

@@ -1,11 +1,3 @@
-if [ "${OS}" = "WINDOWS" ] ; then
-	export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
-	export GHCUP_BIN="$CI_PROJECT_DIR/ghcup/bin"
-	export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:$PATH"
-	export TMPDIR="$CI_PROJECT_DIR/tmp"
-else
-	export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
-	export GHCUP_BIN="$CI_PROJECT_DIR/.ghcup/bin"
-	export PATH="$GHCUP_BIN:$CI_PROJECT_DIR/.local/bin:/opt/llvm/bin:$PATH"
-	export TMPDIR="$CI_PROJECT_DIR/tmp"
-fi
+export GHCUP_INSTALL_BASE_PREFIX="$CI_PROJECT_DIR"
+export PATH="$CI_PROJECT_DIR/.ghcup/bin:$CI_PROJECT_DIR/.local/bin:$PATH"
+

.gitlab/script/ghcup_bootstrap.sh

@@ -1,30 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
-
-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
-
-./scripts/bootstrap/bootstrap-haskell
-
-[ "$(ghc --numeric-version)" = "${GHC_VERSION}" ]
-

.gitlab/script/ghcup_cross.sh

@@ -1,52 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
-
-mkdir -p "$CI_PROJECT_DIR"/.local/bin
-
-CI_PROJECT_DIR=$(pwd)
-
-ecabal() {
-	cabal "$@"
-}
-
-eghcup() {
-	ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
-}
-
-git describe --always
-
-### build
-
-ecabal update
-
-ecabal build -w ghc-${GHC_VERSION}
-cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
-
-### cleanup
-
-rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
-
-### manual cli based testing
-
-eghcup --numeric-version
-
-eghcup install ghc ${GHC_VERSION}
-eghcup set ghc ${GHC_VERSION}
-eghcup install cabal ${CABAL_VERSION}
-
-cabal --version
-
-eghcup debug-info
-
-eghcup compile ghc -j $(nproc) -v ${GHC_TARGET_VERSION} -b ${GHC_VERSION} -x ${CROSS} -- --enable-unregisterised
-eghcup set ghc ${CROSS}-${GHC_TARGET_VERSION}
-
-[ `$(eghcup whereis ghc ${CROSS}-${GHC_TARGET_VERSION}) --numeric-version` = "${GHC_TARGET_VERSION}" ]
-
-# nuke
-eghcup nuke
-[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
-

.gitlab/script/ghcup_git.sh

@@ -1,52 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
-
-mkdir -p "$CI_PROJECT_DIR"/.local/bin
-
-CI_PROJECT_DIR=$(pwd)
-
-ecabal() {
-	cabal "$@"
-}
-
-eghcup() {
-	ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
-}
-
-git describe --always
-
-### build
-
-ecabal update
-
-ecabal build -w ghc-${GHC_VERSION}
-cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
-
-### cleanup
-
-rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
-
-### manual cli based testing
-
-eghcup --numeric-version
-
-eghcup install ghc ${GHC_VERSION}
-eghcup set ghc ${GHC_VERSION}
-eghcup install cabal ${CABAL_VERSION}
-
-cabal --version
-
-eghcup debug-info
-
-eghcup compile ghc -j $(nproc) -g ${GHC_GIT_TAG} -b ${GHC_VERSION} -- --enable-unregisterised
-eghcup set ghc ${GHC_GIT_VERSION}
-
-[ `$(eghcup whereis ghc ${GHC_GIT_VERSION}) --numeric-version` = "${GHC_GIT_VERSION}" ]
-
-# nuke
-eghcup nuke
-[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
-

.gitlab/script/ghcup_hls.sh

@@ -1,51 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
-
-mkdir -p "$CI_PROJECT_DIR"/.local/bin
-
-CI_PROJECT_DIR=$(pwd)
-
-ecabal() {
-	cabal "$@"
-}
-
-eghcup() {
-	ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
-}
-
-git describe --always
-
-### build
-
-ecabal update
-
-ecabal build -w ghc-${GHC_VERSION}
-cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup
-
-### cleanup
-
-rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
-
-### manual cli based testing
-
-eghcup --numeric-version
-
-eghcup install ghc ${GHC_VERSION}
-eghcup set ghc ${GHC_VERSION}
-eghcup install cabal ${CABAL_VERSION}
-
-cabal --version
-
-eghcup debug-info
-
-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}" ]
-
-# nuke
-eghcup nuke
-[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
-

.gitlab/script/ghcup_release.sh

@@ -7,38 +7,20 @@ set -eux
 mkdir -p "$CI_PROJECT_DIR"/.local/bin
 
 ecabal() {
-	cabal "$@"
+	cabal --store-dir="$(pwd)"/.store "$@"
 }
 
-git describe
-
 # build
 ecabal update
 
-
 if [ "${OS}" = "LINUX" ] ; then
-	if [ "${ARCH}" = "32" ] ; then
-		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
-	elif [ "${ARCH}" = "64" ] ; then
-		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
-	else
-		ecabal build -w ghc-${GHC_VERSION} -ftui
-	fi
-elif [ "${OS}" = "FREEBSD" ] ; then
-	ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib +bundled-c-zlib" --constraint="zip +disable-zstd" -ftui
-elif [ "${OS}" = "WINDOWS" ] ; then
-	ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static"
+	ecabal build -w ghc-${GHC_VERSION} -fcurl --ghc-options='-split-sections -optl-static'
 else
-	ecabal build -w ghc-${GHC_VERSION} --constraint="zlib +bundled-c-zlib" --constraint="lzma +static" -ftui
+	ecabal build -w ghc-${GHC_VERSION} -fcurl
 fi
 
 mkdir out
-binary=$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')
-ver=$("${binary}" --numeric-version)
-if [ "${OS}" = "DARWIN" ] ; then
-	strip "${binary}"
-else
-	strip -s "${binary}"
-fi
-cp "${binary}" out/${ARTIFACT}-${ver}
+cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
+ver=$(./ghcup --numeric-version)
+cp ghcup out/${ARTIFACT}-${ver}
 

.gitlab/script/ghcup_stack.sh

@@ -1,21 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
-
-mkdir -p "$CI_PROJECT_DIR"/.local/bin
-
-git describe --always
-
-### build
-
-curl -L -O https://get.haskellstack.org/stable/linux-x86_64.tar.gz
-tar xf linux-x86_64.tar.gz
-cp stack-*-linux-*/stack "$CI_PROJECT_DIR"/.local/bin/stack
-chmod +x "$CI_PROJECT_DIR"/.local/bin/stack
-
-mkdir -p "$CI_PROJECT_DIR"/.stack_root
-export TAR_OPTIONS=--no-same-owner
-stack --allow-different-user --stack-root "$CI_PROJECT_DIR"/.stack_root build
-stack --allow-different-user --stack-root "$CI_PROJECT_DIR"/.stack_root test

.gitlab/script/ghcup_version.sh

@@ -6,253 +6,82 @@ set -eux
 
 mkdir -p "$CI_PROJECT_DIR"/.local/bin
 
-CI_PROJECT_DIR=$(pwd)
-
 ecabal() {
-	cabal "$@"
-}
-
-raw_eghcup() {
-	ghcup -v -c "$@"
+	cabal --store-dir="$(pwd)"/.store "$@"
 }
 
 eghcup() {
-	if [ "${OS}" = "WINDOWS" ] ; then
-		ghcup -v -c -s file:/$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
-	else
-		ghcup -v -c -s file://$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml "$@"
-	fi
+	ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.json "$@"
 }
 
-if [ "${OS}" = "WINDOWS" ] ; then
-	GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
-else
-	GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
-fi
-
-git describe --always
 
 ### build
 
 ecabal update
 
 if [ "${OS}" = "DARWIN" ] ; then
-	ecabal build -w ghc-${GHC_VERSION} -ftui
-	ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
-	ecabal haddock -w ghc-${GHC_VERSION} -ftui
-elif [ "${OS}" = "LINUX" ] ; then
-	if [ "${ARCH}" = "32" ] ; then
-		ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
-		ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
-		ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
-	else
-		ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
-		ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
-		ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
-
-		if [ "${ARCH}" = "64" ] ; then
-			# doctest
-			curl -sL https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal-docspec/cabal-docspec-0.0.0.20210228_p1.tar.bz2 > cabal-docspec.tar.bz2
-			echo '3a10f6fec16dbd18efdd331b1cef5d2d342082da42f5b520726d1fa6a3990d12  cabal-docspec.tar.bz2' | sha256sum -c -
-			tar -xjf cabal-docspec.tar.bz2 cabal-docspec
-			mv cabal-docspec "$CI_PROJECT_DIR"/.local/bin/cabal-docspec
-			rm -f cabal-docspec.tar.bz2
-			chmod a+x "$CI_PROJECT_DIR"/.local/bin/cabal-docspec
-
-			cabal-docspec -XCPP -XTypeSynonymInstances -XOverloadedStrings -XPackageImports --check-properties
-		fi
-	fi
-elif [ "${OS}" = "FREEBSD" ] ; then
-	ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"
-	ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd" ghcup-test
-	ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"
-elif [ "${OS}" = "WINDOWS" ] ; then
+	ecabal build -w ghc-${GHC_VERSION} -fcurl
+else
 	ecabal build -w ghc-${GHC_VERSION}
-	ecabal test -w ghc-${GHC_VERSION} ghcup-test
-	ecabal haddock -w ghc-${GHC_VERSION}
-else
-	ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
-	ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
-	ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
 fi
 
+cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .
+cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" .
 
-if [ "${OS}" = "WINDOWS" ] ; then
-	ext=".exe"
-else
-	ext=''
-fi
-	cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" "$CI_PROJECT_DIR"/.local/bin/ghcup${ext}
-	cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup-gen')" "$CI_PROJECT_DIR"/.local/bin/ghcup-gen${ext}
+cp ./ghcup "$CI_PROJECT_DIR"/.local/bin/ghcup
+cp ./ghcup-gen "$CI_PROJECT_DIR"/.local/bin/ghcup-gen
 
 ### cleanup
 
-rm -rf "${GHCUP_DIR}"
+rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
+
 
 ### manual cli based testing
 
 
-ghcup-gen check -f data/metadata/ghcup-${JSON_VERSION}.yaml
+ghcup-gen check -f ghcup-${JSON_VERSION}.json
 
 eghcup --numeric-version
 
-eghcup install ghc ${GHC_VERSION}
-[ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
-eghcup set ghc ${GHC_VERSION}
-eghcup install cabal ${CABAL_VERSION}
-[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
-eghcup unset cabal
-"$GHCUP_BIN"/cabal --version && exit || echo yes
-eghcup set cabal ${CABAL_VERSION}
-[ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
+# TODO: rm once we have tarballs
+if [ "${OS}"  = "FREEBSD" ] ; then
+	GHC_VERSION=8.6.3
+	CABAL_VERSION=2.4.1.0
+fi
+
+eghcup install ${GHC_VERSION}
+eghcup set ${GHC_VERSION}
+eghcup install-cabal ${CABAL_VERSION}
 
 cabal --version
 
 eghcup debug-info
 
-# also test etags
 eghcup list
 eghcup list -t ghc
 eghcup list -t cabal
 
 ghc_ver=$(ghc --numeric-version)
 ghc --version
-ghc-${ghc_ver} --version
-if [ "${OS}" != "WINDOWS" ] ; then
-		ghci --version
-		ghci-${ghc_ver} --version
-fi
+ghci --version
+ghc-$(ghc --numeric-version) --version
+ghci-$(ghc --numeric-version) --version
 
 
-if [ "${OS}" = "DARWIN" ] && [ "${ARCH}" = "ARM64" ] ; then
-	echo
-else
-	# test installing new ghc doesn't mess with currently set GHC
-	# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
-	if [ "${OS}" = "LINUX" ] ; then
-		eghcup --downloader=wget prefetch ghc 8.10.3
-		eghcup --offline install ghc 8.10.3
-		if [ "${ARCH}" = "64" ] ; then
-			expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-linux.files" | sort)
-			actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort)
-			[ "${actual}" = "${expected}" ]
-			unset actual expected
-		fi
-	elif [ "${OS}" = "WINDOWS" ] ; then
-		eghcup prefetch ghc 8.10.3
-		eghcup --offline install ghc 8.10.3
-		expected=$(cat "$( cd "$(dirname "$0")" ; pwd -P )/../ghc-8.10.3-windows.files" | sort)
-		actual=$(cd "${GHCUP_DIR}/ghc/8.10.3/" && find | sort)
-		[ "${actual}" = "${expected}" ]
-		unset actual expected
-	else
-		eghcup prefetch ghc 8.10.3
-		eghcup --offline install ghc 8.10.3
-	fi
-	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
-	eghcup --offline set 8.10.3
-	eghcup set 8.10.3
-	[ "$(ghc --numeric-version)" = "8.10.3" ]
-	eghcup set ${GHC_VERSION}
-	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
-	eghcup unset ghc
-    "$GHCUP_BIN"/ghc --numeric-version && exit || echo yes
-	eghcup set ${GHC_VERSION}
-	eghcup --offline rm 8.10.3
-	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
-
-
-	if [ "${OS}" = "DARWIN" ] ; then
-		eghcup install hls
-		$(eghcup whereis hls) --version
-
-		eghcup install stack
-		$(eghcup whereis stack) --version
-	elif [ "${OS}" = "LINUX" ] ; then
-		if [ "${ARCH}" = "64" ] ; then
-			eghcup install hls
-			haskell-language-server-wrapper --version
-			eghcup unset hls
-			"$GHCUP_BIN"/haskell-language-server-wrapper --version && exit || echo yes
-
-			eghcup install stack
-			stack --version
-			eghcup unset hls
-			"$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"
-eghcup whereis ghc $(ghc --numeric-version)
-mv -f "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml.bak" "$CI_PROJECT_DIR/data/metadata/ghcup-${JSON_VERSION}.yaml"
+# test installing new ghc doesn't mess with currently set GHC
+# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
+eghcup install 8.4.4
+[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
+eghcup set 8.4.4
+eghcup set 8.4.4
+[ "$(ghc --numeric-version)" = "8.4.4" ]
+eghcup set ${GHC_VERSION}
+[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
+eghcup rm 8.4.4
+[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
 
 eghcup rm $(ghc --numeric-version)
 
-# https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
-if [ "${OS}" = "LINUX" ] ; then
-	if [ "${ARCH}" = "64" ] ; then
-		eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4
-		eghcup rm cabal 3.4.0.0-rc4
-	fi
-fi
-
-sha_sum() {
-	if [ "${OS}" = "FREEBSD" ] ; then
-		sha256 "$@"
-	else
-		sha256sum "$@"
-	fi
-
-}
-
-# test etags
-rm -f "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
-raw_eghcup -s https://www.haskell.org/ghcup/data/ghcup-${JSON_VERSION}.yaml list
-# snapshot yaml and etags file
-etag=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
-sha=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
-# invalidate access time timer, which is 5minutes, so we re-download
-touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
-# redownload same file with some newlines added
-raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
-# snapshot new yaml and etags file
-etag2=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
-sha2=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
-# compare
-[ "${etag}" != "${etag2}" ]
-[ "${sha}" != "${sha2}" ]
-# invalidate access time timer, which is 5minutes, but don't expect a re-download
-touch -a -m -t '199901010101' "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml"
-# this time, we expect the same hash and etag
-raw_eghcup -s https://www.haskell.org/ghcup/exp/ghcup-${JSON_VERSION}.yaml list
-etag3=$(cat "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml.etags")
-sha3=$(sha_sum "${GHCUP_DIR}/cache/ghcup-${JSON_VERSION}.yaml")
-[ "${etag2}" = "${etag3}" ]
-[ "${sha2}" = "${sha3}" ]
-
-# test isolated installs
-eghcup install ghc -i "$(pwd)/isolated" 8.10.5
-[ "$(isolated/bin/ghc --numeric-version)" = "8.10.5" ]
-! eghcup install ghc -i "$(pwd)/isolated" 8.10.5
-if [ "${ARCH}" = "64" ] ; then
-	if [ "${OS}" = "LINUX" ] || [ "${OS}" = "WINDOWS" ] ; then
-		eghcup install cabal -i "$(pwd)/isolated" 3.4.0.0
-		[ "$(isolated/cabal --numeric-version)" = "3.4.0.0" ]
-		eghcup install stack -i "$(pwd)/isolated" 2.7.3
-		[ "$(isolated/stack --numeric-version)" = "2.7.3" ]
-		eghcup install hls -i "$(pwd)/isolated" 1.3.0
-		[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0" ] ||
-			[ "$(isolated/haskell-language-server-wrapper --numeric-version)" = "1.3.0.0" ]
-	fi
-fi
-
 eghcup upgrade
 eghcup upgrade -f
 
-
-# nuke
-eghcup nuke
-[ ! -e "${GHCUP_DIR}" ]

.gitlab/script/hlint.sh

@@ -1,19 +0,0 @@
-#!/bin/sh
-
-set -eux
-
-. "$( cd "$(dirname "$0")" ; pwd -P )/../ghcup_env"
-
-mkdir -p "$CI_PROJECT_DIR"/.local/bin
-
-ecabal() {
-	cabal --store-dir="$(pwd)"/.store "$@"
-}
-
-git describe
-
-ecabal update
-ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint
-
-hlint -r lib/ test/ 
-

.gitlab/shell.nix

@@ -1,90 +0,0 @@
-{ system ? "aarch64-darwin"
-#, nixpkgs ? fetchTarball https://github.com/angerman/nixpkgs/archive/257cb120334.tar.gz #apple-silicon.tar.gz
-, pkgs ? import <nixpkgs> { inherit system; }
-, compiler ? if system == "aarch64-darwin" then "ghc8103Binary" else "ghc8103"
-}: pkgs.mkShell {
-  # this prevents nix from trying to write the env-vars file.
-  # we can't really, as NIX_BUILD_TOP/env-vars is not set.
-  noDumpEnvVars=1;
-
-  # stop polluting LDFLAGS with -liconv
-  dontAddExtraLibs = true;
-
-  # we need to inject ncurses into --with-curses-libraries.
-  # the real fix is to teach terminfo to use libcurses on macOS.
-  # CONFIGURE_ARGS = "--with-intree-gmp --with-curses-libraries=${pkgs.ncurses.out}/lib";
-  CONFIGURE_ARGS = "--with-intree-gmp --with-curses-libraries=/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib --with-iconv-includes=/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/include --with-iconv-libraries=/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib SH=/bin/bash";
-
-  # magic speedup pony :facepalm:
-  #
-  # nix has the ugly habbit of duplicating ld flags more than necessary.  This
-  # somewhat consolidates this.
-  shellHook = ''
-  export NIX_LDFLAGS=$(for a in $NIX_LDFLAGS; do echo $a; done |sort|uniq|xargs)
-  export NIX_LDFLAGS_FOR_TARGET=$(for a in $NIX_LDFLAGS_FOR_TARGET; do echo $a; done |sort|uniq|xargs)
-  export NIX_LDFLAGS_FOR_TARGET=$(comm -3 <(for l in $NIX_LDFLAGS_FOR_TARGET; do echo $l; done) <(for l in $NIX_LDFLAGS; do echo $l; done))
-
-
-  # Impurity hack for GHC releases.
-  #################################
-  # We don't want binary releases to depend on nix, thus we'll need to make sure we don't leak in references.
-  # GHC externally depends only on iconv and curses.  However we can't force a specific curses library for
-  # the terminfo package, as such we'll need to make sure we only look in the system path for the curses library
-  # and not pick up the tinfo from the nix provided ncurses package.
-  #
-  # We also need to force us to use the systems COREFOUNDATION, not the one that nix builds. Again this is impure,
-  # but it will allow us to have proper binary distributions.
-  #
-  # do not use nixpkgs provided core foundation
-  export NIX_COREFOUNDATION_RPATH=/System/Library/Frameworks
-  # drop curses from the LDFLAGS, we really want the system ones, not the nix ones.
-  export NIX_LDFLAGS=$(for lib in $NIX_LDFLAGS; do case "$lib" in *curses*);; *) echo -n "$lib ";; esac; done;)
-  export NIX_CFLAGS_COMPILE+=" -Wno-nullability-completeness -Wno-availability -Wno-expansion-to-defined -Wno-builtin-requires-header -Wno-unused-command-line-argument"
-
-  # unconditionally add the MacOSX.sdk and TargetConditional.h
-  export NIX_CFLAGS_COMPILE+=" -isystem /Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/include"
-  export NIX_LDFLAGS="-L/Library/Developer/CommandLineTools/SDKs/MacOSX.sdk/usr/lib $NIX_LDFLAGS"
-
-  '';
-
-  nativeBuildInputs = (with pkgs; [
-    # This needs to come *before* ghc,
-    # otherwise we migth end up with the clang from
-    # the bootstrap GHC in PATH with higher priority.
-    clang_11
-    llvm_11
-
-    haskell.compiler.${compiler}
-    haskell.packages.${compiler}.cabal-install
-    haskell.packages.${compiler}.alex
-    haskell.packages.${compiler}.happy # _1_19_12 is needed for older GHCs.
-
-    automake
-    autoconf
-    m4
-
-    gmp
-    zlib.out
-    zlib.dev
-    glibcLocales
-    # locale doesn't build yet :-/
-    # locale
-
-    git
-
-    python3
-    # python3Full
-    # python3Packages.sphinx
-    perl
-
-    which
-    wget
-	curl
-    file
-
-    xz
-    xlibs.lndir
-
-    cacert ])
-  ++ (with pkgs.darwin.apple_sdk.frameworks; [ Foundation Security ]);
-}

.hlint.yaml

@@ -1,83 +0,0 @@
-# HLint configuration file
-# https://github.com/ndmitchell/hlint
-##########################
-
-# This file contains a template configuration file, which is typically
-# placed as .hlint.yaml in the root of your project
-
-
-# Warnings currently triggered by your code
-- ignore: {name: "Redundant bang pattern"}
-- ignore: {name: "Use camelCase"}
-- ignore: {name: "Use if"}
-- ignore: {name: "Use newtype instead of data"}
-- ignore: {name: "Use <$>"}
-- ignore: {name: "Use mapMaybe"}
-- ignore: {name: "Use const"}
-- ignore: {name: "Use list comprehension"}
-- ignore: {name: "Redundant multi-way if"}
-- ignore: {name: "Redundant lambda"}
-- ignore: {name: "Avoid lambda"}
-- ignore: {name: "Use uncurry"}
-- ignore: {name: "Use replicateM"}
-- ignore: {name: "Redundant irrefutable pattern"}
-
-
-# Specify additional command line arguments
-#
-# - arguments: [--color, --cpp-simple, -XQuasiQuotes]
-
-
-# Control which extensions/flags/modules/functions can be used
-#
-# - extensions:
-#   - default: false # all extension are banned by default
-#   - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used
-#   - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module
-#
-# - flags:
-#   - {name: -w, within: []} # -w is allowed nowhere
-#
-# - modules:
-#   - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set'
-#   - {name: Control.Arrow, within: []} # Certain modules are banned entirely
-#
-# - functions:
-#   - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
-
-
-# Add custom hints for this project
-#
-# Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar"
-# - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x}
-
-# The hints are named by the string they display in warning messages.
-# For example, if you see a warning starting like
-#
-# Main.hs:116:51: Warning: Redundant ==
-#
-# You can refer to that hint with `{name: Redundant ==}` (see below).
-
-# Turn on hints that are off by default
-#
-# Ban "module X(module X) where", to require a real export list
-# - warn: {name: Use explicit module export list}
-#
-# Replace a $ b $ c with a . b $ c
-# - group: {name: dollar, enabled: true}
-#
-# Generalise map to fmap, ++ to <>
-# - group: {name: generalise, enabled: true}
-
-
-# Ignore some builtin hints
-# - ignore: {name: Use let}
-# - ignore: {name: Use const, within: SpecialModule} # Only within certain modules
-
-
-# Define some custom infix operators
-# - fixity: infixr 3 ~^#^~
-
-
-# To generate a suitable file for HLint do:
-# $ hlint --default > .hlint.yaml

.travis.yml

@@ -10,16 +10,16 @@ jobs:
       language: generic
       env: ARTIFACT=x86_64-apple-darwin-10.14-ghcup
 
-
 script: ".travis/build.sh"
 
 deploy:
   provider: releases
   api_key:
-    secure: "hT2od8Iy04tdFVuonPSWv0NX5hZDmv4al8Q0GbIWmviUetROuM7c6/MCHUcgyiw6H2L3pmH4F24GBYWpKBT3ZMbxrKXhZOZ3KPLXzlnuRlm1qymKqqwsJs3466bMftaiBr16rx1VpAuditN4A32oSmTFcQAJc84Bxn2WZ4t8hk9muS8YPyLhqg3/NxT6ob8dzNp9eS2cA0WODMb/fMzaMruRtepSK8JvuXb/SnTvaDcl9plmPzEa+eW54jwVsDps8ZpQMQlTtGIjYHIwTQ36/iLH4LoAvD7OEnB7qf753LOzmI/bvlB75xYGsLxe1qgpzPMjuG3AK0jb2KGSZCzyAyrbBFSQMIyC1gNKMtab3CohnA9WdQqAT1xrzPzA9zNw516G5Fn/z+t9Ek1f6L2OYO2hJfweNhWh+ChAIsOags2QBpqc0qjkwUS4wqxCWBdyVfgPTUoGelvjCfjQgypgIyLEHFvXt9rlj+kd97FY7nG3vxZrsvWTKKKT551OqUYX5zWTyvGR71jKyNst/p93Pg3DkRy31gHrGnG9zfNgN5tWxJqDd/suR/BAFTp0VtkFb8fR3ct7WMVeJXtE2+bKqxO5Fnocs1VjEm8pKPk7glnp0muu08kaO0h54wiSOCbk1RvO1KZtHue4wKWrHcI18dwW2WtzoBQ4P1lOSkS81UY="
+    secure: GQESg4TcYf3PQJRRaZV/kWS0hsF+OFnH2+EcwpgnIcfx4+aogMyprdh745KtBXe1FlFN1luKHksFjqceqhcg/xcNyeCJiSnLWMn4D/i4WUperEHseRBi5yZZCB1AvOjIlHrE4DS3a8pyEm1GV3G7CKY5Fu8jBjof2SnyENfd7fofhjtNHWmeFS+jBn8HRDf1YaSRYxzTw6uHLrPLsybfgQZVl7babMu/38Ghin0f5pz5OlNokzDxaubIYQHOZ7st7YndHJtBWWql/KualBWbMILy88dUVQBnbqQLP2P8d1ME8ILUjJVqz33HiRU0JzlEJyWfbvEjcJ6iD8M6n4nXTaxfu3i2UhhGsQ6SSBNKssMP4tji8nkNpMqG59wLQ/zhcetEm71fKkgJNrIMNllkqlWSo5K74IqqP9kiLg/qm8ipOJjui0gPk8tZXKcV+ztX1d1OVCapoLfiDM5l/0LLQXaTOXOV1x3e5LLQ/w2doNiH3eh5CV4II9dRu7owpaiiMBHMssmT0pH99jEeF6giHLKtt3y7l2GWoRLPdhsZZ54gxsaBxZt9GuypmkbNcr97CEnAVaWij5v0CF3w4rAWqy/tAxQpIDJOIOQBgmwG5WrBAKyKrFvEpBL5a8BPcRWJDvqKC83QeWpvPrEVdgJevC6ZN1MKzrb2SiPOwC2Kerc=
   file: $ARTIFACT
   on:
-    repo: hasufell/ghcup-hs
+    repo: haskell/ghcup-hs
     tags: true
   skip_cleanup: true
   draft: true
+

.travis/build.sh

@@ -1,28 +1,22 @@
-#!/bin/sh
+#/bin/sh
 
 set -ex
 
+## install ghc via old ghcup
+
 mkdir -p ~/.ghcup/bin
-curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ~/.ghcup/bin/ghcup
+curl https://gitlab.haskell.org/haskell/ghcup/raw/master/ghcup > ~/.ghcup/bin/ghcup
 chmod +x ~/.ghcup/bin/ghcup
 
 export PATH="$HOME/.ghcup/bin:$PATH"
 
-ghcup install 8.10.4
-ghcup install-cabal 3.4.0.0
-ghcup set 8.10.4
+ghcup install 8.8.3
+ghcup install-cabal 3.2.0.0
+ghcup set 8.8.3
 
 
 ## install ghcup
 
 cabal update
-
-(
-       cd /tmp
-       cabal install --installdir="$HOME"/.ghcup/bin hspec-discover
-)
-
-cabal build --constraint="zlib +static" --constraint="lzma +static" -ftui
-cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
-strip ./ghcup
-cp ghcup "./${ARTIFACT}"
+cabal build -fcurl
+cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" "./${ARTIFACT}"

CHANGELOG.md

@@ -0,0 +1,24 @@
+# Revision history for ghcup
+
+## 0.1.4 -- 2020-04-16
+
+* build on all platforms with curl (as a binary), wrt https://gitlab.haskell.org/haskell/ghcup-hs/issues/6
+* Fix unlinking of ghc symlinks after new installation, wrt https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
+
+## 0.1.3 -- 2020-04-15
+
+* Fix lesser bug when skipping ghcup update
+
+## 0.1.2 -- 2020-04-15
+
+* Fix bug when removing the set GHC version
+* Fix use of undocumented `GHCUP_INSTALL_BASE_PREFIX` variable
+* skip upgrade if ghcup is already latest version
+
+## 0.1.1 -- 2020-04-15
+
+* fix awful fdopendir bug on mac bug by updating hpath-posix
+
+## 0.1.0
+
+* First version. Released on an unsuspecting world.

Dockerfile

@@ -0,0 +1,42 @@
+FROM alpine:edge
+
+# ghc and cabal
+RUN apk add --no-cache \
+	curl \
+	gcc \
+	g++ \
+	gmp-dev \
+	ncurses-dev \
+	libffi-dev \
+	make \
+	xz \
+	tar \
+	perl \
+	\
+	cabal \
+	ghc
+
+# utils
+RUN apk add --no-cache \
+	bash
+
+## Package specific
+RUN apk add --no-cache \
+	zlib \
+	zlib-dev \
+	zlib-static \
+	gmp \
+	gmp-dev \
+	openssl-dev \
+	openssl-libs-static \
+	xz \
+	xz-dev
+
+RUN cabal v2-update
+
+COPY . /app
+
+WORKDIR /app
+
+RUN chmod +x /app/docker/build.sh
+

HACKING.md

@@ -6,6 +6,10 @@
 
 This is an open variant, similar to [plucky](https://hackage.haskell.org/package/plucky) or [oops](https://github.com/i-am-tom/oops) and allows us to combine different error types. Maybe it is too much and it's a little bit [unergonomic](https://github.com/haskus/packages/issues/32) at times. If it really hurts maintenance, it will be removed. It was more of an experiment.
 
+### No use of filepath or directory
+
+Filepath and directory have two fundamental problems: 1. they use String as filepath (see [AFPP](https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/abstract-file-path) as to why this is wrong) and 2. they try very hard to be cross-platform at the expense of low-level correctness. Instead, we use the [hpath](https://github.com/hasufell/hpath) libraries for file and filepath related stuff, which also gives us stronger filepath types.
+
 ### No use of haskell-TLS
 
 I consider haskell-TLS an interesting experiment, but not a battle-tested and peer-reviewed crypto implementation. There is little to no research about what the intricacies of using haskell for low-level crypto are and how vulnerable such binaries are. Instead, we use either curl the binary (for FreeBSD and mac) or http-io-streams, which works with OpenSSL bindings.
@@ -39,37 +43,3 @@ Kazu Yamamoto [explained it in his PR](https://github.com/yesodweb/wai/pull/752#
 1. Brittany
 2. mtl-style preferred
 3. no overly pointfree style
-
-## Code structure
-
-Main functionality is in `GHCup` module. Utility functions are
-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 appropriate
-yaml files: `ghcup-<yaml-ver>.yaml`.
-
-## Common Tasks
-
-### Adding a new GHC version
-
-1. open the latest `ghcup-<yaml-ver>.yaml`
-2. find the latest ghc version (in yaml tree e.g. `ghcupDownloads -> GHC -> 8.10.3`)
-3. copy-paste it
-4. adjust the version, tags, changelog, source url
-5. adjust the various bindist urls (make sure to also change the yaml anchors)
-6. run `cabal run exe:ghcup-gen -- check-tarballs -f ghcup-<yaml-ver>.yaml -u 'ghc-8\.10\.4'`
-
-## Major refactors
-
-1. First major refactor included adding cross support. This added
-   `GHCTargetVersion`, which includes the target in addition to the version.
-   Most of the `Version` parameters to functions had to be replaced with
-   that and ensured the logic is consistent for cross and non-cross
-   installs.
-2. This refactor added windows support wrt [#130](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/130).
-   The major changes here were switching `hpath` library out for `filepath`/`directory` (sadly) and
-   introducing a non-unix way of handling processes via the `process` library. It also introduced considerable
-   amounts of CPP wrt file handling, installation etc.

README.md

@@ -1,33 +1,16 @@
 `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 from scratch.
+macOS (aka Darwin) and FreeBSD and can also bootstrap a fresh Haskell developer environment from scratch.
 It follows the unix UNIX philosophy of [do one thing and do it well](https://en.wikipedia.org/wiki/Unix_philosophy#Do_One_Thing_and_Do_It_Well).
 
 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).
 
+*Ubuntu users may prefer [hvr's ppa](https://launchpad.net/~hvr/+archive/ubuntu/ghc).*
+
 ## Table of Contents
 
-[![Join the chat at Libera.chat](https://img.shields.io/badge/chat-on%20libera%20IRC-brightgreen.svg)](https://kiwiirc.com/nextclient/irc.libera.chat/?nick=Guest%7C?#haskell,#haskell-ghcup)
-[![Join the chat at Matrix.org](https://img.shields.io/matrix/haskell-tooling:matrix.org?label=chat%20on%20matrix.org)](https://app.element.io/#/room/#haskell-tooling:matrix.org)
-[![Join the chat at Discord](https://img.shields.io/discord/280033776820813825?label=chat%20on%20discord)](https://discord.gg/pKYf3zDQU7)
-[![Join the chat at https://gitter.im/haskell/ghcup](https://badges.gitter.im/haskell/ghcup.svg)](https://gitter.im/haskell/ghcup?utm_source=badge&utm_medium=badge&utm_campaign=pr-badge&utm_content=badge)
-<a href="https://opencollective.com/ghcup#category-CONTRIBUTE"><img src="https://opencollective.com/webpack/donate/button@2x.png?color=blue" alt="Donate" width="150"></a>
-
    * [Installation](#installation)
-     * [Supported platforms](#supported-platforms)
-     * [Manual install](#manual-install)
-     * [Vim integration](#vim-integration)
    * [Usage](#usage)
-     * [Configuration](#configuration)
-     * [GPG verification](#gpg-verification)
      * [Manpages](#manpages)
-     * [Shell-completion](#shell-completion)
-     * [Compiling GHC from source](#compiling-ghc-from-source)
-     * [XDG support](#xdg-support)
-     * [Env variables](#env-variables)
-     * [Installing custom bindists](#installing-custom-bindists)
-     * [Isolated Installs](#isolated-installs)
-     * [CI](#ci)
-     * [Tips and tricks](#tips-and-tricks)
    * [Design goals](#design-goals)
    * [How](#how)
    * [Known users](#known-users)
@@ -36,59 +19,9 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p
 
 ## Installation
 
-Most users should follow the instructions at [https://www.haskell.org/ghcup/](https://www.haskell.org/ghcup/).
-Advanced users may want to perform a [manual installation](#manual-install).
+### Simple bootstrap
 
-### Supported platforms
-
-This list may not be exhaustive and specifies support for bindists only.
-
-| Platform | Architecture | ghcup | GHC | cabal | HLS | stack | 
-| ------ | ------ | ------ | ------ | ------ | ------ | ------ |
-| Windows 7 | amd64 | ❔ | ✅ | ✅ | ✅ | ✅ |
-| Windows 10 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
-| Windows Server 2016 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
-| Windows Server 2019 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
-| Windows Server 2022 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
-| Windows WSL1 | amd64 | ❌ | ❔ | ❔ | ❔ | ❔ |
-| Windows WSL2 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
-| MacOS >=13 | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
-| MacOS <13 | amd64 | ❌ | ❔ | ❔ | ❔ | ❔ |
-| MacOS | aarch64 | ✅ | ✅ | ✅ | ⚠️ | ❌ |
-| FreeBSD | amd64 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ |
-| Linux generic | x86 | ✅ | ✅ | ✅ | ✅ | ✅ |
-| Linux generic | amd64 | ✅ | ✅ | ✅ | ✅ | ✅ |
-| Linux generic | aarch64 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ |
-| Linux generic | armv7 | ✅ | ⚠️ | ✅ | ⚠️ | ❌ |
-
-#### Windows 7
-
-May or may not work, several issues:
-
-* https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/140
-* https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/197
-
-#### WSL1
-
-Unsupported. GHC may or may not work. Upgrade to WSL2.
-
-#### MacOS <13
-
-Not supported. Would require separate binaries, since >=13 binaries are incompatible.
-Please upgrade.
-
-#### MacOS aarch64
-
-HLS bindists are still experimental. Stack is theoretically supported, but has no binaries yet.
-
-#### FreeBSD
-
-Lacks some upstream bindists and may need compat libs, since most bindists are built on FreeBSD-12.
-HLS bindists are experimental.
-
-#### Linux ARMv7/AARCH64
-
-Lower availability of bindists. HLS only has experimental ones. Stack not supported currently.
+Follow the instructions at [https://www.haskell.org/ghcup/](https://www.haskell.org/ghcup/)
 
 ### Manual install
 
@@ -101,314 +34,40 @@ Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) lik
 export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
 ```
 
-### Vim integration
-
-See [ghcup.vim](https://github.com/hasufell/ghcup.vim).
-
 ## Usage
 
 See `ghcup --help`.
 
-For the simple interactive TUI, run:
-
-```sh
-ghcup tui
-```
-
-For the full functionality via cli:
+Common use cases are:
 
 ```sh
 # list available ghc/cabal versions
 ghcup list
 
 # install the recommended GHC version
-ghcup install ghc
+ghcup install
 
 # install a specific GHC version
-ghcup install ghc 8.2.2
+ghcup install 8.2.2
 
 # set the currently "active" GHC version
-ghcup set ghc 8.4.4
+ghcup set 8.4.4
 
 # install cabal-install
-ghcup install cabal
+ghcup install-cabal
 
 # update ghcup itself
 ghcup upgrade
 ```
 
-GHCup works very well with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
+Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
 handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler)  of `ghc` is available, which `ghcup` can do.
 
-### Configuration
-
-A configuration file can be put in `~/.ghcup/config.yaml`. The default config file
-explaining all possible configurations can be found in this repo: [config.yaml](./data/config.yaml).
-
-Partial configuration is fine. Command line options always override the config file settings.
-
-### 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 key:
-
-```sh
-gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
-```
-
-Then verify the gpg key in one of these ways:
-
-1. find out where I live and visit me to do offline key signing
-2. figure out my mobile phone number and call me to verify the fingerprint
-3. more boring: contact me on Libera IRC (`maerwald`) and verify the fingerprint
-
-Once you've verified the key, you have to figure out if you trust me.
-
-If you trust me, then you can configure gpg in `~/.ghcup/config.yaml`:
-
-```yml
-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>`.
-
 ### Manpages
 
 For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc.
 `MANPATH` may be required to be unset.
 
-### Shell-completion
-
-Shell completions are in [scripts/shell-completions](./scripts/shell-completions) directory of this repository.
-
-For bash: install `shell-completions/bash`
-as e.g. `/etc/bash_completion.d/ghcup` (depending on distro)
-and make sure your bashrc sources the startup script
-(`/usr/share/bash-completion/bash_completion` on some distros).
-
-### Compiling GHC from source
-
-Compiling from source is supported for both source tarballs and arbitrary git refs. See `ghcup compile ghc --help`
-for a list of all available options.
-
-If you need to overwrite the existing `build.mk`, check the default files
-in [data/build_mk](./data/build_mk), copy them somewhere, adjust them and
-pass `--config path/to/build.mk` to `ghcup compile ghc`.
-Common `build.mk` options are explained [here](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/using#build-configuration).
-
-Make sure your system meets all the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/preparation).
-
-#### Cross support
-
-ghcup can compile and install a cross GHC for any target. However, this
-requires that the build host has a complete cross toolchain and various
-libraries installed for the target platform.
-
-Consult the GHC documentation on the [prerequisites](https://gitlab.haskell.org/ghc/ghc/-/wikis/building/cross-compiling#tools-to-install).
-For distributions with non-standard locations of cross toolchain and
-libraries, this may need some tweaking of `build.mk` or configure args.
-See `ghcup compile ghc --help` for further information.
-
-### XDG support
-
-To enable XDG style directories, set the environment variable `GHCUP_USE_XDG_DIRS` to anything.
-
-Then you can control the locations via XDG environment variables as such:
-
-* `XDG_DATA_HOME`: GHCs will be unpacked in `ghcup/ghc` subdir (default: `~/.local/share`)
-* `XDG_CACHE_HOME`: logs and download files will be stored in `ghcup` subdir (default: `~/.cache`)
-* `XDG_BIN_HOME`: binaries end up here (default: `~/.local/bin`)
-* `XDG_CONFIG_HOME`: the config file is stored in `ghcup` subdir as `config.yaml` (default: `~/.config`)
-
-**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.
-
-
-- No symlinks are made to these isolated installed tools, you'd have to manually point to them wherever you intend to use them.
-
-- These installs, can also NOT be deleted from ghcup, you'd have to go and manually delete these.
-
-You need to use the `--isolate` or `-i` flag followed by the directory path.
-
-Examples:-
-
-1. install an isolated GHC version at location /home/user/isolated_dir/ghc/  
-   - `ghcup install ghc 8.10.5 --isolate /home/user/isolated_dir/ghc`
-
-2. isolated install Cabal at a location you desire  
-   - `ghcup install cabal --isolate /home/username/my_isolated_dir/`
-
-3. do an isolated install with a custom bindist  
-   - `ghcup install ghc --isolate /home/username/my_isolated_dir/ -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`
-
-4. isolated install HLS  
-   - `ghcup install hls --isolate /home/username/dir/hls/`
-
-5. you can even compile ghc to an isolated location.  
-   - `ghcup compile ghc -j 4 -v 9.0.1 -b 8.10.5 -i /home/username/my/dir/ghc` 
-   ---  
-
-### CI
-
-On windows, ghcup can be installed automatically on a CI runner like so:
-
-```ps
-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:\"
-```
-
-On linux/darwin/freebsd, run the following on your runner:
-
-```sh
-curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | BOOTSTRAP_HASKELL_NONINTERACTIVE=1 BOOTSTRAP_HASKELL_MINIMAL=1 sh
-```
-
-This will just install `ghcup` and on windows additionally `msys2`.
-
-#### Example github workflow
-
-On github workflows you can use https://github.com/haskell/actions/
-
-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
-```
-   
-### Tips and tricks
-
-#### with_ghc wrapper (e.g. for HLS)
-
-Due to some HLS [bugs](https://github.com/mpickering/hie-bios/issues/194) it's necessary that the `ghc` in PATH
-is the one defined in `cabal.project`. With some simple shell functions, we can start our editor with the appropriate
-path prepended.
-
-For bash, in e.g. `~/.bashrc` define:
-
-```sh
-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
-}
-```
-
-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.
-
 ## Design goals
 
 1. simplicity
@@ -437,27 +96,10 @@ In addition this script can also install `cabal-install`.
 
 ## Known users
 
-* Github actions:
-	- [actions/virtual-environments](https://github.com/actions/virtual-environments)
-	- [haskell/actions/setup](https://github.com/haskell/actions/tree/main/setup)
-* mirrors:
-	- [sjtug](https://mirror.sjtu.edu.cn/docs/ghcup)
-* tools:
-	- [vabal](https://github.com/Franciman/vabal)
+* [vabal](https://github.com/Franciman/vabal)
 
 ## Known problems
 
-### Custom ghc version names
-
-When installing ghc bindists with custom version names as outlined in
-[installing custom bindists](#installing-custom-bindists), then cabal might
-be unable to find the correct `ghc-pkg` (also see [#73](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/73))
-if you use `cabal build --with-compiler=ghc-foo`. Instead, point it to the full path, such as:
-`cabal build --with-compiler=$HOME/.ghcup/ghc/<version-name>/bin/ghc` or set that GHC version
-as the current one via: `ghcup set ghc <version-name>`.
-
-This problem doesn't exist for regularly installed GHC versions.
-
 ### Limited distributions supported
 
 Currently only GNU/Linux distributions compatible with the [upstream GHC](https://www.haskell.org/ghc/download_ghc_8_6_1.html#binaries) binaries are supported.
@@ -490,110 +132,16 @@ to figure out whether you have the correct toolchain and
 the correct dependencies. Refer to [the official docs](https://ghc.haskell.org/trac/ghc/wiki/Building/Preparation/Linux)
 on how to prepare your environment for building GHC.
 
-### Stack support
-
-There may be a number of bugs when trying to make ghcup installed GHC versions work with stack,
-such as:
-
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/188
-
-Further, stack's upgrade procedure may break/confuse ghcup. There are a number of integration
-issues discussed here:
-
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/153
-
-### Windows support
-
-Windows support is in early stages. Since windows doesn't support symbolic links properly,
-ghcup uses a [shimgen wrapper](https://github.com/71/scoop-better-shimexe). It seems to work
-well, but there may be unknown issues with that approach.
-
-Windows 7 and Powershell 2.0 aren't well supported at the moment, also see:
-
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/140
-- https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/197
-
 ## FAQ
 
-### Why reimplement stack?
+1. Why reimplement stack?
 
-GHCup is not a reimplementation of stack. The only common part is automatic installation of GHC,
-but even that differs in scope and design.
+ghcup is not a reimplementation of stack. The only common part is automatic installation of GHC, but even that differs in scope and design.
 
-### Why should I use ghcup over stack?
+2. Why not support windows?
 
-GHCup is not a replacement for stack. Instead, it supports installing and managing stack versions.
-It does the same for cabal, GHC and HLS. As such, It doesn't make a workflow choice for you.
+Consider using [Chocolatey](https://chocolatey.org/search?q=ghc) or [ghcups](https://github.com/kakkun61/ghcups).
 
-### Why should I let ghcup manage stack?
+3. Why the haskell reimplementation?
 
-You don't need to. However, some users seem to prefer to have a central tool that manages cabal and stack
-at the same time. Additionally, it can allow better sharing of GHC installation across these tools.
-Also see:
-
-* https://docs.haskellstack.org/en/stable/yaml_configuration/#system-ghc
-* https://github.com/commercialhaskell/stack/pull/5585
-
-### Why does ghcup not use stack code?
-
-Oddly, this question has been asked a couple of times. For the curious, here are a few reasons:
-
-1. GHCup started as a shell script. At the time of rewriting it in Haskell, the authors didn't even know that stack exposes *some* of its [installation API](https://hackage.haskell.org/package/stack-2.5.1.1/docs/Stack-Setup.html)
-2. Even if they did, it doesn't seem it would have satisfied their needs
-	  - it didn't support cabal installation, which was the main motivation behind GHCup back then
-	  - depending on a codebase as big as stack for a central part of one's application without having a short contribution pipeline would likely have caused stagnation or resulted in simply copy-pasting the relevant code in order to adjust it
-	  - it's not clear how GHCup would have been implemented with the provided API. It seems the codebases are fairly different. GHCup does a lot of symlink handling to expose a central `bin/` directory that users can easily put in PATH, without having to worry about anything more. It also provides explicit removal functionality, GHC cross-compilation, a TUI, etc etc.
-3. GHCup is built around unix principles and supposed to be simple.
-
-### Why not unify...
-
-#### ...stack and Cabal and do away with standalone installers
-
-GHCup is not involved in such decisions. cabal-install and stack might have a
-sufficiently different user experience to warrant having a choice.
-
-#### ...installer implementations and have a common library
-
-This sounds like an interesting goal. However, GHC installation isn't a hard engineering problem
-and the shared code wouldn't be too exciting. For such an effort to make sense, all involved
-parties would need to collaborate and have a short pipeline to get patches in.
-
-It's true this would solve the integration problem, but following unix principles, we can
-do similar via **hooks**. Both cabal and stack can support installation hooks. These hooks
-can then call into ghcup or anything else, also see:
-
-* https://github.com/haskell/cabal/issues/7394
-* https://github.com/commercialhaskell/stack/pull/5585
-
-#### ...installers (like, all of it)
-
-So far, there hasn't been an **open** discussion about this. Is this even a good idea?
-Sometimes projects converge eventually if their overlap is big enough, sometimes they don't.
-
-While unification sounds like a simplification of the ecosystem, it also takes away choice.
-Take `curl` and `wget` as an example.
-
-How bad do we need this?
-
-### Why not support windows?
-
-Windows is supported since GHCup version 0.1.15.1.
-
-### Why the haskell reimplementation?
-
-GHCup started as a portable posix shell script of maybe 50 LOC. GHC installation itself can be carried out in
-about ~3 lines of shell code (download, unpack , configure+make install). However, much convenient functionality
-has been added since, as well as ensuring that all operations are safe and correct. The shell script ended up with
-over 2k LOC, which was very hard to maintain.
-
-The main concern when switching from a portable shell script to haskell was platform/architecture support.
-However, ghcup now re-uses GHCs CI infrastructure and as such is perfectly in sync with all platforms that
-GHC supports.
-
-### Is GHCup affiliated with the Haskell Foundation?
-
-There has been some collaboration: Windows and Stack support were mainly requested by the Haskell Foundation
-and those seemed interesting features to add.
-
-Other than that, GHCup is dedicated only to its users and is supported by haskell.org through hosting and CI
-infrastructure.
+Why not?

RELEASING.md

@@ -0,0 +1,11 @@
+# RELEASING
+
+1. update `GHCup.Version` module. `ghcupURL` must only be updated if we change the `_toolRequirements` type or the JSON representation of it. The version of the json represents the change increments. `ghcUpVer` is the current application version.
+
+2. Add/fix downloads to `GHCupDownloads` module, then run `ghcup-gen gen` to generate the new json and validate it via `ghcup-gen check`.
+
+3. Commit and git push with tag. Wait for tests to succeed.
+
+4. Upload the new `ghcup-<ver>.json` to `webhost.haskell.org/ghcup/data/`.
+
+5. Build ghcup releases for Linux (fully static), mac (with `-fcurl`) and FreeBSD (with `-fcurl`). Upload to `webhost.haskell.org/ghcup/bin/` and update symlinks.

TODO.md

@@ -2,38 +2,27 @@
 
 ## Now
 
-* ghcup init?
-* merge two download files
-* fetch/unpack functionality
-* installing multiple versions of the same
-* post-install
-
-* proper test suite
-
-* !! update of 0.1.5 must go in ghcup-0.0.1.json !!
-
-* try to run exe before upgrade (backup to ~/.ghcup/bin/ghcup.old)
-* stdout flushing?
-* resume support (for make-install only)
+* move out GHCup.Version module, bc it's not library-ish
 
 ## Maybe
 
-* version ranges in json
+* maybe: changelog          Show the changelog of a GHC release (online)
 * sign the JSON? (Or check gpg keys?)
 * testing (especially distro detection -> unit tests)
 
 ## Later
 
+* i386 support
 * add support for RC/alpha/HEAD versions
 
 ## Cleanups
 
+* too many decodeutf8
 * avoid alternative for IO
 * use plucky or oops instead of Excepts
 
 ## Questions
 
-* move out GHCup.Version module, bc it's not library-ish?
 * mirror support
 * interactive handling when distro doesn't exist and we know the tarball is incompatible?
 * ghcup-with wrapper to execute a command with a given ghc in PATH?

app/ghcup-gen/GHCupInfo.hs

@@ -0,0 +1,11 @@
+module GHCupInfo where
+
+import           GHCupDownloads
+import           ToolRequirements
+import           GHCup.Types
+
+
+ghcupInfo :: GHCupInfo
+ghcupInfo = GHCupInfo { _toolRequirements = toolRequirements
+                      , _ghcupDownloads   = ghcupDownloads
+                      }

app/ghcup-gen/Main.hs

@@ -11,41 +11,64 @@
 module Main where
 
 import           GHCup.Types
-import           GHCup.Errors
-import           GHCup.Platform
-import           GHCup.Utils.Dirs
-import           GHCup.Utils.Logger
 import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Logger
+import           GHCupInfo
 
-import           Control.Monad.Trans.Reader     ( runReaderT )
-import           Control.Monad.IO.Class
-import           Data.Char                      ( toLower )
-import           Data.Maybe
+import           Data.Aeson                     ( eitherDecode, encode )
+import           Data.Aeson.Encode.Pretty
 #if !MIN_VERSION_base(4,13,0)
 import           Data.Semigroup                 ( (<>) )
 #endif
 import           Options.Applicative     hiding ( style )
-import           Haskus.Utils.Variant.Excepts
 import           System.Console.Pretty
-import           System.Environment
 import           System.Exit
-import           System.IO                      ( stderr )
-import           Text.Regex.Posix
+import           System.IO                      ( stdout )
 import           Validate
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
-import qualified Data.Text.IO                  as T
-import qualified Data.Text                     as T
 import qualified Data.ByteString               as B
-import qualified Data.YAML.Aeson               as Y
+import qualified Data.ByteString.Lazy          as L
 
 
 data Options = Options
   { optCommand :: Command
   }
 
-data Command = ValidateYAML ValidateYAMLOpts
-             | ValidateTarballs ValidateYAMLOpts TarballFilter
+data Command = GenJSON GenJSONOpts
+             | ValidateJSON ValidateJSONOpts
+             | ValidateTarballs ValidateJSONOpts
+
+data Output
+  = FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
+  | StdOutput
+
+fileOutput :: Parser Output
+fileOutput =
+  FileOutput
+    <$> (strOption
+          (long "file" <> short 'f' <> metavar "FILENAME" <> help
+            "Output to a file"
+          )
+        )
+
+stdOutput :: Parser Output
+stdOutput = flag'
+  StdOutput
+  (short 'o' <> long "stdout" <> help "Print to stdout (default)")
+
+outputP :: Parser Output
+outputP = fileOutput <|> stdOutput
+
+
+data GenJSONOpts = GenJSONOpts
+  { output :: Maybe Output
+  , pretty :: Bool
+  }
+
+genJSONOpts :: Parser GenJSONOpts
+genJSONOpts = GenJSONOpts <$> optional outputP <*> switch
+  (short 'p' <> long "pretty" <> help "Make JSON output pretty (human readable)"
+  )
 
 
 data Input
@@ -55,10 +78,11 @@ data Input
 fileInput :: Parser Input
 fileInput =
   FileInput
-    <$> strOption
+    <$> (strOption
           (long "file" <> short 'f' <> metavar "FILENAME" <> help
             "Input file to validate"
           )
+        )
 
 stdInput :: Parser Input
 stdInput = flag'
@@ -68,90 +92,82 @@ stdInput = flag'
 inputP :: Parser Input
 inputP = fileInput <|> stdInput
 
-data ValidateYAMLOpts = ValidateYAMLOpts
-  { vInput :: Maybe Input
+data ValidateJSONOpts = ValidateJSONOpts
+  { input :: Maybe Input
   }
 
-validateYAMLOpts :: Parser ValidateYAMLOpts
-validateYAMLOpts = ValidateYAMLOpts <$> optional inputP
-
-tarballFilterP :: Parser TarballFilter
-tarballFilterP = option readm $
-  long "tarball-filter" <> short 'u' <> metavar "<tool>-<version>" <> value def
-    <> help "Only check certain tarballs (format: <tool>-<version>)"
-  where
-    def = TarballFilter (Right Nothing) (makeRegex ("" :: String))
-    readm = do
-      s <- str
-      case span (/= '-') s of
-        (_, []) -> fail "invalid format, missing '-' after the tool name"
-        (t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
-          pure (TarballFilter $ Right $ Just tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
-        (t, v) | [tool] <- [ tool | tool <- [minBound..maxBound], low (show tool) == low t ] ->
-          pure (TarballFilter $ Left tool) <*> makeRegexOptsM compIgnoreCase execBlank (drop 1 v)
-        _ -> fail "invalid tool"
-    low = fmap toLower
-
+validateJSONOpts :: Parser ValidateJSONOpts
+validateJSONOpts = ValidateJSONOpts <$> optional inputP
 
 opts :: Parser Options
 opts = Options <$> com
 
 com :: Parser Command
 com = subparser
-  (  command
+  (  (command
+       "gen"
+       (   GenJSON
+       <$> (info (genJSONOpts <**> helper)
+                 (progDesc "Generate the json downloads file")
+           )
+       )
+     )
+  <> (command
        "check"
-       (   ValidateYAML
-       <$> info (validateYAMLOpts <**> helper)
-                (progDesc "Validate the YAML")
+       (   ValidateJSON
+       <$> (info (validateJSONOpts <**> helper)
+                 (progDesc "Validate the JSON")
+           )
        )
-  <> command
+     )
+  <> (command
        "check-tarballs"
-       (info
-         ((ValidateTarballs <$> validateYAMLOpts <*> tarballFilterP) <**> helper)
-         (progDesc "Validate all tarballs (download and checksum)")
+       (   ValidateTarballs
+       <$> (info
+             (validateJSONOpts <**> helper)
+             (progDesc "Validate all tarballs (download and checksum)")
+           )
        )
+     )
   )
 
 
 
 main :: IO ()
 main = do
-  no_color <- isJust <$> lookupEnv "NO_COLOR"
-  let loggerConfig = LoggerConfig { lcPrintDebug  = True
-                                  , consoleOutter = T.hPutStr stderr
-                                  , fileOutter    = \_ -> pure ()
-                                  , fancyColors   = not no_color
-                                  }
-  dirs <- liftIO getAllDirs
-  let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings loggerConfig
-
-  pfreq <- (
-    flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
-    ) >>= \case
-            VRight r -> pure r
-            VLeft e -> do
-              flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
-              liftIO $ exitWith (ExitFailure 2)
-
-  let appstate = AppState (Settings True False Never Curl True GHCupURL False GPGNone False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
-
-  _ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
+  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
     >>= \Options {..} -> case optCommand of
-          ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)
-          ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
+          GenJSON gopts -> do
+            let bs True =
+                  encodePretty' (defConfig { confIndent = Spaces 2 }) ghcupInfo
+                bs False = encode ghcupInfo
+            case gopts of
+              GenJSONOpts { output = Nothing, pretty } ->
+                L.hPutStr stdout (bs pretty)
+              GenJSONOpts { output = Just StdOutput, pretty } ->
+                L.hPutStr stdout (bs pretty)
+              GenJSONOpts { output = Just (FileOutput file), pretty } ->
+                L.writeFile file (bs pretty)
+          ValidateJSON vopts -> case vopts of
+            ValidateJSONOpts { input = Nothing } ->
+              L.getContents >>= valAndExit validate
+            ValidateJSONOpts { input = Just StdInput } ->
+              L.getContents >>= valAndExit validate
+            ValidateJSONOpts { input = Just (FileInput file) } ->
+              L.readFile file >>= valAndExit validate
+          ValidateTarballs vopts -> case vopts of
+            ValidateJSONOpts { input = Nothing } ->
+              L.getContents >>= valAndExit validateTarballs
+            ValidateJSONOpts { input = Just StdInput } ->
+              L.getContents >>= valAndExit validateTarballs
+            ValidateJSONOpts { input = Just (FileInput file) } ->
+              L.readFile file >>= valAndExit validateTarballs
   pure ()
 
  where
-  withValidateYamlOpts vopts f = case vopts of
-    ValidateYAMLOpts { vInput = Nothing } ->
-      B.getContents >>= valAndExit f
-    ValidateYAMLOpts { vInput = Just StdInput } ->
-      B.getContents >>= valAndExit f
-    ValidateYAMLOpts { vInput = Just (FileInput file) } ->
-      B.readFile file >>= valAndExit f
   valAndExit f contents = do
-    (GHCupInfo _ av gt) <- case Y.decode1Strict contents of
+    (GHCupInfo _ av) <- case eitherDecode contents of
       Right r -> pure r
-      Left  (_, e) -> die (color Red $ show e)
-    f av gt
+      Left  e -> die (color Red $ show e)
+    myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
       >>= exitWith

app/ghcup-gen/ToolRequirements.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes       #-}
+
+module ToolRequirements where
+
+import           GHCup.Types
+import           GHCup.Utils.String.QQ
+
+import qualified Data.Map                      as M
+
+
+
+-- | Currently 'GHC' is used for both GHC and cabal to simplify
+-- this, until we need actual separation.
+toolRequirements :: ToolRequirements
+toolRequirements = M.fromList
+  [ ( GHC
+    , M.fromList
+      [ ( Nothing
+        , M.fromList
+          [ ( Linux UnknownLinux
+            , M.fromList
+              [ ( Nothing
+                , Requirements
+                  []
+                  [s|You need the following packages: curl g++ gcc gmp make ncurses realpath xz-utils. Consult your distro documentation on the exact names of those packages.|]
+                )
+              ]
+            )
+          , ( Linux Alpine
+            , M.fromList
+              [ ( Nothing
+                , Requirements
+                  [ "curl"
+                  , "gcc"
+                  , "g++"
+                  , "gmp-dev"
+                  , "ncurses-dev"
+                  , "libffi-dev"
+                  , "make"
+                  , "xz"
+                  , "tar"
+                  , "perl"
+                  ]
+                  ""
+                )
+              ]
+            )
+          , ( Linux Ubuntu
+            , M.fromList
+              [ ( Nothing
+                , Requirements
+                  [ "build-essential"
+                  , "curl"
+                  , "libgmp-dev"
+                  , "libffi-dev"
+                  , "libncurses-dev"
+                  , "libtinfo5"
+                  ]
+                  ""
+                )
+              ]
+            )
+          , ( Darwin
+            , M.fromList
+              [ ( Nothing
+                , Requirements
+                  []
+                  "On OS X, in the course of running ghcup you will be given a dialog box to install the command line tools. Accept and the requirements will be installed for you. You will then need to run the command again."
+                )
+              ]
+            )
+          , ( FreeBSD
+            , M.fromList
+              [ ( Nothing
+                , Requirements
+                  [ "curl"
+                  , "gcc"
+                  , "gmp"
+                  , "gmake"
+                  , "ncurses"
+                  , "perl5"
+                  , "libffi"
+                  , "libiconv"
+                  ]
+                  ""
+                )
+              ]
+            )
+          ]
+        )
+      ]
+    )
+  ]

app/ghcup-gen/Validate.hs

@@ -1,49 +1,35 @@
-{-# LANGUAGE CPP              #-}
-{-# LANGUAGE DataKinds        #-}
+{-# LANGUAGE TemplateHaskell  #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE QuasiQuotes      #-}
-{-# LANGUAGE TemplateHaskell  #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE ViewPatterns     #-}
-{-# LANGUAGE OverloadedStrings #-}
 
 module Validate where
 
 import           GHCup
 import           GHCup.Download
-import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Types.Optics
-import           GHCup.Utils
 import           GHCup.Utils.Logger
-import           GHCup.Utils.Version.QQ
 
-import           Codec.Archive
-import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
+import           Control.Monad.Logger
 import           Control.Monad.Reader.Class
 import           Control.Monad.Trans.Class      ( lift )
 import           Control.Monad.Trans.Reader     ( runReaderT )
 import           Control.Monad.Trans.Resource   ( runResourceT
                                                 , MonadUnliftIO
                                                 )
-import           Data.Containers.ListUtils      ( nubOrd )
 import           Data.IORef
 import           Data.List
+import           Data.String.Interpolate
 import           Data.Versions
 import           Haskus.Utils.Variant.Excepts
 import           Optics
-import           System.FilePath
 import           System.Exit
-import           Text.ParserCombinators.ReadP
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
-import           Text.Regex.Posix
+import           System.IO
 
+import qualified Data.ByteString               as B
 import qualified Data.Map.Strict               as M
-import qualified Data.Text                     as T
-import qualified Data.Version                  as V
 
 
 data ValidationError = InternalError String
@@ -58,14 +44,13 @@ addError = do
   liftIO $ modifyIORef ref (+ 1)
 
 
-validate :: (Monad m, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)
+validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
          => GHCupDownloads
-         -> M.Map GlobalTool DownloadInfo
          -> m ExitCode
-validate dls _ = do
+validate dls = do
   ref <- liftIO $ newIORef 0
 
-  -- verify binary downloads --
+  -- * verify binary downloads * --
   flip runReaderT ref $ do
     -- unique tags
     forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
@@ -74,50 +59,33 @@ validate dls _ = do
     forM_ (M.toList dls) $ \(t, versions) ->
       forM_ (M.toList versions) $ \(v, vi) ->
         forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
-          checkHasRequiredPlatforms t v (_viTags vi) arch (M.keys pspecs)
+          checkHasRequiredPlatforms t v arch (M.keys pspecs)
 
-    checkGHCVerIsValid
+    checkGHCisSemver
     forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
-    _ <- checkGHCHasBaseVersion
 
     -- exit
     e <- liftIO $ readIORef ref
     if e > 0
       then pure $ ExitFailure e
       else do
-        lift $ logInfo "All good"
+        lift $ $(logInfo) [i|All good|]
         pure ExitSuccess
  where
-  checkHasRequiredPlatforms t v tags arch pspecs = do
+  checkHasRequiredPlatforms t v arch pspecs = do
     let v' = prettyVer v
-        arch' = prettyShow arch
-    when (notElem (Linux UnknownLinux) pspecs) $ do
-      lift $ logError $
-        "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
+    when (not $ any (== Linux UnknownLinux) pspecs) $ do
+      lift $ $(logError)
+        [i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
       addError
-    when ((notElem Darwin pspecs) && arch == A_64) $ do
-      lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
+    when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
+      lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
       addError
-    when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
-      "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
-    when (notElem Windows pspecs && arch == A_64) $ do
-      lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
-      addError
-
-    -- alpine needs to be set explicitly, because
-    -- we cannot assume that "Linux UnknownLinux" runs on Alpine
-    -- (although it could be static)
-    when (notElem (Linux Alpine) pspecs) $
-      case t of
-        GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
-        Cabal | v > [vver|2.4.1.0|]
-              , arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
-        GHC | Latest `elem` tags || Recommended `elem` tags
-            , arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
-        _ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
+    when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
+      [i|FreeBSD missing for #{t} #{v'} #{arch}|]
 
   checkUniqueTags tool = do
-    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
     let nonUnique =
           fmap fst
             .   filter (\(_, b) -> not b)
@@ -125,7 +93,7 @@ validate dls _ = do
                     (\case
                       [] -> throwM $ InternalError "empty inner list"
                       (t : ts) ->
-                        pure $ (t, ) (not (isUniqueTag t) || null ts)
+                        pure $ (t, ) $ if isUniqueTag t then ts == [] else True
                     )
                 . group
                 . sort
@@ -134,147 +102,80 @@ validate dls _ = do
     case join nonUnique of
       [] -> pure ()
       xs -> do
-        lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
+        lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
         addError
    where
-    isUniqueTag Latest         = True
-    isUniqueTag Recommended    = True
-    isUniqueTag Old            = False
-    isUniqueTag Prerelease     = False
-    isUniqueTag (Base       _) = False
-    isUniqueTag (UnknownTag _) = False
+    isUniqueTag Latest      = True
+    isUniqueTag Recommended = True
 
-  checkGHCVerIsValid = do
+  checkGHCisSemver = do
     let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
-    forM_ ghcVers $ \v ->
-      case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
-        [_] -> pure ()
-        _   -> do
-          lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
-          addError
+    forM_ ghcVers $ \v -> case semver (prettyVer v) of
+      Left _ -> do
+        lift $ $(logError) [i|GHC version #{v} is not valid semver|]
+        addError
+      Right _ -> pure ()
 
   -- a tool must have at least one of each mandatory tags
   checkMandatoryTags tool = do
-    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
     forM_ [Latest, Recommended] $ \t -> case elem t allTags of
       False -> do
-        lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
+        lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
         addError
       True -> pure ()
 
-  -- all GHC versions must have a base tag
-  checkGHCHasBaseVersion = do
-    let allTags = M.toList $ availableToolVersions dls GHC
-    forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
-      False -> do
-        lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
-        addError
-      True -> pure ()
-
-  isBase (Base _) = True
-  isBase _        = False
-
-data TarballFilter = TarballFilter
-  { tfTool    :: Either GlobalTool (Maybe Tool)
-  , tfVersion :: Regex
-  }
 
 validateTarballs :: ( Monad m
-                    , MonadReader env m
-                    , HasLog env
-                    , HasDirs env
-                    , HasSettings env
+                    , MonadLogger m
                     , MonadThrow m
                     , MonadIO m
                     , MonadUnliftIO m
                     , MonadMask m
-                    , Alternative m
-                    , MonadFail m
                     )
-                 => TarballFilter
-                 -> GHCupDownloads
-                 -> M.Map GlobalTool DownloadInfo
+                 => GHCupDownloads
                  -> m ExitCode
-validateTarballs (TarballFilter etool versionRegex) dls gt = do
+validateTarballs dls = do
   ref <- liftIO $ newIORef 0
 
-   -- download/verify all tarballs
-  let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
-  let gdlis = nubOrd $ gt ^.. each
-  let allDls = either (const gdlis) (const dlis) etool
-  when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
-  forM_ allDls (downloadAll ref)
+  flip runReaderT ref $ do
+     -- download/verify all binary tarballs
+    let
+      dlbis = nub $ join $ (M.elems dls) <&> \versions ->
+        join $ (M.elems versions) <&> \vi ->
+          join $ (M.elems $ _viArch vi) <&> \pspecs ->
+            join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
+    forM_ dlbis $ downloadAll
 
-  -- exit
-  e <- liftIO $ readIORef ref
-  if e > 0
-    then pure $ ExitFailure e
-    else do
-      logInfo "All good"
-      pure ExitSuccess
+    let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
+          join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
+    forM_ dlsrc $ downloadAll
+
+    -- exit
+    e <- liftIO $ readIORef ref
+    if e > 0
+      then pure $ ExitFailure e
+      else do
+        lift $ $(logInfo) [i|All good|]
+        pure ExitSuccess
 
  where
-  downloadAll :: ( MonadUnliftIO m
-                 , MonadIO m
-                 , MonadReader env m
-                 , HasLog env
-                 , HasDirs env
-                 , HasSettings env
-                 , MonadCatch m
-                 , MonadMask m
-                 , MonadThrow m
-                 )
-              => IORef Int
-              -> DownloadInfo
-              -> m ()
-  downloadAll ref dli = do
-    r <- runResourceT
-      . runE @'[DigestError
-               , GPGError
-               , DownloadFailed
-               , UnknownArchive
-               , ArchiveResult
-               ]
-      $ do
-        case etool of
-          Right (Just GHCup) -> do
-            tmpUnpack <- lift mkGhcupTmpDir
-            _ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
-            pure Nothing
-          Right _ -> do
-            p <- liftE $ downloadCached dli Nothing
-            fmap (Just . head . splitDirectories . head)
-              . liftE
-              . getArchiveFiles
-              $ p
-          Left ShimGen -> do
-            tmpUnpack <- lift mkGhcupTmpDir
-            _ <- liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmpUnpack Nothing False
-            pure Nothing
+  downloadAll dli = do
+    let settings = Settings True False
+    let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
+                                           , colorOutter  = B.hPut stderr
+                                           , rawOutter    = (\_ -> pure ())
+                                           }
+
+    r <-
+      runLogger
+      . flip runReaderT settings
+      . runResourceT
+      . runE
+      $ downloadCached dli Nothing
     case r of
-      VRight (Just basePath) -> do
-        case _dlSubdir dli of
-          Just (RealDir prel) -> do
-            logInfo
-              $ " verifying subdir: " <> T.pack prel
-            when (basePath /= prel) $ do
-              logError $
-                "Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
-              (flip runReaderT ref addError)
-          Just (RegexDir regexString) -> do
-            logInfo $
-              "verifying subdir (regex): " <> T.pack regexString
-            let regex = makeRegexOpts
-                  compIgnoreCase
-                  execBlank
-                  regexString
-            when (not (match regex basePath)) $ do
-              logError $
-                "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
-              (flip runReaderT ref addError)
-          Nothing -> pure ()
-      VRight Nothing -> pure ()
+      VRight _ -> pure ()
       VLeft  e -> do
-        logError $
-          "Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
-        (flip runReaderT ref addError)
+        lift $ $(logError)
+          [i|Could not download (or verify hash) of #{dli}, Error was: #{e}|]
+        addError

app/ghcup/BrickMain.hs

@@ -1,614 +0,0 @@
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE ViewPatterns      #-}
-{-# LANGUAGE RankNTypes        #-}
-
-module BrickMain where
-
-import           GHCup
-import           GHCup.Download
-import           GHCup.Errors
-import           GHCup.Types         hiding ( LeanAppState(..) )
-import           GHCup.Utils
-import           GHCup.Utils.Logger
-import           GHCup.Utils.Prelude ( decUTF8Safe )
-import           GHCup.Utils.File
-
-import           Brick
-import           Brick.Widgets.Border
-import           Brick.Widgets.Border.Style
-import           Brick.Widgets.Center
-import           Brick.Widgets.List             ( listSelectedFocusedAttr
-                                                , listSelectedAttr
-                                                , listAttr
-                                                )
-import           Codec.Archive
-import           Control.Exception.Safe
-import           Control.Monad.Reader
-import           Control.Monad.Trans.Except
-import           Control.Monad.Trans.Resource
-import           Data.Bool
-import           Data.Functor
-import           Data.List
-import           Data.Maybe
-import           Data.IORef
-import           Data.Vector                    ( Vector
-                                                , (!?)
-                                                )
-import           Data.Versions           hiding ( str )
-import           Haskus.Utils.Variant.Excepts
-import           Prelude                 hiding ( appendFile )
-import           System.Exit
-import           System.IO.Unsafe
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
-import           URI.ByteString
-
-import qualified Data.Text                     as T
-import qualified Graphics.Vty                  as Vty
-import qualified Data.Vector                   as V
-
-
-hiddenTools :: [Tool]
-hiddenTools = []
-
-
-data BrickData = BrickData
-  { lr    :: [ListResult]
-  }
-  deriving Show
-
-data BrickSettings = BrickSettings
-  { showAllVersions :: Bool
-  , showAllTools    :: Bool
-  }
-  deriving Show
-
-data BrickInternalState = BrickInternalState
-  { clr :: Vector ListResult
-  , ix  :: Int
-  }
-  deriving Show
-
-data BrickState = BrickState
-  { appData     :: BrickData
-  , appSettings :: BrickSettings
-  , appState    :: BrickInternalState
-  , appKeys     :: KeyBindings
-  }
-  deriving Show
-
-
-keyHandlers :: KeyBindings
-            -> [ ( Vty.Key
-                 , BrickSettings -> String
-                 , BrickState -> EventM n (Next BrickState)
-                 )
-               ]
-keyHandlers KeyBindings {..} =
-  [ (bQuit, const "Quit"     , halt)
-  , (bInstall, const "Install"  , withIOAction install')
-  , (bUninstall, const "Uninstall", withIOAction del')
-  , (bSet, const "Set"      , withIOAction ((liftIO .) . set'))
-  , (bChangelog, const "ChangeLog", withIOAction changelog')
-  , ( bShowAllVersions
-    , \BrickSettings {..} ->
-       if showAllVersions then "Don't show all versions" else "Show all versions"
-    , hideShowHandler (not . showAllVersions) showAllTools
-    )
-  , ( bShowAllTools
-    , \BrickSettings {..} ->
-       if showAllTools then "Don't show all tools" else "Show all tools"
-    , hideShowHandler showAllVersions (not . showAllTools)
-    )
-  , (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
-  , (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
-  ]
- where
-  hideShowHandler f p BrickState{..} =
-    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
-        newInternalState = constructList appData newAppSettings (Just appState)
-    in  continue (BrickState appData newAppSettings newInternalState appKeys)
-
-
-showKey :: Vty.Key -> String
-showKey (Vty.KChar c) = [c]
-showKey Vty.KUp = "↑"
-showKey Vty.KDown = "↓"
-showKey key = tail (show key)
-
-
-ui :: AttrMap -> BrickState -> Widget String
-ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
-  = padBottom Max
-      ( withBorderStyle unicode
-        $ borderWithLabel (str "GHCup")
-          (center (header <=> hBorder <=> renderList' appState))
-      )
-    <=> footer
-
- where
-  footer =
-    withAttr "help"
-      . txtWrap
-      . T.pack
-      . foldr1 (\x y -> x <> "  " <> y)
-      . fmap (\(key, s, _) -> showKey key <> ":" <> s as)
-      $ keyHandlers appKeys
-  header =
-    minHSize 2 emptyWidget
-      <+> padLeft (Pad 2) (minHSize 6 $ str "Tool")
-      <+> minHSize 15 (str "Version")
-      <+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
-      <+> padLeft (Pad 5) (str "Notes")
-  renderList' = withDefAttr listAttr . drawListElements renderItem True
-  renderItem _ b listResult@ListResult{..} =
-    let marks = if
-          | lSet       -> (withAttr "set" $ str "✔✔")
-          | lInstalled -> (withAttr "installed" $ str "✓ ")
-          | otherwise  -> (withAttr "not-installed" $ str "✗ ")
-        ver = case lCross of
-          Nothing -> T.unpack . prettyVer $ lVer
-          Just c  -> T.unpack (c <> "-" <> prettyVer lVer)
-        dim
-          | lNoBindist && not lInstalled
-            && not b -- TODO: overloading dim and active ignores active
-                       --       so we hack around it here
-          = updateAttrMap (const dimAttrs) . withAttr "no-bindist"
-          | otherwise  = id
-        hooray
-          | elem Latest lTag && not lInstalled =
-              withAttr "hooray"
-          | otherwise = id
-        active = if b then putCursor "GHCup" (Location (0,0)) . forceAttr "active" else id
-    in  hooray $ active $ dim
-          (   marks
-          <+> padLeft (Pad 2)
-               ( minHSize 6
-                 (printTool lTool)
-               )
-          <+> minHSize 15 (str ver)
-          <+> (let l = catMaybes . fmap printTag $ sort lTag
-               in  padLeft (Pad 1) $ minHSize 25 $ if null l
-                     then emptyWidget
-                     else foldr1 (\x y -> x <+> str "," <+> y) l
-              )
-          <+> padLeft (Pad 5)
-              ( let notes = printNotes listResult
-                in  if null notes
-                      then emptyWidget
-                      else foldr1 (\x y -> x <+> str "," <+> y) notes
-              )
-          <+> vLimit 1 (fill ' ')
-          )
-
-  printTag Recommended    = Just $ withAttr "recommended" $ str "recommended"
-  printTag Latest         = Just $ withAttr "latest" $ str "latest"
-  printTag Prerelease     = Just $ withAttr "prerelease" $ str "prerelease"
-  printTag (Base pvp'')   = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
-  printTag Old            = Nothing
-  printTag (UnknownTag t) = Just $ str t
-
-  printTool Cabal = str "cabal"
-  printTool GHC = str "GHC"
-  printTool GHCup = str "GHCup"
-  printTool HLS = str "HLS"
-  printTool Stack = str "Stack"
-
-  printNotes ListResult {..} =
-    (if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
-      )
-      ++ (if fromSrc then [withAttr "compiled" $ str "compiled"] else mempty)
-      ++ (if lStray then [withAttr "stray" $ str "stray"] else mempty)
-
-  -- | Draws the list elements.
-  --
-  -- Evaluates the underlying container up to, and a bit beyond, the
-  -- selected element. The exact amount depends on available height
-  -- for drawing and 'listItemHeight'. At most, it will evaluate up to
-  -- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the
-  -- available height.
-  drawListElements :: (Int -> Bool -> ListResult -> Widget String)
-                   -> Bool
-                   -> BrickInternalState
-                   -> Widget String
-  drawListElements drawElem foc is@(BrickInternalState clr _) =
-    Widget Greedy Greedy $
-      let
-        es = clr
-        listSelected        = fmap fst $ listSelectedElement' is
-
-        drawnElements = flip V.imap es $ \i' e ->
-          let addSeparator w = case es !? (i' - 1) of
-                Just e' | lTool e' /= lTool e ->
-                  hBorder <=> w
-                _                             -> w
-
-              isSelected  = Just i' == listSelected
-              elemWidget  = drawElem i' isSelected e
-              selItemAttr = if foc
-                then withDefAttr listSelectedFocusedAttr
-                else withDefAttr listSelectedAttr
-              makeVisible = if isSelected then visible . selItemAttr else id
-          in  addSeparator $ makeVisible elemWidget
-
-      in render
-        $ viewport "GHCup" Vertical
-        $ vBox
-        $ V.toList drawnElements
-
-
-minHSize :: Int -> Widget n -> Widget n
-minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
-
-
-app :: AttrMap -> AttrMap -> App BrickState e String
-app attrs dimAttrs =
-  App { appDraw         = \st -> [ui dimAttrs st]
-  , appHandleEvent  = eventHandler
-  , appStartEvent   = return
-  , appAttrMap      = const attrs
-  , appChooseCursor = showFirstCursor
-  }
-
-defaultAttributes :: Bool -> AttrMap
-defaultAttributes no_color = attrMap
-  Vty.defAttr
-  [ ("active"       , Vty.defAttr `withBackColor` Vty.blue)
-  , ("not-installed", Vty.defAttr `withForeColor` Vty.red)
-  , ("set"          , Vty.defAttr `withForeColor` Vty.green)
-  , ("installed"    , Vty.defAttr `withForeColor` Vty.green)
-  , ("recommended"  , Vty.defAttr `withForeColor` Vty.green)
-  , ("hls-powered"  , Vty.defAttr `withForeColor` Vty.green)
-  , ("latest"       , Vty.defAttr `withForeColor` Vty.yellow)
-  , ("prerelease"   , Vty.defAttr `withForeColor` Vty.red)
-  , ("compiled"     , Vty.defAttr `withForeColor` Vty.blue)
-  , ("stray"        , Vty.defAttr `withForeColor` Vty.blue)
-  , ("help"         , Vty.defAttr `withStyle`     Vty.italic)
-  , ("hooray"       , Vty.defAttr `withForeColor` Vty.brightWhite)
-  ]
-  where
-    withForeColor | no_color  = const
-                  | otherwise = Vty.withForeColor
-
-    withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
-                  | otherwise = Vty.withBackColor
-
-    withStyle                 = Vty.withStyle
-
-dimAttributes :: Bool -> AttrMap
-dimAttributes no_color = attrMap
-  (Vty.defAttr `Vty.withStyle` Vty.dim)
-  [ ("active"    , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ??
-  , ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
-  ]
-  where
-    withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
-                  | otherwise = Vty.withBackColor
-
-eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState)
-eventHandler st@BrickState{..} ev = do
-  AppState { keyBindings = kb } <- liftIO $ readIORef settings'
-  case ev of
-    (MouseDown _ Vty.BScrollUp _ _) ->
-      continue (BrickState { appState = moveCursor 1 appState Up, .. })
-    (MouseDown _ Vty.BScrollDown _ _) ->
-      continue (BrickState { appState = moveCursor 1 appState Down, .. })
-    (VtyEvent (Vty.EvResize _ _)) -> continue st
-    (VtyEvent (Vty.EvKey Vty.KUp _)) ->
-      continue BrickState{ appState = moveCursor 1 appState Up, .. }
-    (VtyEvent (Vty.EvKey Vty.KDown _)) ->
-      continue BrickState{ appState = moveCursor 1 appState Down, .. }
-    (VtyEvent (Vty.EvKey key _)) ->
-      case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
-        Nothing -> continue st
-        Just (_, _, handler) -> handler st
-    _ -> continue st
-
-
-moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
-moveCursor steps ais@BrickInternalState{..} direction =
-  let newIx = if direction == Down then ix + steps else ix - steps
-  in  case clr !? newIx of
-        Just _  -> BrickInternalState { ix = newIx, .. }
-        Nothing -> ais
-
-
--- | Suspend the current UI and run an IO action in terminal. If the
--- IO action returns a Left value, then it's thrown as userError.
-withIOAction :: (BrickState
-                 -> (Int, ListResult)
-                 -> ReaderT AppState IO (Either String a))
-             -> BrickState
-             -> EventM n (Next BrickState)
-withIOAction action as = case listSelectedElement' (appState as) of
-  Nothing      -> continue as
-  Just (ix, e) -> do
-    suspendAndResume $ do
-      settings <- readIORef settings'
-      flip runReaderT settings $ action as (ix, e) >>= \case
-        Left  err -> liftIO $ putStrLn ("Error: " <> err)
-        Right _   -> liftIO $ putStrLn "Success"
-      getAppData Nothing >>= \case
-        Right data' -> do
-          putStrLn "Press enter to continue"
-          _ <- getLine
-          pure (updateList data' as)
-        Left err -> throwIO $ userError err
-
-
--- | Update app data and list internal state based on new evidence.
--- This synchronises @BrickInternalState@ with @BrickData@
--- and @BrickSettings@.
-updateList :: BrickData -> BrickState -> BrickState
-updateList appD BrickState{..} =
-  let newInternalState = constructList appD appSettings (Just appState)
-  in  BrickState { appState    = newInternalState
-                 , appData     = appD
-                 , appSettings = appSettings
-                 , appKeys     = appKeys
-                 }
-
-
-constructList :: BrickData
-              -> BrickSettings
-              -> Maybe BrickInternalState
-              -> BrickInternalState
-constructList appD appSettings =
-  replaceLR (filterVisible (showAllVersions appSettings)
-                           (showAllTools appSettings))
-            (lr appD)
-
-listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
-listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
-
-
-selectLatest :: Vector ListResult -> Int
-selectLatest v =
-  case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
-    Just ix -> ix
-    Nothing -> 0
-
-
--- | Replace the @appState@ or construct it based on a filter function
--- and a new @[ListResult]@ evidence.
--- When passed an existing @appState@, tries to keep the selected element.
-replaceLR :: (ListResult -> Bool)
-          -> [ListResult]
-          -> Maybe BrickInternalState
-          -> BrickInternalState
-replaceLR filterF lr s =
-  let oldElem = s >>= listSelectedElement'
-      newVec  = V.fromList . filter filterF $ lr
-      newSelected =
-        case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
-          Just ix -> ix
-          Nothing -> selectLatest newVec
-  in  BrickInternalState newVec newSelected
- where
-  toolEqual e1 e2 =
-    lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
-
-
-filterVisible :: Bool -> Bool -> ListResult -> Bool
-filterVisible v t e | lInstalled e = True
-                    | v
-                    , not t
-                    , not (elem (lTool e) hiddenTools) = True
-                    | not v
-                    , t
-                    , not (elem Old (lTag e)) = True
-                    | v
-                    , t = True
-                    | otherwise = not (elem Old (lTag e)) &&
-                                  not (elem (lTool e) hiddenTools)
-
-
-install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
-         => BrickState
-         -> (Int, ListResult)
-         -> m (Either String ())
-install' _ (_, ListResult {..}) = do
-  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-
-  let run =
-        runResourceT
-          . runE
-            @'[ AlreadyInstalled
-              , ArchiveResult
-              , UnknownArchive
-              , FileDoesNotExistError
-              , CopyError
-              , NoDownload
-              , NotInstalled
-              , BuildFailed
-              , TagNotFound
-              , DigestError
-              , GPGError
-              , DownloadFailed
-              , DirNotEmpty
-              , NoUpdate
-              , TarDirDoesNotExist
-              , FileAlreadyExistsError
-              ]
-
-  run (do
-      case lTool of
-        GHC   -> do
-          let vi = getVersionInfo lVer GHC dls
-          liftE $ installGHCBin lVer Nothing False $> vi
-        Cabal -> do
-          let vi = getVersionInfo lVer Cabal dls
-          liftE $ installCabalBin lVer Nothing False $> vi
-        GHCup -> do
-          let vi = snd <$> getLatest dls GHCup
-          liftE $ upgradeGHCup Nothing False $> vi
-        HLS   -> do
-          let vi = getVersionInfo lVer HLS dls
-          liftE $ installHLSBin lVer Nothing False $> vi
-        Stack -> do
-          let vi = getVersionInfo lVer Stack dls
-          liftE $ installStackBin lVer Nothing False $> vi
-    )
-    >>= \case
-          VRight vi                         -> do
-            forM_ (_viPostInstall =<< vi) $ \msg ->
-              logInfo msg
-            pure $ Right ()
-          VLeft  (V (AlreadyInstalled _ _)) -> pure $ Right ()
-          VLeft (V NoUpdate) -> pure $ Right ()
-          VLeft e -> pure $ Left $ prettyShow e <> "\n"
-            <> "Also check the logs in ~/.ghcup/logs"
-
-
-set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
-set' _ (_, ListResult {..}) = do
-  settings <- readIORef settings'
-
-  let run =
-        flip runReaderT settings
-          . runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
-
-  run (do
-      case lTool of
-        GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
-        Cabal -> liftE $ setCabal lVer $> ()
-        HLS   -> liftE $ setHLS lVer $> ()
-        Stack -> liftE $ setStack lVer $> ()
-        GHCup -> pure ()
-    )
-    >>= \case
-          VRight _ -> pure $ Right ()
-          VLeft  e -> pure $ Left (prettyShow e)
-
-
-del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
-     => BrickState
-     -> (Int, ListResult)
-     -> m (Either String ())
-del' _ (_, ListResult {..}) = do
-  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-
-  let run = runE @'[NotInstalled]
-
-  run (do
-      let vi = getVersionInfo lVer lTool dls
-      case lTool of
-        GHC   -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
-        Cabal -> liftE $ rmCabalVer lVer $> vi
-        HLS   -> liftE $ rmHLSVer lVer $> vi
-        Stack -> liftE $ rmStackVer lVer $> vi
-        GHCup -> pure Nothing
-    )
-    >>= \case
-          VRight vi -> do
-            forM_ (join $ fmap _viPostRemove vi) $ \msg ->
-              logInfo msg
-            pure $ Right ()
-          VLeft  e -> pure $ Left (prettyShow e)
-
-
-changelog' :: (MonadReader AppState m, MonadIO m)
-           => BrickState
-           -> (Int, ListResult)
-           -> m (Either String ())
-changelog' _ (_, ListResult {..}) = do
-  AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
-  case getChangeLog dls lTool (Left lVer) of
-    Nothing -> pure $ Left $
-      "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
-    Just uri -> do
-      let cmd = case _rPlatform pfreq of
-            Darwin  -> "open"
-            Linux _ -> "xdg-open"
-            FreeBSD -> "xdg-open"
-            Windows -> "start"
-      exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
-        Right _ -> pure $ Right ()
-        Left  e -> pure $ Left $ prettyShow e
-
-
-settings' :: IORef AppState
-{-# NOINLINE settings' #-}
-settings' = unsafePerformIO $ do
-  dirs <- getAllDirs
-  let loggerConfig = LoggerConfig { lcPrintDebug  = False
-                                  , consoleOutter = \_ -> pure ()
-                                  , fileOutter    = \_ -> pure ()
-                                  , fancyColors   = True
-                                  }
-  newIORef $ AppState (Settings { cache      = True
-                                , noVerify   = False
-                                , keepDirs   = Never
-                                , downloader = Curl
-                                , verbose    = False
-                                , urlSource  = GHCupURL
-                                , noNetwork  = False
-                                , gpgSetting = GPGNone
-                                , noColor    = False
-                                , ..
-                                })
-                      dirs
-                      defaultKeyBindings
-                      (GHCupInfo mempty mempty mempty)
-                      (PlatformRequest A_64 Darwin Nothing)
-                      loggerConfig
-
-
-
-brickMain :: AppState
-          -> IO ()
-brickMain s = do
-  writeIORef settings' s
-
-  eAppData <- getAppData (Just $ ghcupInfo s)
-  case eAppData of
-    Right ad ->
-      defaultMain
-          (app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s)))
-          (BrickState ad
-                    defaultAppSettings
-                    (constructList ad defaultAppSettings Nothing)
-                    (keyBindings (s :: AppState))
-
-          )
-        $> ()
-    Left e -> do
-      flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e)
-      exitWith $ ExitFailure 2
-
-
-defaultAppSettings :: BrickSettings
-defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
-
-
-getGHCupInfo :: IO (Either String GHCupInfo)
-getGHCupInfo = do
-  settings <- readIORef settings'
-
-  r <-
-    flip runReaderT settings
-    . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
-    $ liftE
-    $ getDownloadsF
-
-  case r of
-    VRight a -> pure $ Right a
-    VLeft  e -> pure $ Left (prettyShow e)
-
-
-getAppData :: Maybe GHCupInfo
-           -> IO (Either String BrickData)
-getAppData mgi = runExceptT $ do
-  r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
-  liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
-  settings <- liftIO $ readIORef settings'
-
-  flip runReaderT settings $ do
-    lV <- listVersions Nothing Nothing
-    pure $ BrickData (reverse lV)
-

bootstrap-haskell

@@ -0,0 +1,202 @@
+#!/bin/sh
+
+# safety subshell to avoid executing anything in case this script is not downloaded properly
+(
+
+: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
+
+die() {
+    (>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
+    exit 2
+}
+
+edo()
+{
+    "$@" || die "\"$*\" failed!"
+}
+
+eghcup() {
+    if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
+        edo ghcup "$@"
+    else
+        edo ghcup --verbose "$@"
+    fi
+}
+
+download_ghcup() {
+	_plat="$(uname -s)"
+	_arch=$(uname -m)
+
+    case "${_plat}" in
+        "linux"|"Linux")
+			case "${_arch}" in
+				x86_64|amd64)
+					_url=https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4
+					;;
+				i*86)
+					_url=https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4
+					;;
+				*) die "Unknown architecture: ${_arch}"
+					;;
+			esac
+			;;
+        "FreeBSD"|"freebsd")
+			case "${_arch}" in
+				x86_64|amd64)
+					;;
+				i*86)
+					die "i386 currently not supported!"
+					;;
+				*) die "Unknown architecture: ${_arch}"
+					;;
+			esac
+			_url=https://downloads.haskell.org/~ghcup/0.1.4/x86_64-portbld-freebsd-ghcup-0.1.4
+            ;;
+        "Darwin"|"darwin")
+			case "${_arch}" in
+				x86_64|amd64)
+					;;
+				i*86)
+					die "i386 currently not supported!"
+					;;
+				*) die "Unknown architecture: ${_arch}"
+					;;
+			esac
+			_url=https://downloads.haskell.org/~ghcup/0.1.4/x86_64-apple-darwin-ghcup-0.1.4 ;;
+        *) die "Unknown platform: ${_plat}"
+			;;
+    esac
+
+	edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
+
+	unset _plat _arch _url
+}
+
+
+echo
+echo "Welcome to Haskell!"
+echo
+echo "This will download and install the Glasgow Haskell Compiler (GHC)"
+echo "and the Cabal build tool."
+echo
+echo "ghcup installs only into the following directory, which can be removed anytime:"
+echo "  $GHCUP_INSTALL_BASE_PREFIX/.ghcup"
+echo
+
+if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
+    printf "\\033[0;35m%s\\033[0m\\n" "Press ENTER to proceed"
+    printf "\\033[0;35m%s\\033[0m\\n" "or ctrl-c to abort."
+    printf "\\033[0;35m%s\\033[0m\\n" "Note that this script can be re-run at any given time."
+    echo
+    # Wait for user input to continue.
+    # shellcheck disable=SC2034
+    read -r answer </dev/tty
+fi
+
+edo mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
+
+if command -V "ghcup" >/dev/null 2>&1 ; then
+    if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
+        eghcup upgrade
+    fi
+else
+	download_ghcup
+    edo chmod +x "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
+
+	cat <<-EOF > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env || die "Failed to create env file"
+		export PATH="\$HOME/.cabal/bin:\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/bin:\$PATH"
+		EOF
+	# shellcheck disable=SC1090
+    edo . "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/env
+    eghcup upgrade
+fi
+
+echo
+echo "$(ghcup tool-requirements)"
+echo
+
+if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
+    printf "\\033[0;35m%s\\033[0m\\n" "Press ENTER to proceed"
+    printf "\\033[0;35m%s\\033[0m\\n" "or ctrl-c to abort."
+    printf "\\033[0;35m%s\\033[0m\\n" "Installation may take a while."
+    echo
+
+    # Wait for user input to continue.
+    # shellcheck disable=SC2034
+    read -r answer </dev/tty
+fi
+
+eghcup --cache install
+
+eghcup set
+eghcup --cache install-cabal
+
+edo cabal new-update
+
+printf "\\033[0;35m%s\\033[0m\\n" ""
+printf "\\033[0;35m%s\\033[0m\\n" "Installation done!"
+printf "\\033[0;35m%s\\033[0m\\n" ""
+
+if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
+    echo "In order to run ghc and cabal, you need to adjust your PATH variable."
+    echo "You may want to source '$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env' in your shell"
+    echo "configuration to do so (e.g. ~/.bashrc)."
+
+	case $SHELL in
+		*/zsh) # login shell is zsh
+			GHCUP_PROFILE_FILE="$HOME/.zshrc"
+			MY_SHELL="zsh" ;;
+		*/bash) # login shell is bash
+			if [ -f "$HOME/.bashrc" ] ; then # bashrc is not sourced by default, so assume it isn't if file does not exist
+				GHCUP_PROFILE_FILE="$HOME/.bashrc"
+			else
+				GHCUP_PROFILE_FILE="$HOME/.bash_profile"
+			fi
+
+			MY_SHELL="bash" ;;
+		*/sh) # login shell is sh, but might be a symlink to bash or zsh
+			if [ -n "${BASH}" ] ; then
+				if [ -f "$HOME/.bashrc" ] ; then # bashrc is not sourced by default, so assume it isn't if file does not exist
+					GHCUP_PROFILE_FILE="$HOME/.bashrc"
+				else
+					GHCUP_PROFILE_FILE="$HOME/.bash_profile"
+				fi
+
+				MY_SHELL="bash"
+			elif [ -n "${ZSH_VERSION}" ] ; then
+				GHCUP_PROFILE_FILE="$HOME/.zshrc"
+				MY_SHELL="zsh"
+			else
+				exit 0
+			fi
+			;;
+		*) exit 0 ;;
+	esac
+
+
+	printf "\\033[0;35m%s\\033[0m\\n" ""
+	printf "\\033[0;35m%s\\033[0m\\n" "Detected ${MY_SHELL} shell on your system..."
+	printf "\\033[0;35m%s\\033[0m\\n" "If you want ghcup to automatically add the required PATH variable to \"${GHCUP_PROFILE_FILE}\""
+	printf "\\033[0;35m%s\\033[0m\\n" "answer with YES, otherwise with NO and press ENTER."
+	printf "\\033[0;35m%s\\033[0m\\n" ""
+
+    while true; do
+        read -r next_answer </dev/tty
+
+        case $next_answer in
+            [Yy]*)
+                echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
+                printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
+                printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
+                exit 0;;
+            [Nn]*)
+                exit 0;;
+            *)
+                echo "Please type YES or NO and press enter.";;
+        esac
+    done
+fi
+)
+
+# vim: tabstop=4 shiftwidth=4 expandtab
+

cabal.ghc8107.project

@@ -1,34 +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
-    tag: 34ea816bd63f75f800eedac12c6908c6f3736036
-
-source-repository-package
-    type: git
-    location: https://github.com/hasufell/libarchive
-    tag: 8587aab78dd515928024ecd82c8f215e06db85cd
-
-constraints: http-io-streams -brotli
-
-package libarchive
-  flags: -system-libarchive
-
-package aeson-pretty
-  flags: +lib-only
-
-package cabal-plan
-  flags: -exe
-
-allow-newer: base, ghc-prim, template-haskell, language-c
-
-with-compiler: ghc-8.10.7

cabal.ghc8107.project.freeze

@@ -1,213 +0,0 @@
-active-repositories: hackage.haskell.org:merge
-constraints: any.Cabal ==3.2.1.0,
-             any.HUnit ==1.6.2.0,
-             any.HsOpenSSL ==0.11.7.1,
-             HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
-             any.HsYAML ==0.2.1.0,
-             HsYAML -exe,
-             any.HsYAML-aeson ==0.2.0.0,
-             any.QuickCheck ==2.14.2,
-             QuickCheck -old-random +templatehaskell,
-             any.StateVar ==1.2.2,
-             any.aeson ==1.5.6.0,
-             aeson -bytestring-builder -cffi -developer -fast,
-             any.aeson-pretty ==0.8.8,
-             aeson-pretty +lib-only,
-             any.alex ==3.2.6,
-             alex +small_base,
-             any.ansi-terminal ==0.11,
-             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.3,
-             async -bench,
-             any.attoparsec ==0.13.2.5,
-             attoparsec -developer,
-             any.base ==4.14.3.0,
-             any.base-compat ==0.11.2,
-             any.base-compat-batteries ==0.11.2,
-             any.base-orphans ==0.8.4,
-             any.base16-bytestring ==1.0.1.0,
-             any.base64-bytestring ==1.1.0.0,
-             any.bifunctors ==5.5.11,
-             bifunctors +semigroups +tagged,
-             any.binary ==0.8.8.0,
-             any.blaze-builder ==0.4.2.1,
-             any.brick ==0.64,
-             brick -demos,
-             any.bytestring ==0.10.12.0,
-             any.bz2 ==1.0.1.0,
-             bz2 -cross +with-bzlib,
-             any.c2hs ==0.28.8,
-             c2hs +base3 -regression,
-             any.cabal-plan ==0.7.2.0,
-             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.0,
-             any.chs-deps ==0.1.0.0,
-             chs-deps -cross,
-             any.clock ==0.8.2,
-             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.concurrent-output ==1.10.12,
-             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.100.1,
-             any.cryptohash-sha256 ==0.11.102.0,
-             cryptohash-sha256 -exe +use-cbits,
-             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,
-             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.1,
-             any.free ==5.1.7,
-             any.generic-arbitrary ==0.1.0,
-             any.ghc-boot-th ==8.10.7,
-             any.ghc-byteorder ==4.11.0.0.10,
-             any.ghc-prim ==0.6.1,
-             any.happy ==1.20.0,
-             any.hashable ==1.3.3.0,
-             hashable +integer-gmp -random-initial-seed,
-             any.haskus-utils-data ==1.4,
-             any.haskus-utils-types ==1.5.1,
-             any.haskus-utils-variant ==3.1,
-             any.hsc2hs ==0.68.7,
-             hsc2hs -in-ghc-tree,
-             any.hspec ==2.7.10,
-             any.hspec-core ==2.7.10,
-             any.hspec-discover ==2.7.10 || ==2.8.3,
-             any.hspec-expectations ==0.8.2,
-             any.hspec-golden-aeson ==0.9.0.0,
-             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.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.0.1,
-             language-c -allwarnings +iecfpextension +usebytestrings,
-             any.libarchive ==3.0.2.2,
-             libarchive -cross -low-memory -system-libarchive,
-             any.lzma-static ==5.2.5.4,
-             any.megaparsec ==9.0.1,
-             megaparsec -dev,
-             any.microlens ==0.4.12.0,
-             any.microlens-mtl ==0.2.0.1,
-             any.microlens-th ==0.4.3.10,
-             any.mtl ==2.2.2,
-             any.network ==3.1.2.2,
-             network -devel,
-             any.network-uri ==2.6.4.1,
-             any.openssl-streams ==1.2.3.0,
-             any.optics ==0.4,
-             any.optics-core ==0.4,
-             optics-core -explicit-generic-labels,
-             any.optics-extra ==0.4,
-             any.optics-th ==0.4,
-             any.optparse-applicative ==0.16.1.0,
-             optparse-applicative +process,
-             any.os-release ==1.0.2,
-             os-release -devel,
-             any.parallel ==3.2.2.0,
-             any.parsec ==3.1.14.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.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.0,
-             any.recursion-schemes ==5.2.2.1,
-             recursion-schemes +template-haskell,
-             any.regex-base ==0.94.0.1,
-             any.regex-posix ==0.96.0.1,
-             regex-posix -_regex-posix-clib,
-             any.resourcet ==1.2.4.3,
-             any.rts ==1.0.1,
-             any.safe ==0.3.19,
-             any.safe-exceptions ==0.1.7.2,
-             any.scientific ==0.3.7.0,
-             scientific -bytestring-builder -integer-simple,
-             any.semigroupoids ==5.3.5,
-             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.3,
-             splitmix -optimised-mixer,
-             any.stm ==2.5.0.1,
-             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.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-zipper ==0.11,
-             any.tf-random ==0.5,
-             any.th-abstraction ==0.4.2.0,
-             any.th-compat ==0.1.2,
-             any.th-lift ==0.8.2,
-             any.th-lift-instances ==0.1.18,
-             any.these ==1.1.1.1,
-             these +assoc,
-             any.time ==1.9.3,
-             any.time-compat ==1.9.6,
-             time-compat -old-locale,
-             any.transformers ==0.5.6.2,
-             any.transformers-base ==0.4.6,
-             transformers-base +orphaninstances,
-             any.transformers-compat ==0.7,
-             transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
-             any.unix ==2.7.2.2,
-             any.unix-bytestring ==0.3.7.3,
-             any.unix-compat ==0.5.3,
-             unix-compat -old-time,
-             any.unliftio-core ==0.2.0.1,
-             any.unordered-containers ==0.2.14.0,
-             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.0,
-             vector +boundschecks -internalchecks -unsafechecks -wall,
-             any.versions ==5.0.0,
-             any.vty ==5.33,
-             any.word-wrap ==0.4.1,
-             any.word8 ==0.1.3,
-             any.xor ==0.0.1.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 2021-08-29T16:24:29Z

cabal.ghc901.project

@@ -1,34 +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
-    tag: 34ea816bd63f75f800eedac12c6908c6f3736036
-
-source-repository-package
-    type: git
-    location: https://github.com/hasufell/libarchive
-    tag: 8587aab78dd515928024ecd82c8f215e06db85cd
-
-constraints: http-io-streams -brotli
-
-package libarchive
-  flags: -system-libarchive
-
-package aeson-pretty
-  flags: +lib-only
-
-package cabal-plan
-  flags: -exe
-
-allow-newer: base, ghc-prim, template-haskell, language-c
-
-with-compiler: ghc-9.0.1

cabal.ghc901.project.freeze

@@ -1,213 +0,0 @@
-active-repositories: hackage.haskell.org:merge
-constraints: any.Cabal ==3.4.0.0,
-             any.HUnit ==1.6.2.0,
-             any.HsOpenSSL ==0.11.7.1,
-             HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -use-pkg-config,
-             any.HsYAML ==0.2.1.0,
-             HsYAML -exe,
-             any.HsYAML-aeson ==0.2.0.0,
-             any.QuickCheck ==2.14.2,
-             QuickCheck -old-random +templatehaskell,
-             any.StateVar ==1.2.2,
-             any.aeson ==1.5.6.0,
-             aeson -bytestring-builder -cffi -developer -fast,
-             any.aeson-pretty ==0.8.8,
-             aeson-pretty +lib-only,
-             any.alex ==3.2.6,
-             alex +small_base,
-             any.ansi-terminal ==0.11,
-             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.3,
-             async -bench,
-             any.attoparsec ==0.13.2.5,
-             attoparsec -developer,
-             any.base ==4.15.0.0,
-             any.base-compat ==0.11.2,
-             any.base-compat-batteries ==0.11.2,
-             any.base-orphans ==0.8.4,
-             any.base16-bytestring ==1.0.1.0,
-             any.base64-bytestring ==1.1.0.0,
-             any.bifunctors ==5.5.11,
-             bifunctors +semigroups +tagged,
-             any.binary ==0.8.8.0,
-             any.blaze-builder ==0.4.2.1,
-             any.brick ==0.64,
-             brick -demos,
-             any.bytestring ==0.10.12.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.0,
-             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.0,
-             any.chs-deps ==0.1.0.0,
-             chs-deps -cross,
-             any.clock ==0.8.2,
-             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.concurrent-output ==1.10.12,
-             any.config-ini ==0.2.4.0,
-             config-ini -enable-doctests,
-             any.containers ==0.6.4.1,
-             any.contravariant ==1.5.5,
-             contravariant +semigroups +statevar +tagged,
-             any.cpphs ==1.20.9.1,
-             cpphs -old-locale,
-             any.cryptohash-sha1 ==0.11.100.1,
-             any.cryptohash-sha256 ==0.11.102.0,
-             cryptohash-sha256 -exe +use-cbits,
-             any.data-clist ==0.1.2.3,
-             any.data-fix ==0.3.2,
-             any.deepseq ==1.4.5.0,
-             any.directory ==1.3.6.1,
-             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.1,
-             any.free ==5.1.7,
-             any.generic-arbitrary ==0.1.0,
-             any.ghc-bignum ==1.0,
-             any.ghc-boot-th ==9.0.1,
-             any.ghc-byteorder ==4.11.0.0.10,
-             any.ghc-prim ==0.7.0,
-             any.happy ==1.20.0,
-             any.hashable ==1.3.3.0,
-             hashable +integer-gmp -random-initial-seed,
-             any.haskus-utils-data ==1.4,
-             any.haskus-utils-types ==1.5.1,
-             any.haskus-utils-variant ==3.1,
-             any.hsc2hs ==0.68.7,
-             hsc2hs -in-ghc-tree,
-             any.hspec ==2.7.10,
-             any.hspec-core ==2.7.10,
-             any.hspec-discover ==2.7.10 || ==2.8.3,
-             any.hspec-expectations ==0.8.2,
-             any.hspec-golden-aeson ==0.9.0.0,
-             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.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.0.1,
-             language-c -allwarnings +iecfpextension +usebytestrings,
-             any.libarchive ==3.0.2.2,
-             libarchive -cross -low-memory -system-libarchive,
-             any.lzma-static ==5.2.5.4,
-             any.megaparsec ==9.0.1,
-             megaparsec -dev,
-             any.microlens ==0.4.12.0,
-             any.microlens-mtl ==0.2.0.1,
-             any.microlens-th ==0.4.3.10,
-             any.mtl ==2.2.2,
-             any.network ==3.1.2.2,
-             network -devel,
-             any.network-uri ==2.6.4.1,
-             any.openssl-streams ==1.2.3.0,
-             any.optics ==0.4,
-             any.optics-core ==0.4,
-             optics-core -explicit-generic-labels,
-             any.optics-extra ==0.4,
-             any.optics-th ==0.4,
-             any.optparse-applicative ==0.16.1.0,
-             optparse-applicative +process,
-             any.os-release ==1.0.2,
-             os-release -devel,
-             any.parallel ==3.2.2.0,
-             any.parsec ==3.1.14.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.2.0,
-             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.0,
-             any.recursion-schemes ==5.2.2.1,
-             recursion-schemes +template-haskell,
-             any.regex-base ==0.94.0.1,
-             any.regex-posix ==0.96.0.1,
-             regex-posix -_regex-posix-clib,
-             any.resourcet ==1.2.4.3,
-             any.rts ==1.0,
-             any.safe ==0.3.19,
-             any.safe-exceptions ==0.1.7.2,
-             any.scientific ==0.3.7.0,
-             scientific -bytestring-builder -integer-simple,
-             any.semigroupoids ==5.3.5,
-             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.3,
-             splitmix -optimised-mixer,
-             any.stm ==2.5.0.0,
-             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.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.4,
-             any.text ==1.2.4.1,
-             any.text-zipper ==0.11,
-             any.tf-random ==0.5,
-             any.th-abstraction ==0.4.2.0,
-             any.th-compat ==0.1.2,
-             any.th-lift ==0.8.2,
-             any.th-lift-instances ==0.1.18,
-             any.these ==1.1.1.1,
-             these +assoc,
-             any.time ==1.9.3,
-             any.time-compat ==1.9.6,
-             time-compat -old-locale,
-             any.transformers ==0.5.6.2,
-             any.transformers-base ==0.4.6,
-             transformers-base +orphaninstances,
-             any.transformers-compat ==0.7,
-             transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
-             any.unix ==2.7.2.2,
-             any.unix-bytestring ==0.3.7.3,
-             any.unix-compat ==0.5.3,
-             unix-compat -old-time,
-             any.unliftio-core ==0.2.0.1,
-             any.unordered-containers ==0.2.14.0,
-             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.0,
-             vector +boundschecks -internalchecks -unsafechecks -wall,
-             any.versions ==5.0.0,
-             any.vty ==5.33,
-             any.word-wrap ==0.4.1,
-             any.word8 ==0.1.3,
-             any.xor ==0.0.1.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 2021-08-29T16:24:29Z

cabal.project

@@ -1,27 +1,16 @@
 packages: ./ghcup.cabal
 
-optional-packages: ./vendored/*/*.cabal
-
 optimization: 2
 
-package ghcup
-    tests: True
-    flags: +tui
+package streamly
+    ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
 
-source-repository-package
-    type: git
-    location: https://github.com/hasufell/libarchive
-    tag: 8587aab78dd515928024ecd82c8f215e06db85cd
+package ghcup
+    ghc-options: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
+
+package tar-bytestring
+    ghc-options: -O2
 
 constraints: http-io-streams -brotli
 
-package libarchive
-  flags: -system-libarchive
-
-package aeson-pretty
-  flags: +lib-only
-
-package cabal-plan
-  flags: -exe
-
-allow-newer: base, ghc-prim, template-haskell, language-c
+allow-newer: base

cabal.project.freeze

@@ -1,2 +0,0 @@
--- windows picks weird version
-constraints: any.hsc2hs ==0.68.7

data/build_mk/cross

@@ -1,9 +0,0 @@
-V=0
-BUILD_MAN = NO
-BUILD_SPHINX_HTML = NO
-BUILD_SPHINX_PDF = NO
-HADDOCK_DOCS = NO
-ifneq "$(BuildFlavour)" ""
-include mk/flavours/$(BuildFlavour).mk
-endif
-Stage1Only = YES

data/build_mk/default

@@ -1,8 +0,0 @@
-V=0
-BUILD_MAN = NO
-BUILD_SPHINX_HTML = NO
-BUILD_SPHINX_PDF = NO
-HADDOCK_DOCS = YES
-ifneq "$(BuildFlavour)" ""
-include mk/flavours/$(BuildFlavour).mk
-endif

data/config.yaml

@@ -1,67 +0,0 @@
-# Cache downloads in ~/.ghcup/cache
-cache: False
-# Skip tarball checksum verification
-no-verify: False
-# enable verbosity
-verbose: False
-# When to keep build directories
-keep-dirs: Errors  # Always | Never | Errors
-# Which downloader to use
-downloader: Curl   # Curl | Wget | Internal
-# whether to run in offline mode
-no-network: False
-# whether/how to do gpg verification
-gpg-setting: GPGNone # GPGStrict | GPGLax | GPGNone
-
-# TUI key bindings,
-# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key
-# for possible values.
-key-bindings:
-  up:
-    KUp: []
-  down:
-    KDown: []
-  quit:
-    KChar: 'q'
-  install:
-    KChar: 'i'
-  uninstall:
-    KChar: 'u'
-  set:
-    KChar: 's'
-  changelog:
-    KChar: 'c'
-  show-all:
-    KChar: 'a'
-  show-all-tools:
-    KChar: 't'
-
-# Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
-# check the 'URLSource' type in the code.
-url-source:
-  ## Use the internal download uri, this is the default
-  GHCupURL: []
-
-  ## Example 1: Read download info from this location instead
-  ## Accepts file/http/https scheme
-  # OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
-
-  ## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions
-  # AddSource:
-    # Left:
-      # toolRequirements: {} # this is ignored
-      # ghcupDownloads:
-        # GHC:
-          # 9.10.2:
-            # viTags: []
-            # viArch:
-              # A_64:
-                # Linux_UnknownLinux:
-                  # unknown_versioning:
-                    # dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-deb8-linux.tar.bz2
-                    # dlSubdir: ghc-7.10.3
-                    # dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
-
-  ## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions
-  # AddSource:
-    # Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"

docker/build.sh

@@ -0,0 +1,14 @@
+#!/bin/sh
+
+set -ex
+
+cd /app
+
+cabal v2-update
+
+cabal v2-install \
+	--install-method=copy \
+	--overwrite-policy=always \
+	--installdir="/bin" \
+	--ghc-options='-optl-static'
+

docs/CHANGELOG.md

@@ -1,203 +0,0 @@
-# Revision history for ghcup
-
-## 0.1.17.1 -- 2021-09-26
-
-* Fix `NO_COLOR`
-* Fix `ghcup list -t` for hls/stack, wrt [#244](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/244)
-* Get rid of concurrent-output
-* Improve cli interface with partial versions (e.g. `ghcup install ghc 8`)
-* Fix HLS compilation builds
-* Implement `ghcup gc` (garbage collection) command
-
-## 0.1.17 -- 2021-09-20
-
-* Add `--force` option to install/compile wrt [#210](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/210) by Arjun Kathuria
-* Implement compiling HLS from source wrt [#201](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/201)
-* Implement experimental GPG verification of the metadata file (see README) wrt [#263](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/236)
-* Add `ghcup unset` command wrt [#145](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/145)
-* Add `ghcup whereis bindir` etc wrt [#221](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/221)
-* Greatly reduce dependency footprint wrt [#212](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/212)
-* Add `ghcup --plan-json`
-* Improve `--patchdir` option for GHC compilation wrt [#226](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/226)
-* Try to improve logging and failure modes, especially during downloads
-* Add descriptive warnings when HLS and GHC versions are incompatible
-* Improve curl header parsing wrt [#213](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/213)
-
-## 0.1.16.2 -- 2021-08-12
-
-* Add isolated installations wrt [#141](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/141) by Arjun Kathuria
-* Implement config cli MVP wrt [#134](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/134) by Oleksii Dorozhkin
-* Fix `ghcup compile ghc --flavor`
-* Fix minor installation bug causing increased disk space wrt [#139](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/139)
-* Improved error handling wrt [#136](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/136)
-* Various improvements to metadata download when using `file://` and `--offline` wrt [#137](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/137)
-
-## 0.1.16.1 -- 2021-07-29
-
-* Add 'nuke' subcommand wrt [#135](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/135), implemented by Arjun Kathuria
-* Add uninstallation powershell script on windows wrt [#150](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/150)
-* Improve logging
-* Fix building GHC cross compiler wrt [#180](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/180)
-* Allow to use hadrian as build system (for git based versions only) wrt [#35](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/35)
-* Allow passing `--flavor` to `ghcup compile ghc`
-* Support new GHC `bin/` directory format wrt [ghc/ghc#20074](https://gitlab.haskell.org/ghc/ghc/-/issues/20074#note_363720)
-* Implement `whereis` subcommand wrt [#173](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/173)
-* Add `--offline` switch and `prefetch` subcommand wrt [#186](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/186)
-* Implement ETAGs hashing for metadata downloads to speed up `ghcup list` wrt [#193](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/193)
-* Avoid unnecessary fetching of ghcup metadata in some commands
-* Avoid unnecessary update checks for some commands
-* Preserve mtimes on unpacked GHC tarballs on windows wrt [#187](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/187), fixing issues with `ghc-pkg`
-* Fix lesser bug in `ghcup list` for stray stack versions wrt [#183](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/183)
-* Major redo on how file removal on windows works, avoiding partial removals etc, wrt [#165](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/165)
-* Improve ghcup tui for screen readers wrt [github/#4](https://github.com/haskell/ghcup-hs/pull/4), thanks to Mario Lang
-
-## 0.1.15.2 -- 2021-06-13
-
-* Remove legacy handling of cabal binary and be more graceful about binaries not installed by ghcup (e.g. stack)
-* Fix GHC compilation from git
-* Fix 'ghcup upgrade' on windows
-* Allow to skip update checks via `GHCUP_SKIP_UPDATE_CHECK`
-* Use libarchive on windows as well, fixing unpack errors wrt [#147](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/147)
-
-## 0.1.15.1 -- 2021-06-11
-
-* Add Apple Silicon support
-* Add windows support wrt [#130](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/130)
-* Add stack support
-* Warn when /tmp doesn't have 5GB or more of disk space
-* Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
-* Allow to set custom ghc version when running 'ghcup compile ghc' wrt [#136](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/136)
-* Add date to GHC bindist names created by ghcup
-
-## 0.1.14.2 -- 2021-05-12
-
-* Remove dead dependency on ascii-string
-
-## 0.1.14.1 -- 2021-04-11
-
-* Make internal symlink target parser more lax, fixes [#119](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119)
-* Prepare for hackage release
-
-## 0.1.14 -- 2021-03-07
-
-* Major bugfix: fix handling of stray versions wrt [#116](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116)
-* Fix error messages and overhaul pretty printing wrt [#115](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/115)
-
-## 0.1.13 -- 2021-02-26
-
-* Support ARMv7/AARCH64
-* Add command line completions for installed and available versions wrt [MR #70](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/70)
-* Allow to cycle through set tools wrt [#114](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/114)
-* Fix item selection with unavailable versions wrt [#107](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/107)
-* Allow for dynamic post-install, post-remove and pre-compile msgs wrt [MR #68](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/68)
-* Alert user if upgraded ghcup is shadowed by old ghcup wrt [#111](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/111)
-* Fix to `ghcup` directory creation and placement for the XDG install mode ([MR #49](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/49))
-* Do 755 permissions on executables, wrt #97
-* Add [NO_COLOR](https://no-color.org/) support wrt [MR #47](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/47)
-
-## 0.1.12 -- 2020-11-21
-
-* Fix disappearing HLS symlinks wrt #91
-* improve TUI:
-  - separators between tools sections
-  - reverse list order so latest is on top
-  - expand the blues selected bar
-  - show new latest versions in bright white
-* allow configuration file and setting TUI hotkeys wrt #41
-  - see https://gitlab.haskell.org/haskell/ghcup-hs#configuration for a more in-depth explanation
-* add a `--set` switch to `ghcup install ghc` to automatically set as default after install
-* emit warnings when CC/LD is set wrt #82
-* add support for version ranges in distro specifiers wrt #84
-  - e.g. `"(>= 19 && <= 20) || ==0.2.2"` is a valid version key for distro
-
-## 0.1.11 -- 2020-09-23
-
-* Add support for installing haskell-language-server, wrt #65
-* When compiling GHC from source create a bindist first, store that bindist in `~/.ghcup/cache` and install it, wrt #51
-* Allow to compile over existing version (`ghcup compile ghc -v 8.6.5 -b 8.6.5`) and replace it wrt #59
-* simplify installing from custom bindist wrt #60
-  - `ghcup install ghc -u <url> <version>`
-* fix bug when cabal isn't marked executable in bindist
-* fix bug when `~/.ghcup` is a valid symlink wrt #49
-* Drop support for compiling cabal from source (the old bootstrap script is discontinued)
-
-## 0.1.10 -- 2020-08-14
-
-* Show stray Cabals (useful for pre-releases or compiled ones)
-
-## 0.1.9 -- 2020-08-14
-
-* Fix bug when uninstalling all cabal versions
-* Fix bug when setting a non-installed ghc version as current default
-* Use yaml instead of generated json for download info for ease of adding new GHC versions #44
-* Allow pre-release versions of GHC/cabal
-* Add XDG dirs support (set `GHCUP_USE_XDG_DIRS`) wrt #39
-* Allow to specify regex for tarball subdir (e.g. `ghc-.*`)
-* Allow installing arbitrary bindists more seamlessly:
-  - e.g. installing GHC HEAD: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": { "RegexDir": "ghc-.*"}, "dlUri": "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`
-* Avoid duplicate edits to .bashrc/.zshrc wrt #43
-
-## 0.1.8 -- 2020-07-21
-
-* Fix bug in logging thread dying on newlines
-* Allow to install from arbitrary bindists: `ghcup -n install ghc -u '{"dlHash": "", "dlSubdir": "ghc-8.10.1", "dlUri": "https://github.com/commercialhaskell/ghc/releases/download/ghc-8.10.1-release/ghc-8.10.1-x86_64-deb9-linux.tar.xz"}' 8.10.1`
-
-## 0.1.7 -- 2020-07-20
-
-* Fix a bug in libarchive not unpacking some uncleanly packed bindists
-* Improved fish support in bootstrap-haskell
-* Only check for upgrades when not upgrading
-* Fix platform detection for i386 docker images
-* Improve alpine support
-  - more/proper bindists
-  - don't fall back to glibc based bindists
-  - install bindists with `--disable-ld-override` to avoid ld.gold bugs
-
-## 0.1.6 -- 2020-07-13
-
-* Create a new curses (brick) based TUI, accessible via `ghcup tui` #24
-* Support multiple installed versions of cabal #23
-* Improvements to `ghcup list` (show unavailable bindists for platform)
-* Fix redhat downloads #29
-* Support for hadrian bindists (fixes alpine-8.10.1) #31
-* Add FreeBSD bindists 8.6.5 and 8.8.3
-* Fix memory leak during unpack
-
-## 0.1.5 -- 2020-04-30
-
-* Fix errors when PATH variable contains path components that are actually files
-* Add `--version` and `--numeric-version` options
-* Add `changelog` command
-* Also check for available GHC and Cabal updates on start
-* Add base versions as tags for every GHC version (these are "installable" tags and the latest GHC version matching the tag will be picked)
-* Added `--format-raw` to list subcommand
-* Allow to install X.Y versions (e.g.: ghcup install 8.8)
-* Implement `--keep=<always|errors|never>` to control temporary build directories cleanup
-* Add proper shell completions to the repo
-* Fix building of documentation
-* Allow to work in offline mode and use cached files if possible
-* Allow to set the downloader via `--downloader=<curl|wget>`
-* Support for compiling and installing a cross GHC (see README). This is experimental.
-
-## 0.1.4 -- 2020-04-16
-
-* build on all platforms with curl (as a binary), wrt https://gitlab.haskell.org/haskell/ghcup-hs/issues/6
-* Fix unlinking of ghc symlinks after new installation, wrt https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
-
-## 0.1.3 -- 2020-04-15
-
-* Fix lesser bug when skipping ghcup update
-
-## 0.1.2 -- 2020-04-15
-
-* Fix bug when removing the set GHC version
-* Fix use of undocumented `GHCUP_INSTALL_BASE_PREFIX` variable
-* skip upgrade if ghcup is already latest version
-
-## 0.1.1 -- 2020-04-15
-
-* fix awful fdopendir bug on mac bug by updating hpath-posix
-
-## 0.1.0
-
-* First version. Released on an unsuspecting world.

docs/RELEASING.md

@@ -1,21 +0,0 @@
-# RELEASING
-
-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. Add/fix downloads in `ghcup-<ver>.yaml` (under `data/metadata`), then verify with `ghcup-gen check -f ghcup-<ver>.yaml` and possibly (example only) `ghcup-gen check-tarballs -f ghcup-<ver>.yaml -u 'ghc-8.10.7'`. Generally, new GHC/cabal/stack/hls versions are only added to the latest yaml file. New GHCup versions are added to all (great care must be taken here to not break the parser... e.g. ARM platforms don't parse in all older formats).
-
-5. Commit and git push with tag. Wait for tests to succeed and release artifacts to build.
-
-6. Download release artifacts and upload them `downloads.haskell.org/ghcup` along with checksum files (`sha256sum --tag * > SHA256SUMS && gpg --detach-sign -u <your-email> SHA256SUMS`)
-
-7. Add ghcup release artifacts to ALL yaml files (see point 4.)
-
-8. Upload the final `ghcup-<ver>.yaml` to `webhost.haskell.org/ghcup/data/`.
-
-9. Update `bootstrap-haskell` and `bootstrap-haskell.ps1` to `webhost.haskell.org/ghcup/sh/`
-
-10. Update the ghcup symlinks at `downloads.haskell.org/ghcup`

ghcup.cabal

@@ -1,53 +1,282 @@
 cabal-version:      3.0
 name:               ghcup
-version:            0.1.17.1
-license:            LGPL-3.0-only
-license-file:       LICENSE
-copyright:          Julian Ospald 2020
-maintainer:         hasufell@posteo.de
-author:             Julian Ospald
-homepage:           https://gitlab.haskell.org/haskell/ghcup-hs
-bug-reports:        https://gitlab.haskell.org/haskell/ghcup-hs/issues
-synopsis:           ghc toolchain installer
+version:            0.1.4
+synopsis:           ghc toolchain installer as an exe/library
 description:
   A rewrite of the shell script ghcup, for providing
   a more stable user experience and exposing an API.
 
+homepage:           https://gitlab.haskell.org/haskell/ghcup-hs
+bug-reports:        https://gitlab.haskell.org/haskell/ghcup-hs/issues
+license:            LGPL-3.0-only
+license-file:       LICENSE
+author:             Julian Ospald
+maintainer:         hasufell@posteo.de
+copyright:          Julian Ospald 2020
 category:           System
 build-type:         Simple
-extra-doc-files:
-  data/config.yaml
-  data/metadata/ghcup-0.0.4.yaml
-  data/metadata/ghcup-0.0.5.yaml
-  data/metadata/ghcup-0.0.6.yaml
-  docs/CHANGELOG.md
-  docs/HACKING.md
-  docs/RELEASING.md
-  README.md
-
-extra-source-files:
-  data/build_mk/cross
-  data/build_mk/default
+extra-source-files: CHANGELOG.md
 
 source-repository head
   type:     git
   location: https://gitlab.haskell.org/haskell/ghcup-hs.git
 
-flag tui
-  description:
-    Build the brick powered tui (ghcup tui). This is disabled on windows.
-
+flag Curl
+  description: Use curl instead of http-io-streams for download
   default:     False
   manual:      True
 
-flag internal-downloader
-  description:
-    Compile the internal downloader, which links against OpenSSL. This is disabled on windows.
+common HsOpenSSL
+  build-depends: HsOpenSSL >=0.11.4.18
 
-  default:     False
-  manual:      True
+common aeson
+  build-depends: aeson >=1.4
+
+common aeson-pretty
+  build-depends: aeson-pretty >=0.8.8
+
+common ascii-string
+  build-depends: ascii-string >=1.0
+
+common async
+  build-depends: async >=0.8
+
+common attoparsec
+  build-depends: attoparsec >=0.13
+
+common base
+  build-depends: base >=4.12 && <5
+
+common base16-bytestring
+  build-depends: base16-bytestring >= 0.1.1.6
+
+common binary
+  build-depends: binary >=0.8.6.0
+
+common bytestring
+  build-depends: bytestring >=0.10
+
+common bz2
+  build-depends: bz2 >=0.5.0.5
+
+common case-insensitive
+  build-depends: case-insensitive >=1.2.1.0
+
+common concurrent-output
+  build-depends: concurrent-output >=1.10.11
+
+common containers
+  build-depends: containers >=0.6
+
+common cryptohash-sha256
+  build-depends: cryptohash-sha256 >= 0.11.101.0
+
+common generics-sop
+  build-depends: generics-sop >=0.5
+
+common haskus-utils-types
+  build-depends: haskus-utils-types >=1.5
+
+common haskus-utils-variant
+  build-depends: haskus-utils-variant >=3.0
+
+common hpath
+  build-depends: hpath >=0.11
+
+common hpath-directory
+  build-depends: hpath-directory >=0.13.3
+
+common hpath-filepath
+  build-depends: hpath-filepath >=0.10.3
+
+common hpath-io
+  build-depends: hpath-io >=0.13.1
+
+common hpath-posix
+  build-depends: hpath-posix >=0.13.2
+
+common http-io-streams
+  build-depends: http-io-streams >=0.1.2.0
+
+common io-streams
+  build-depends: io-streams >=1.5
+
+common language-bash
+  build-depends: language-bash >=0.9
+
+common lzma
+  build-depends: lzma >=0.0.0.3
+
+common megaparsec
+  build-depends: megaparsec >=8.0.0
+
+common monad-logger
+  build-depends: monad-logger >=0.3.31
+
+common mtl
+  build-depends: mtl >=2.2
+
+common optics
+  build-depends: optics >=0.2
+
+common optics-vl
+  build-depends: optics-vl >=0.2
+
+common optparse-applicative
+  build-depends: optparse-applicative >=0.15.1.0
+
+common parsec
+  build-depends: parsec >=3.1
+
+common pretty-terminal
+  build-depends: pretty-terminal >=0.1.0.0
+
+common regex-posix
+  build-depends: regex-posix >=0.96
+
+common resourcet
+  build-depends: resourcet >=1.2.2
+
+common safe
+  build-depends: safe >=0.3.18
+
+common safe-exceptions
+  build-depends: safe-exceptions >=0.1
+
+common streamly
+  build-depends: streamly >=0.7.1
+
+common streamly-posix
+  build-depends: streamly-posix >=0.1.0.0
+
+common streamly-bytestring
+  build-depends: streamly-bytestring >=0.1.2
+
+common strict-base
+  build-depends: strict-base >=0.4
+
+common string-interpolate
+  build-depends: string-interpolate >=0.2.0.0
+
+common table-layout
+  build-depends: table-layout >=0.8
+
+common tar-bytestring
+  build-depends: tar-bytestring >=0.6.3.1
+
+common template-haskell
+  build-depends: template-haskell >=2.7
+
+common terminal-progress-bar
+  build-depends: terminal-progress-bar >=0.4.1
+
+common text
+  build-depends: text >=1.2
+
+common time
+  build-depends: time >=1.9.3
+
+common transformers
+  build-depends: transformers >=0.5
+
+common unix
+  build-depends: unix >=2.7
+
+common unix-bytestring
+  build-depends: unix-bytestring >=0.3
+
+common uri-bytestring
+  build-depends: uri-bytestring >=0.3.2.2
+
+common utf8-string
+  build-depends: utf8-string >=1.0
+
+common vector
+  build-depends: vector >=0.12
+
+common versions
+  build-depends: versions >=3.5
+
+common waargonaut
+  build-depends: waargonaut >=0.8
+
+common word8
+  build-depends: word8 >=0.1.3
+
+common zlib
+  build-depends: zlib >=0.6.2.1
+
+common config
+  default-language:   Haskell2010
+  ghc-options:
+    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
+    -fwarn-incomplete-record-updates -threaded
+
+  default-extensions:
+    LambdaCase
+    MultiWayIf
+    PackageImports
+    RecordWildCards
+    ScopedTypeVariables
+    Strict
+    StrictData
+    TupleSections
 
 library
+  import:
+    config
+    , base
+    , base16-bytestring
+    , aeson
+    , ascii-string
+    , async
+    , attoparsec
+    , binary
+    , bytestring
+    , bz2
+    , case-insensitive
+    , concurrent-output
+    , containers
+    , cryptohash-sha256
+    , generics-sop
+    , haskus-utils-types
+    , haskus-utils-variant
+    , hpath
+    , hpath-directory
+    , hpath-filepath
+    , hpath-io
+    , hpath-posix
+    , language-bash
+    , lzma
+    , monad-logger
+    , mtl
+    , optics
+    , optics-vl
+    , parsec
+    , pretty-terminal
+    , regex-posix
+    , resourcet
+    , safe
+    , safe-exceptions
+    , streamly
+    , streamly-posix
+    , streamly-bytestring
+    , strict-base
+    , string-interpolate
+    , tar-bytestring
+    , template-haskell
+    , text
+    , time
+    , transformers
+    , unix
+    , unix-bytestring
+    , uri-bytestring
+    , utf8-string
+    , vector
+    , versions
+    , word8
+    , zlib
+
   exposed-modules:
     GHCup
     GHCup.Download
@@ -59,257 +288,103 @@ library
     GHCup.Types.JSON
     GHCup.Types.Optics
     GHCup.Utils
+    GHCup.Utils.Bash
     GHCup.Utils.Dirs
     GHCup.Utils.File
-    GHCup.Utils.File.Common
     GHCup.Utils.Logger
-    GHCup.Utils.MegaParsec
     GHCup.Utils.Prelude
     GHCup.Utils.String.QQ
     GHCup.Utils.Version.QQ
     GHCup.Version
 
-  hs-source-dirs:     lib
-  other-modules:      Paths_ghcup
-  autogen-modules:    Paths_ghcup
-  default-language:   Haskell2010
-  default-extensions:
-    DeriveGeneric
-    LambdaCase
-    MultiWayIf
-    NamedFieldPuns
-    PackageImports
-    QuasiQuotes
-    RecordWildCards
-    ScopedTypeVariables
-    StrictData
-    TupleSections
-    TypeApplications
-    TypeFamilies
-    ViewPatterns
+  -- other-modules:
+  -- other-extensions:
+  hs-source-dirs:  lib
 
-  ghc-options:
-    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-    -fwarn-incomplete-record-updates
-
-  build-depends:
-    , aeson                 >=1.4        && <1.6
-    , async                 >=0.8        && <2.3
-    , base                  >=4.13       && <5
-    , base16-bytestring     >=0.1.1.6    && <1.1
-    , binary                ^>=0.8.6.0
-    , bytestring            ^>=0.10
-    , Cabal
-    , case-insensitive      ^>=1.2.1.0
-    , casing                ^>=0.1.4.1
-    , containers            ^>=0.6
-    , cryptohash-sha256     ^>=0.11.101.0
-    , deepseq               ^>=1.4.4.0
-    , directory             ^>=1.3.6.0
-    , disk-free-space       ^>=0.1.0.1
-    , filepath              ^>=1.4.2.1
-    , haskus-utils-types    ^>=1.5
-    , haskus-utils-variant  >=3.0        && <3.2
-    , HsYAML-aeson          ^>=0.2.0.0
-    , libarchive            ^>=3.0.0.0
-    , lzma-static           ^>=5.2.5.3
-    , megaparsec            >=8.0.0      && <9.1
-    , mtl                   ^>=2.2
-    , optics                ^>=0.4
-    , os-release            ^>=1.0.0
-    , pretty                ^>=1.1.3.1
-    , pretty-terminal       ^>=0.1.0.0
-    , regex-posix           ^>=0.96
-    , resourcet             ^>=1.2.2
-    , safe                  ^>=0.3.18
-    , safe-exceptions       ^>=0.1
-    , split                 ^>=0.2.3.4
-    , strict-base           ^>=0.4
-    , template-haskell      >=2.7        && <2.18
-    , temporary             ^>=1.3
-    , text                  ^>=1.2.4.0
-    , time                  ^>=1.9.3
-    , transformers          ^>=0.5
-    , unliftio-core         ^>=0.2.0.1
-    , unordered-containers  ^>=0.2.10.0
-    , uri-bytestring        ^>=0.3.2.2
-    , vector                ^>=0.12
-    , versions              >=4.0.1      && <5.1
-    , word8                 ^>=0.1.3
-    , zlib                  ^>=0.6.2.2
-
-  if (flag(internal-downloader) && !os(windows))
+  if !flag(curl)
+    import:
+      , HsOpenSSL
+      , http-io-streams
+      , io-streams
+      , terminal-progress-bar
     exposed-modules: GHCup.Download.IOStreams
-    cpp-options:     -DINTERNAL_DOWNLOADER
-    build-depends:
-      , HsOpenSSL              >=0.11.4.18
-      , http-io-streams        >=0.1.2.0
-      , io-streams             >=1.5.2.1
-      , terminal-progress-bar  >=0.4.1
-
-  if os(windows)
-    cpp-options:   -DIS_WINDOWS
-    other-modules: GHCup.Utils.File.Windows
-    build-depends:
-      , bzlib
-      , process  ^>=1.6.11.0
-      , retry    ^>=0.8.1.2
-      , Win32    ^>=2.10
-
   else
-    other-modules:
-      GHCup.Utils.File.Posix
-      System.Console.Terminal.Common
-      System.Console.Terminal.Posix
-
-    build-depends:
-      , bz2              >=0.5.0.5 && <1.1
-      , unix             ^>=2.7
-      , unix-bytestring  ^>=0.3.7.3
-
-  if (flag(tui) && !os(windows))
-    cpp-options:   -DBRICK
-    build-depends: vty >=5.28.2 && <5.34
+    cpp-options:     -DCURL
 
 executable ghcup
-  main-is:            Main.hs
-  hs-source-dirs:     app/ghcup
-  default-language:   Haskell2010
-  default-extensions:
-    LambdaCase
-    MultiWayIf
-    NamedFieldPuns
-    PackageImports
-    RecordWildCards
-    ScopedTypeVariables
-    StrictData
-    TupleSections
+  import:
+    config
+    , base
+    , bytestring
+    , containers
+    , haskus-utils-variant
+    , hpath
+    , hpath-io
+    , megaparsec
+    , monad-logger
+    , mtl
+    , optparse-applicative
+    , pretty-terminal
+    , resourcet
+    , safe
+    , string-interpolate
+    , table-layout
+    , template-haskell
+    , text
+    , uri-bytestring
+    , utf8-string
+    , versions
 
-  ghc-options:
-    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-    -fwarn-incomplete-record-updates -threaded
+  --
+  main-is:          Main.hs
 
-  build-depends:
-    , aeson                 >=1.4      && <1.6
-    , aeson-pretty          ^>=0.8.8
-    , async                 ^>=2.2.3
-    , base                  >=4.13     && <5
-    , bytestring            ^>=0.10
-    , cabal-plan            ^>=0.7.2
-    , containers            ^>=0.6
-    , deepseq               ^>=1.4
-    , filepath              ^>=1.4.2.1
-    , ghcup
-    , haskus-utils-variant  >=3.0      && <3.2
-    , HsYAML-aeson          ^>=0.2.0.0
-    , libarchive            ^>=3.0.0.0
-    , megaparsec            >=8.0.0    && <9.1
-    , mtl                   ^>=2.2
-    , optparse-applicative  >=0.15.1.0 && <0.17
-    , pretty                ^>=1.1.3.1
-    , pretty-terminal       ^>=0.1.0.0
-    , resourcet             ^>=1.2.2
-    , safe                  ^>=0.3.18
-    , safe-exceptions       ^>=0.1
-    , template-haskell      >=2.7      && <2.18
-    , text                  ^>=1.2.4.0
-    , uri-bytestring        ^>=0.3.2.2
-    , utf8-string           ^>=1.0
-    , versions              >=4.0.1    && <5.1
-
-  if flag(internal-downloader)
-    cpp-options: -DINTERNAL_DOWNLOADER
-
-  if (flag(tui) && !os(windows))
-    cpp-options:   -DBRICK
-    other-modules: BrickMain
-    build-depends:
-      , brick         ^>=0.64
-      , transformers  ^>=0.5
-      , vector        ^>=0.12
-      , vty           >=5.28.2 && <5.34
-
-  if os(windows)
-    cpp-options: -DIS_WINDOWS
+  -- other-modules:
+  -- other-extensions:
+  build-depends:    ghcup
+  hs-source-dirs:   app/ghcup
+  default-language: Haskell2010
 
 executable ghcup-gen
-  main-is:            Main.hs
-  hs-source-dirs:     app/ghcup-gen
-  other-modules:      Validate
-  default-language:   Haskell2010
-  default-extensions:
-    DeriveGeneric
-    LambdaCase
-    MultiWayIf
-    NamedFieldPuns
-    PackageImports
-    QuasiQuotes
-    RecordWildCards
-    ScopedTypeVariables
-    StrictData
-    TupleSections
-    TypeApplications
-    TypeFamilies
-    ViewPatterns
+  import:
+    config
+    , base
+    , aeson
+    , aeson-pretty
+    , bytestring
+    , containers
+    , haskus-utils-variant
+    , hpath
+    , monad-logger
+    , mtl
+    , optics
+    , optparse-applicative
+    , pretty-terminal
+    , resourcet
+    , safe-exceptions
+    , string-interpolate
+    , table-layout
+    , text
+    , transformers
+    , uri-bytestring
+    , utf8-string
+    , versions
 
-  ghc-options:
-    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-    -fwarn-incomplete-record-updates -threaded
+  --
+  main-is:          Main.hs
+  other-modules:
+    GHCupDownloads
+    GHCupInfo
+    ToolRequirements
+    Validate
 
-  build-depends:
-    , base                  >=4.13     && <5
-    , bytestring            ^>=0.10
-    , containers            ^>=0.6
-    , filepath              ^>=1.4.2.1
-    , ghcup
-    , haskus-utils-variant  >=3.0      && <3.2
-    , HsYAML-aeson          ^>=0.2.0.0
-    , libarchive            ^>=3.0.0.0
-    , mtl                   ^>=2.2
-    , optics                ^>=0.4
-    , optparse-applicative  >=0.15.1.0 && <0.17
-    , pretty                ^>=1.1.3.1
-    , pretty-terminal       ^>=0.1.0.0
-    , regex-posix           ^>=0.96
-    , resourcet             ^>=1.2.2
-    , safe-exceptions       ^>=0.1
-    , text                  ^>=1.2.4.0
-    , transformers          ^>=0.5
-    , versions              >=4.0.1    && <5.1
+  -- other-extensions:
+  build-depends:    ghcup
+  hs-source-dirs:   app/ghcup-gen
+  default-language: Haskell2010
 
 test-suite ghcup-test
-  type:               exitcode-stdio-1.0
-  main-is:            Main.hs
-  build-tool-depends: hspec-discover:hspec-discover -any
-  hs-source-dirs:     test
-  other-modules:
-    GHCup.ArbitraryTypes
-    GHCup.Types.JSONSpec
-    Spec
-
-  default-language:   Haskell2010
-  default-extensions:
-    LambdaCase
-    MultiWayIf
-    PackageImports
-    RecordWildCards
-    ScopedTypeVariables
-    TupleSections
-
-  ghc-options:
-    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-    -fwarn-incomplete-record-updates
-
-  build-depends:
-    , base                      >=4.13    && <5
-    , bytestring                ^>=0.10
-    , containers                ^>=0.6
-    , generic-arbitrary         ^>=0.1.0
-    , ghcup
-    , hspec                     ^>=2.7.10
-    , hspec-golden-aeson        ^>=0.9
-    , QuickCheck                ^>=2.14.1
-    , quickcheck-arbitrary-adt  ^>=0.3.1.0
-    , text                      ^>=1.2.4.0
-    , uri-bytestring            ^>=0.3.2.2
-    , versions                  >=4.0.1   && <5.1
+  default-language: Haskell2010
+  type:             exitcode-stdio-1.0
+  hs-source-dirs:   test
+  main-is:          MyLibTest.hs
+  build-depends:    base >=4.12.0.0

hie.yaml

@@ -1,10 +0,0 @@
-cradle:
-  cabal:
-  - component: "ghcup:lib:ghcup"
-    path: ./lib
-  - component: "ghcup:exe:ghcup"
-    path: ./app/ghcup
-  - component: "ghcup:exe:ghcup-gen"
-    path: "./app/ghcup-gen"
-  - component: "ghcup:test:ghcup-test"
-    path: ./test

lib/GHCup/Download.hs

@@ -1,41 +1,26 @@
 {-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 
 
-{-|
-Module      : GHCup.Download
-Description : Downloading
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
-
-Module for handling all download related functions.
-
-Generally we support downloading via:
-
-  - curl (default)
-  - wget
-  - internal downloader (only when compiled)
--}
 module GHCup.Download where
 
-#if defined(INTERNAL_DOWNLOADER)
+#if !defined(CURL)
 import           GHCup.Download.IOStreams
 import           GHCup.Download.Utils
 #endif
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.Dirs
+import           GHCup.Types.Optics
+import           GHCup.Utils
 import           GHCup.Utils.File
-import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 import           GHCup.Version
 
@@ -45,49 +30,47 @@ import           Control.Monad
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
 #endif
+import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
 import           Data.Aeson
-import           Data.Bifunctor
+#if !defined(CURL)
 import           Data.ByteString                ( ByteString )
-#if defined(INTERNAL_DOWNLOADER)
-import           Data.CaseInsensitive           ( mk )
+import           Data.CaseInsensitive           ( CI )
 #endif
 import           Data.Maybe
-import           Data.List
+import           Data.String.Interpolate
 import           Data.Time.Clock
 import           Data.Time.Clock.POSIX
-import           Data.Versions
-import           Data.Word8              hiding ( isSpace )
-import           Haskus.Utils.Variant.Excepts
-#if defined(INTERNAL_DOWNLOADER)
-import           Network.Http.Client     hiding ( URL )
+#if !defined(CURL)
+import           Data.Time.Format
 #endif
+import           Data.Versions
+import           GHC.IO.Exception
+import           HPath
+import           HPath.IO                      as HIO
+import           Haskus.Utils.Variant.Excepts
 import           Optics
 import           Prelude                 hiding ( abs
                                                 , readFile
                                                 , writeFile
                                                 )
-import           Safe
-import           System.Directory
-import           System.Environment
-import           System.Exit
-import           System.FilePath
 import           System.IO.Error
-import           System.IO.Temp
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString
 
 import qualified Crypto.Hash.SHA256            as SHA256
-import qualified Data.ByteString               as B
 import qualified Data.ByteString.Base16        as B16
 import qualified Data.ByteString.Lazy          as L
+#if !defined(CURL)
+import qualified Data.CaseInsensitive          as CI
 import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
-import qualified Data.Text.IO                  as T
+#endif
 import qualified Data.Text.Encoding            as E
-import qualified Data.YAML.Aeson               as Y
+import qualified System.Posix.Files.ByteString as PF
+import qualified System.Posix.RawFilePath.Directory
+                                               as RD
 
 
 
@@ -99,212 +82,145 @@ import qualified Data.YAML.Aeson               as Y
     ------------------
 
 
-
 -- | Downloads the download information! But only if we need to ;P
-getDownloadsF :: ( FromJSONKey Tool
-                 , FromJSONKey Version
-                 , FromJSON VersionInfo
-                 , MonadReader env m
-                 , HasSettings env
-                 , HasDirs env
-                 , MonadIO m
-                 , MonadCatch m
-                 , HasLog env
-                 , MonadThrow m
-                 , MonadFail m
-                 , MonadMask m
-                 )
-              => Excepts
-                   '[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
-                   m
-                   GHCupInfo
-getDownloadsF = do
-  Settings { urlSource } <- lift getSettings
+getDownloads :: ( FromJSONKey Tool
+                , FromJSONKey Version
+                , FromJSON VersionInfo
+                , MonadIO m
+                , MonadCatch m
+                , MonadLogger m
+                , MonadThrow m
+                , MonadFail m
+                )
+             => URLSource
+             -> Excepts '[JSONError , DownloadFailed] m GHCupInfo
+getDownloads urlSource = do
+  lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
   case urlSource of
-    GHCupURL -> liftE $ getBase ghcupURL
-    (OwnSource url) -> liftE $ getBase url
-    (OwnSpec av) -> pure av
-    (AddSource (Left ext)) -> do
-      base <- liftE $ getBase ghcupURL
-      pure (mergeGhcupInfo base ext)
-    (AddSource (Right uri)) -> do
-      base <- liftE $ getBase ghcupURL
-      ext  <- liftE $ getBase uri
-      pure (mergeGhcupInfo base ext)
+    GHCupURL -> do
+      bs <- reThrowAll DownloadFailed $ smartDl ghcupURL
+      lE' JSONDecodeError $ eitherDecode' bs
+    (OwnSource url) -> do
+      bs <- reThrowAll DownloadFailed $ downloadBS url
+      lE' JSONDecodeError $ eitherDecode' bs
+    (OwnSpec av) -> pure $ av
 
-    where
-
-  mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
-                 -> GHCupInfo -- ^ extension overwriting the base
-                 -> GHCupInfo
-  mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
-    let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
-                                        Just a' -> M.union a' a
-                                        Nothing -> a
-                                    ) 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 (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
-
-
-etagsFile :: FilePath -> FilePath
-etagsFile = (<.> "etags")
-
-
-getBase :: ( MonadReader env m
-           , HasDirs env
-           , HasSettings env
-           , MonadFail m
-           , MonadIO m
-           , MonadCatch m
-           , HasLog env
-           , MonadMask m
-           )
-        => URI
-        -> Excepts '[GPGError, DigestError, JSONError, FileDoesNotExistError] m GHCupInfo
-getBase uri = do
-  Settings { noNetwork, downloader } <- lift getSettings
-
-  -- try to download yaml... usually this writes it into cache dir,
-  -- but in some cases not (e.g. when using file://), so we honour
-  -- the return filepath, if any
-  mYaml <- if noNetwork && view (uriSchemeL' % schemeBSL') uri /= "file" -- for file://, let it fall through
-           then pure Nothing
-           else handleIO (\e -> lift (warnCache (displayException e) downloader) >> pure Nothing)
-               . catchE @_ @_ @'[] (\e@(DownloadFailed _) -> lift (warnCache (prettyShow e) downloader) >> pure Nothing)
-               . fmap Just
-               . smartDl
-               $ uri
-
-  -- if we didn't get a filepath from the download, use the cached yaml
-  actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
-  yamlContents <- liftIOException doesNotExistErrorType (FileDoesNotExistError actualYaml) $ liftIO $ L.readFile actualYaml
-  lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
-
-  liftE
-    . onE_ (onError actualYaml)
-    . lE' @_ @_ @'[JSONError] JSONDecodeError
-    . first (\(_, e) -> unlines [e, "Consider removing " <> actualYaml <> " manually."])
-    . Y.decode1
-    $ yamlContents
  where
-  -- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-  -- may re-download and succeed.
-  onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
-  onError fp = do
-    let efp = etagsFile fp
-    handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
-      (hideError doesNotExistErrorType $ rmFile efp)
-    liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
-
-  warnCache :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> Downloader -> m ()
-  warnCache s downloader' = do
-    let tryDownloder = case downloader' of
-                         Curl -> "Wget"
-                         Wget -> "Curl"
-#if defined(INTERNAL_DOWNLOADER)
-                         Internal -> "Curl"
-#endif
-    logWarn $ "Could not get download info, trying cached version (this may not be recent!)" <> "\n" <>
-      "If this problem persists, consider switching downloader via: " <> "\n    " <>
-      "ghcup config set downloader " <> tryDownloder
-    logDebug $ "Error was: " <> T.pack s
-
   -- First check if the json file is in the ~/.ghcup/cache dir
   -- and check it's access time. If it has been accessed within the
   -- last 5 minutes, just reuse it.
   --
+  -- If not, then send a HEAD request and check for modification time.
+  -- Only download the file if the modification time is newer
+  -- than the local file.
+  --
   -- Always save the local file with the mod time of the remote file.
-  smartDl :: forall m1 env1
-           . ( MonadReader env1 m1
-             , HasDirs env1
-             , HasSettings env1
-             , MonadCatch m1
-             , MonadIO m1
-             , MonadFail m1
-             , HasLog env1
-             , MonadMask m1
-             )
+  smartDl :: forall m1
+           . (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
           => URI
           -> Excepts
-               '[ DownloadFailed
-                , DigestError
-                , GPGError
+               '[ FileDoesNotExistError
+                , HTTPStatusError
+                , URIParseError
+                , UnsupportedScheme
+                , NoLocationHeader
+                , TooManyRedirs
+                , ProcessError
                 ]
                m1
-               FilePath
+               L.ByteString
   smartDl uri' = do
-    json_file <- lift $ yamlFromCache uri'
-    let scheme = view (uriSchemeL' % schemeBSL') uri'
-    e <- liftIO $ doesFileExist json_file
-    currentTime <- liftIO getCurrentTime
-    Dirs { cacheDir } <- lift getDirs
+    let path = view pathL' uri'
+    cacheDir  <- liftIO $ ghcupCacheDir
+    json_file <- (cacheDir </>) <$> urlBaseName path
+    e         <- liftIO $ doesFileExist json_file
+    if e
+      then do
+        accessTime <-
+          PF.accessTimeHiRes
+            <$> (liftIO $ PF.getFileStatus (toFilePath json_file))
+        currentTime <- liftIO $ getPOSIXTime
 
-       -- for local files, let's short-circuit and ignore access time
-    if | scheme == "file" -> liftE $ download uri' Nothing Nothing cacheDir Nothing True
-       | e -> do
-          accessTime <- liftIO $ getAccessTime json_file
+        -- access time won't work on most linuxes, but we can try regardless
+        if (currentTime - accessTime) > 300
+          then do -- no access in last 5 minutes, re-check upstream mod time
+            getModTime >>= \case
+              Just modTime -> do
+                fileMod <- liftIO $ getModificationTime json_file
+                if modTime > fileMod
+                  then do
+                    bs <- liftE $ downloadBS uri'
+                    liftIO $ writeFileWithModTime modTime json_file bs
+                    pure bs
+                  else liftIO $ readFile json_file
+              Nothing -> do
+                lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
+                liftIO $ deleteFile json_file
+                liftE $ downloadBS uri'
+          else -- access in less than 5 minutes, re-use file
+               liftIO $ readFile json_file
+      else do
+        liftIO $ createDirIfMissing newDirPerms cacheDir
+        getModTime >>= \case
+          Just modTime -> do
+            bs <- liftE $ downloadBS uri'
+            liftIO $ writeFileWithModTime modTime json_file bs
+            pure bs
+          Nothing -> do
+            lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
+            liftE $ downloadBS uri'
 
-          -- access time won't work on most linuxes, but we can try regardless
-          if | ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) ->
-                -- no access in last 5 minutes, re-check upstream mod time
-                dlWithMod currentTime json_file
-             | otherwise -> pure json_file
-       | otherwise -> dlWithMod currentTime json_file
    where
-    dlWithMod modTime json_file = do
-      let (dir, fn) = splitFileName json_file
-      f <- liftE $ download uri' (Just $ over pathL' (<> ".sig") uri') Nothing dir (Just fn) True
-      liftIO $ setModificationTime f modTime
-      liftIO $ setAccessTime f modTime
-      pure f
+    getModTime = do
+#if defined(CURL)
+      pure Nothing
+#else
+      headers <-
+        handleIO (\_ -> pure mempty)
+        $ liftE
+        $ ( catchAllE
+              (\_ ->
+                pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
+              )
+          $ getHead uri'
+          )
+      pure $ parseModifiedHeader headers
+
+  parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
+  parseModifiedHeader headers =
+    (M.lookup (CI.mk "Last-Modified") headers) >>= \h -> parseTimeM
+      True
+      defaultTimeLocale
+      "%a, %d %b %Y %H:%M:%S %Z"
+      (T.unpack . decUTF8Safe $ h)
+
+#endif
+
+  writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
+  writeFileWithModTime utctime path content = do
+    let mod_time = utcTimeToPOSIXSeconds utctime
+    writeFileL path (Just newFilePerms) content
+    setModificationTimeHiRes path mod_time
 
 
-getDownloadInfo :: ( MonadReader env m
-                   , HasPlatformReq env
-                   , HasGHCupInfo env
-                   )
-                => Tool
+getDownloadInfo :: Tool
                 -> Version
                 -- ^ tool version
-                -> Excepts
-                     '[NoDownload]
-                     m
-                     DownloadInfo
-getDownloadInfo t v = do
-  (PlatformRequest a p mv) <- lift getPlatformReq
-  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
+                -> PlatformRequest
+                -> GHCupDownloads
+                -> Either NoDownload DownloadInfo
+getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
+  (Left NoDownload)
+  Right
+  (with_distro <|> without_distro_ver <|> without_distro)
 
-  let distro_preview f g =
-        let platformVersionSpec =
-              preview (ix t % ix v % viArch % ix a % ix (f p)) dls
-            mv' = g mv
-        in  fmap snd
-              .   find
-                    (\(mverRange, _) -> maybe
-                      (isNothing mv')
-                      (\range -> maybe False (`versionRange` range) mv')
-                      mverRange
-                    )
-              .   M.toList
-              =<< platformVersionSpec
-      with_distro        = distro_preview id id
-      without_distro_ver = distro_preview id (const Nothing)
-      without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)
+ where
+  with_distro        = distro_preview id id
+  without_distro_ver = distro_preview id (const Nothing)
+  without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)
 
-  maybe
-    (throwE NoDownload)
-    pure
-    (case p of
-      -- non-musl won't work on alpine
-      Linux Alpine -> with_distro <|> without_distro_ver
-      _            -> with_distro <|> without_distro_ver <|> without_distro
-    )
+  distro_preview f g =
+    preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
 
 
 -- | Tries to download from the given http or https url
@@ -314,301 +230,93 @@ getDownloadInfo t v = do
 --   2. otherwise create a random file
 --
 -- The file must not exist.
-download :: ( MonadReader env m
-            , HasSettings env
-            , HasDirs env
-            , MonadMask m
+download :: ( MonadMask m
+            , MonadReader Settings m
             , MonadThrow m
-            , HasLog env
+            , MonadLogger m
             , MonadIO m
             )
-         => URI
-         -> Maybe URI         -- ^ URI for gpg sig
-         -> Maybe T.Text      -- ^ expected hash
-         -> FilePath          -- ^ destination dir (ignored for file:// scheme)
-         -> Maybe FilePath    -- ^ optional filename
-         -> Bool              -- ^ whether to read an write etags
-         -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
-download uri gpgUri eDigest dest mfn etags
+         => DownloadInfo
+         -> Path Abs          -- ^ destination dir
+         -> Maybe (Path Rel)  -- ^ optional filename
+         -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
+download dli dest mfn
   | scheme == "https" = dl
   | scheme == "http"  = dl
-  | scheme == "file"  = do
-      let destFile' = T.unpack . decUTF8Safe $ view pathL' uri
-      lift $ logDebug $ "using local file: " <> T.pack destFile'
-      forM_ eDigest (liftE . flip checkDigest destFile')
-      pure destFile'
+  | scheme == "file"  = cp
   | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
 
  where
-  scheme = view (uriSchemeL' % schemeBSL') uri
+  scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
+  cp     = do
+    -- destination dir must exist
+    liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
+    destFile <- getDestFile
+    fromFile <- parseAbs path
+    liftIO $ copyFile fromFile destFile Strict
+    pure destFile
   dl = do
-    baseDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile uri mfn
-    lift $ logInfo $ "downloading: " <> (decUTF8Safe . serializeURIRef') uri <> " as file " <> T.pack baseDestFile
+    let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
+    lift $ $(logInfo) [i|downloading: #{uri'}|]
 
     -- destination dir must exist
-    liftIO $ createDirRecursive' dest
-
+    liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
+    destFile <- getDestFile
 
     -- download
     flip onException
-         (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile))
-     $ catchAllE @_ @'[GPGError, ProcessError, DownloadFailed, UnsupportedScheme, DigestError] @'[DigestError, DownloadFailed, GPGError]
-          (\e' -> do
-            lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile baseDestFile)
-            case e' of
-              V e@GPGError {} -> throwE e
-              V e@DigestError {} -> throwE e
-              _ -> throwE (DownloadFailed e')
+         (liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
+     $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
+          (\e ->
+            (liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
+              >> (throwE . DownloadFailed $ e)
           ) $ do
-              Settings{ downloader, noNetwork, gpgSetting } <- lift getSettings
-              when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
-              downloadAction <- case downloader of
-                    Curl -> do
-                      o' <- liftIO getCurlOpts
-                      if etags
-                        then pure $ curlEtagsDL o'
-                        else pure $ curlDL o'
-                    Wget -> do
-                      o' <- liftIO getWgetOpts
-                      if etags
-                        then pure $ wgetEtagsDL o'
-                        else pure $ wgetDL o'
-#if defined(INTERNAL_DOWNLOADER)
-                    Internal -> do
-                      if etags
-                        then pure (\fp -> liftE . internalEtagsDL fp)
-                        else pure (\fp -> liftE . internalDL fp)
-#endif
-              liftE $ downloadAction baseDestFile uri
-              case (gpgUri, gpgSetting) of
-                (_, GPGNone) -> pure ()
-                (Just gpgUri', _) -> do
-                  gpgDestFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile gpgUri' Nothing
-                  liftE $ flip onException
-                       (lift $ hideError doesNotExistErrorType $ recycleFile (tmpFile gpgDestFile))
-                   $ catchAllE @_ @'[GPGError, ProcessError, UnsupportedScheme, DownloadFailed] @'[GPGError]
-                        (\e -> if gpgSetting == GPGStrict then throwE (GPGError e) else lift $ logWarn $ T.pack (prettyShow (GPGError e))
-                        ) $ do
-                      o' <- liftIO getGpgOpts
-                      lift $ logDebug $ "downloading: " <> (decUTF8Safe . serializeURIRef') gpgUri' <> " as file " <> T.pack gpgDestFile
-                      liftE $ downloadAction gpgDestFile gpgUri'
-                      lift $ logInfo $ "verifying signature of: " <> T.pack baseDestFile
-                      let args = o' ++ ["--batch", "--verify", "--quiet", "--no-tty", gpgDestFile, baseDestFile]
-                      cp <- lift $ executeOut "gpg" args Nothing
-                      case cp of
-                        CapturedProcess { _exitCode = ExitFailure i, _stdErr } -> do
-                          lift $ logDebug $ decUTF8Safe' _stdErr
-                          throwE (GPGError @'[ProcessError] (V (NonZeroExit i "gpg" args)))
-                        CapturedProcess { _stdErr } -> lift $ logDebug $ decUTF8Safe' _stdErr
-                _ -> pure ()
-
-              forM_ eDigest (liftE . flip checkDigest baseDestFile)
-    pure baseDestFile
-
-  curlDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-  curlDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
-    let destFileTemp = tmpFile destFile
-    flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
-      liftE $ lEM @_ @'[ProcessError] $ exec "curl"
-        (o' ++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
-      liftIO $ renameFile destFileTemp destFile
-
-  curlEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
-              => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-  curlEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
-    let destFileTemp = tmpFile destFile
-    dh <- liftIO $ emptySystemTempFile "curl-header"
-    flip finally (try @_ @SomeException $ rmFile dh) $
-      flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
-        metag <- lift $ readETag destFile
-        liftE $ lEM @_ @'[ProcessError] $ exec "curl"
-            (o' ++ (if etags then ["--dump-header", dh] else [])
-                ++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
-                ++ ["-fL", "-o", destFileTemp, T.unpack uri']) Nothing Nothing
-        headers <- liftIO $ T.readFile dh
-
-        -- this nonsense is necessary, because some older versions of curl would overwrite
-        -- the destination file when 304 is returned
-        case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
-          Just (http':sc:_)
-            | sc == "304"
-            , T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
-            | T.pack "HTTP" `T.isPrefixOf` http' -> do
-                lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
-                liftIO $ renameFile destFileTemp destFile
-          _ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
-            :: V '[MalformedHeaders]))
-
-        lift $ writeEtags destFile (parseEtags headers)
-
-  wgetDL :: (MonadCatch m, MonadMask m, MonadIO m) => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-  wgetDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
-    let destFileTemp = tmpFile destFile
-    flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
-      let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
-      liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
-      liftIO $ renameFile destFileTemp destFile
-
-
-  wgetEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
-              => [String] -> FilePath -> URI -> Excepts '[ProcessError, DownloadFailed, UnsupportedScheme] m ()
-  wgetEtagsDL o' destFile (decUTF8Safe . serializeURIRef' -> uri') = do
-    let destFileTemp = tmpFile destFile
-    flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
-      metag <- lift $ readETag destFile
-      let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
-                    ++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
-      CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
-      case _exitCode of
-        ExitSuccess -> do
-          liftIO $ renameFile destFileTemp destFile
-          lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
-        ExitFailure i'
-          | i' == 8
-          , Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-                   -> do
-                        lift $ logDebug "Not modified, skipping download"
-                        lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
-          | otherwise -> throwE (NonZeroExit i' "wget" opts)
-
-#if defined(INTERNAL_DOWNLOADER)
-  internalDL :: (MonadCatch m, MonadMask m, MonadIO m)
-             => FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
-  internalDL destFile uri' = do
-    let destFileTemp = tmpFile destFile
-    flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
-      (https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
-      void $ liftE $ catchE @HTTPNotModified
-                 @'[DownloadFailed]
-            (\e@(HTTPNotModified _) ->
-              throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
-        $ downloadToFile https host fullPath port destFileTemp mempty
-      liftIO $ renameFile destFileTemp destFile
-
-
-  internalEtagsDL :: (MonadReader env m, HasLog env, MonadCatch m, MonadMask m, MonadIO m)
-                  => FilePath -> URI -> Excepts '[DownloadFailed, UnsupportedScheme] m ()
-  internalEtagsDL destFile uri' = do
-    let destFileTemp = tmpFile destFile
-    flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
-      (https, host, fullPath, port) <- liftE $ uriToQuadruple uri'
-      metag <- lift $ readETag destFile
-      let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
-                                                         , E.encodeUtf8 etag)]) metag
-      liftE
-        $ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
-        $ do
-          r <- downloadToFile https host fullPath port destFileTemp addHeaders
-          liftIO $ renameFile destFileTemp destFile
-          lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
+#if defined(CURL)
+              liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
+                ["-fL", "-o", toFilePath destFile , serializeURIRef' $ view dlUri dli] Nothing Nothing
+#else
+              (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
+              liftE $ downloadToFile https host fullPath port destFile
 #endif
 
+    liftE $ checkDigest dli destFile
+    pure destFile
 
   -- Manage to find a file we can write the body into.
-  getDestFile :: Monad m => URI -> Maybe FilePath -> Excepts '[NoUrlBase] m FilePath
-  getDestFile uri' mfn' = 
-    let path = view pathL' uri'
-    in case mfn' of
-        Just fn -> pure (dest </> fn)
-        Nothing
-          | let urlBase = T.unpack (decUTF8Safe (urlBaseName path))
-          , not (null urlBase) -> pure (dest </> urlBase)
-          -- TODO: remove this once we use hpath again
-          | otherwise -> throwE $ NoUrlBase (decUTF8Safe . serializeURIRef' $ uri')
+  getDestFile :: MonadThrow m => m (Path Abs)
+  getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
 
-  parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
-  parseEtags stderr = do
-    let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr
-    case T.words <$> mEtag of
-      (Just []) -> do
-        logDebug "Couldn't parse etags, no input: "
-        pure Nothing
-      (Just [_, etag']) -> do
-        logDebug $ "Parsed etag: " <> etag'
-        pure (Just etag')
-      (Just xs) -> do
-        logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
-        pure Nothing
-      Nothing -> do
-        logDebug "No etags header found"
-        pure Nothing
-
-  writeEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
-  writeEtags destFile getTags = do
-    getTags >>= \case
-      Just t -> do
-        logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
-        liftIO $ T.writeFile (etagsFile destFile) t
-      Nothing ->
-        logDebug "No etags files written"
-
-  readETag :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
-  readETag fp = do
-    e <- liftIO $ doesFileExist fp
-    if e
-    then do
-      rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
-      case rE of
-        (Right et) -> do
-          logDebug $ "Read etag: " <> et
-          pure (Just et)
-        (Left _) -> do
-          logDebug "Etag file doesn't exist (yet)"
-          pure Nothing
-    else do
-      logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
-      liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
-      pure Nothing
+  path        = view (dlUri % pathL') dli
 
 
 -- | Download into tmpdir or use cached version, if it exists. If filename
 -- is omitted, infers the filename from the url.
-downloadCached :: ( MonadReader env m
-                  , HasDirs env
-                  , HasSettings env
-                  , MonadMask m
+downloadCached :: ( MonadMask m
                   , MonadResource m
                   , MonadThrow m
-                  , HasLog env
+                  , MonadLogger m
                   , MonadIO m
-                  , MonadUnliftIO m
+                  , MonadReader Settings m
                   )
                => DownloadInfo
-               -> Maybe FilePath  -- ^ optional filename
-               -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
+               -> Maybe (Path Rel)  -- ^ optional filename
+               -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
 downloadCached dli mfn = do
-  Settings{ cache } <- lift getSettings
+  cache <- lift getCache
   case cache of
-    True -> downloadCached' dli mfn Nothing
+    True -> do
+      cachedir <- liftIO $ ghcupCacheDir
+      fn       <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
+      let cachfile = cachedir </> fn
+      fileExists <- liftIO $ doesFileExist cachfile
+      if
+        | fileExists -> do
+          liftE $ checkDigest dli cachfile
+          pure $ cachfile
+        | otherwise -> liftE $ download dli cachedir mfn
     False -> do
       tmp <- lift withGHCupTmpDir
-      liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) tmp mfn False
-
-
-downloadCached' :: ( MonadReader env m
-                   , HasDirs env
-                   , HasSettings env
-                   , MonadMask m
-                   , MonadThrow m
-                   , HasLog env
-                   , MonadIO m
-                   , MonadUnliftIO m
-                   )
-                => DownloadInfo
-                -> Maybe FilePath  -- ^ optional filename
-                -> Maybe FilePath  -- ^ optional destination dir (default: cacheDir)
-                -> Excepts '[DigestError , DownloadFailed, GPGError] m FilePath
-downloadCached' dli mfn mDestDir = do
-  Dirs { cacheDir } <- lift getDirs
-  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
-  if
-    | fileExists -> do
-      liftE $ checkDigest (view dlHash dli) cachfile
-      pure cachfile
-    | otherwise -> liftE $ download (_dlUri dli) Nothing (Just (_dlHash dli)) destDir mfn False
+      liftE $ download dli tmp mfn
 
 
 
@@ -619,70 +327,61 @@ downloadCached' dli mfn mDestDir = do
 
 
 
-checkDigest :: ( MonadReader env m
-               , HasDirs env
-               , HasSettings env
-               , MonadIO m
-               , MonadThrow m
-               , HasLog env
-               )
-            => T.Text     -- ^ the hash
-            -> FilePath
+
+-- | This is used for downloading the JSON.
+downloadBS :: (MonadCatch m, MonadIO m)
+           => URI
+           -> Excepts
+                '[ FileDoesNotExistError
+                 , HTTPStatusError
+                 , URIParseError
+                 , UnsupportedScheme
+                 , NoLocationHeader
+                 , TooManyRedirs
+                 , ProcessError
+                 ]
+                m
+                L.ByteString
+downloadBS uri'
+  | scheme == "https"
+  = dl True
+  | scheme == "http"
+  = dl False
+  | scheme == "file"
+  = liftIOException doesNotExistErrorType (FileDoesNotExistError path)
+    $ (liftIO $ RD.readFile path)
+  | otherwise
+  = throwE UnsupportedScheme
+
+ where
+  scheme = view (uriSchemeL' % schemeBSL') uri'
+  path   = view pathL' uri'
+#if defined(CURL)
+  dl _ = do
+    let exe = [rel|curl|]
+        args = ["-sSfL", serializeURIRef' uri']
+    liftIO (executeOut exe args Nothing) >>= \case
+      CapturedProcess ExitSuccess stdout _ -> do
+        pure $ L.fromStrict stdout
+      CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
+#else
+  dl https = do
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ downloadBS' https host' fullPath' port'
+#endif
+
+
+checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader Settings m)
+            => DownloadInfo
+            -> Path Abs
             -> Excepts '[DigestError] m ()
-checkDigest eDigest file = do
-  Settings{ noVerify } <- lift getSettings
-  let verify = not noVerify
+checkDigest dli file = do
+  verify <- lift ask <&> (not . noVerify)
   when verify $ do
-    let p' = takeFileName file
-    lift $ logInfo $ "verifying digest of: " <> T.pack p'
-    c <- liftIO $ L.readFile file
+    p' <- toFilePath <$> basename file
+    lift $ $(logInfo) [i|verifying digest of: #{p'}|]
+    c <- liftIO $ readFile file
     cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
-    when ((cDigest /= eDigest) && verify) $ throwE (DigestError file cDigest eDigest)
+    let eDigest = view dlHash dli
+    when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
 
-
--- | Get additional curl args from env. This is an undocumented option.
-getCurlOpts :: IO [String]
-getCurlOpts =
-  lookupEnv "GHCUP_CURL_OPTS" >>= \case
-    Just r  -> pure $ splitOn " " r
-    Nothing -> pure []
-
-
--- | Get additional wget args from env. This is an undocumented option.
-getWgetOpts :: IO [String]
-getWgetOpts =
-  lookupEnv "GHCUP_WGET_OPTS" >>= \case
-    Just r  -> pure $ splitOn " " r
-    Nothing -> pure []
-
--- | Get additional gpg args from env. This is an undocumented option.
-getGpgOpts :: IO [String]
-getGpgOpts =
-  lookupEnv "GHCUP_GPG_OPTS" >>= \case
-    Just r  -> pure $ splitOn " " r
-    Nothing -> pure []
-
--- | Get the url base name.
---
--- >>> urlBaseName "/foo/bar/baz"
--- "baz"
-urlBaseName :: ByteString  -- ^ the url path (without scheme and host)
-            -> ByteString
-urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
-
-
--- | Curl saves all intermediate connect headers as well, not just the last one, so we make an effort to take the
--- last HTTP block only. Passing '--suppress-connect-headers' would be better, but it isn't supported by all versions,
--- also see:
---   https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/213
---
--- >>> getLastHeader "\n\nHTTP/1.0 200 Connection established\n\nHTTP/1.1 304 Not Modified\n"
--- "HTTP/1.1 304 Not Modified\n"
--- >>> getLastHeader "HTTP/1.1 304 Not Modified\n"
--- "HTTP/1.1 304 Not Modified\n"
-getLastHeader :: T.Text -> T.Text
-getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [""] . fmap T.stripEnd . T.lines
-
-
-tmpFile :: FilePath -> FilePath
-tmpFile = (<.> "tmp")

lib/GHCup/Download/IOStreams.hs

@@ -1,6 +1,10 @@
 {-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 
 
@@ -9,7 +13,9 @@ module GHCup.Download.IOStreams where
 
 import           GHCup.Download.Utils
 import           GHCup.Errors
+import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.File
 import           GHCup.Utils.Prelude
 
 import           Control.Applicative
@@ -18,10 +24,12 @@ import           Control.Monad
 import           Control.Monad.Reader
 import           Data.ByteString                ( ByteString )
 import           Data.ByteString.Builder
-import           Data.CaseInsensitive           ( CI, original, mk )
+import           Data.CaseInsensitive           ( CI )
 import           Data.IORef
 import           Data.Maybe
 import           Data.Text.Read
+import           HPath
+import           HPath.IO                      as HIO
 import           Haskus.Utils.Variant.Excepts
 import           Network.Http.Client     hiding ( URL )
 import           Optics
@@ -29,6 +37,10 @@ import           Prelude                 hiding ( abs
                                                 , readFile
                                                 , writeFile
                                                 )
+import "unix"    System.Posix.IO.ByteString
+                                         hiding ( fdWrite )
+import "unix-bytestring" System.Posix.IO.ByteString
+                                                ( fdWrite )
 import           System.ProgressBar
 import           URI.ByteString
 
@@ -60,11 +72,11 @@ downloadBS' :: MonadIO m
                   , TooManyRedirs
                   ]
                  m
-                 L.ByteString
+                 (L.ByteString)
 downloadBS' https host path port = do
   bref <- liftIO $ newIORef (mempty :: Builder)
   let stepper bs = modifyIORef bref (<> byteString bs)
-  void $ downloadInternal False https host path port stepper (pure ()) mempty
+  downloadInternal False https host path port stepper
   liftIO (readIORef bref <&> toLazyByteString)
 
 
@@ -73,18 +85,13 @@ downloadToFile :: (MonadMask m, MonadIO m)
                -> ByteString       -- ^ host (e.g. "www.example.com")
                -> ByteString       -- ^ path (e.g. "/my/file") including query
                -> Maybe Int        -- ^ optional port (e.g. 3000)
-               -> FilePath         -- ^ destination file to create and write to
-               -> M.Map (CI ByteString) ByteString -- ^ additional headers
-               -> Excepts '[DownloadFailed, HTTPNotModified] m Response
-downloadToFile https host fullPath port destFile addHeaders = do
-  let stepper = BS.appendFile destFile
-      setup = BS.writeFile destFile mempty
-  catchAllE (\case
-              (V (HTTPStatusError i headers))
-                | i == 304
-                , Just e <- M.lookup (mk "etag") headers -> throwE $ HTTPNotModified (decUTF8Safe e)
-              v -> throwE $ DownloadFailed v
-            ) $ downloadInternal True https host fullPath port stepper setup addHeaders
+               -> Path Abs         -- ^ destination file to create and write to
+               -> Excepts '[DownloadFailed] m ()
+downloadToFile https host fullPath port destFile = do
+  fd <- liftIO $ createRegularFileFd newFilePerms destFile
+  let stepper = fdWrite fd
+  flip finally (liftIO $ closeFd fd)
+    $ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
 
 
 downloadInternal :: MonadIO m
@@ -94,8 +101,6 @@ downloadInternal :: MonadIO m
                  -> ByteString  -- ^ path with query
                  -> Maybe Int   -- ^ optional port
                  -> (ByteString -> IO a)   -- ^ the consuming step function
-                 -> IO a                   -- ^ setup action
-                 -> M.Map (CI ByteString) ByteString -- ^ additional headers
                  -> Excepts
                       '[ HTTPStatusError
                        , URIParseError
@@ -104,21 +109,19 @@ downloadInternal :: MonadIO m
                        , TooManyRedirs
                        ]
                       m
-                      Response
+                      ()
 downloadInternal = go (5 :: Int)
 
  where
-  go redirs progressBar https host path port consumer setup addHeaders = do
+  go redirs progressBar https host path port consumer = do
     r <- liftIO $ withConnection' https host port action
     veitherToExcepts r >>= \case
-      Right r' ->
+      Just r' ->
         if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
-      Left res -> pure res
+      Nothing -> pure ()
    where
     action c = do
-      let q = buildRequest1 $ do
-                http GET path
-                flip M.traverseWithKey addHeaders $ \key val -> setHeader (original key) val
+      let q = buildRequest1 $ http GET path
 
       sendRequest c q emptyBody
 
@@ -127,30 +130,28 @@ downloadInternal = go (5 :: Int)
         (\r i' -> runE $ do
           let scode = getStatusCode r
           if
-            | scode >= 200 && scode < 300 -> liftIO $ downloadStream r i' >> pure (Left r)
-            | scode == 304 -> throwE $ HTTPStatusError scode (getHeaderMap r)
+            | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
             | scode >= 300 && scode < 400 -> case getHeader r "Location" of
-              Just r' -> pure $ Right r'
+              Just r' -> pure $ Just $ r'
               Nothing -> throwE NoLocationHeader
-            | otherwise -> throwE $ HTTPStatusError scode (getHeaderMap r)
+            | otherwise -> throwE $ HTTPStatusError scode
         )
 
     followRedirectURL bs = case parseURI strictURIParserOptions bs of
       Right uri' -> do
         (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
-        go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer
       Left e -> throwE e
 
     downloadStream r i' = do
-      void setup
       let size = case getHeader r "Content-Length" of
             Just x' -> case decimal $ decUTF8Safe x' of
               Left  _       -> 0
               Right (r', _) -> r'
             Nothing -> 0
 
-      (mpb :: Maybe (ProgressBar ())) <- if progressBar
-        then Just <$> newProgressBar defStyle 10 (Progress 0 size ())
+      mpb <- if progressBar
+        then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
         else pure Nothing
 
       outStream <- liftIO $ Streams.makeOutputStream
@@ -163,13 +164,86 @@ downloadInternal = go (5 :: Int)
       liftIO $ Streams.connect i' outStream
 
 
+getHead :: (MonadCatch m, MonadIO m)
+        => URI
+        -> Excepts
+             '[ HTTPStatusError
+              , URIParseError
+              , UnsupportedScheme
+              , NoLocationHeader
+              , TooManyRedirs
+              , ProcessError
+              ]
+             m
+             (M.Map (CI ByteString) ByteString)
+getHead uri' | scheme == "https" = head' True
+             | scheme == "http"  = head' False
+             | otherwise         = throwE UnsupportedScheme
+
+ where
+  scheme = view (uriSchemeL' % schemeBSL') uri'
+  head' https = do
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ headInternal https host' fullPath' port'
+
+
+headInternal :: MonadIO m
+             => Bool        -- ^ https?
+             -> ByteString  -- ^ host
+             -> ByteString  -- ^ path with query
+             -> Maybe Int   -- ^ optional port
+             -> Excepts
+                  '[ HTTPStatusError
+                   , URIParseError
+                   , UnsupportedScheme
+                   , TooManyRedirs
+                   , NoLocationHeader
+                   ]
+                  m
+                  (M.Map (CI ByteString) ByteString)
+headInternal = go (5 :: Int)
+
+ where
+  go redirs https host path port = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Left r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Right hs -> pure hs
+   where
+
+    action c = do
+      let q = buildRequest1 $ http HEAD path
+
+      sendRequest c q emptyBody
+
+      unsafeReceiveResponse
+        c
+        (\r _ -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> do
+              let headers = getHeaderMap r
+              pure $ Right $ headers
+            | scode >= 300 && scode < 400 -> case getHeader r "Location" of
+              Just r' -> pure $ Left $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) https' host' fullPath' port'
+      Left e -> throwE e
+
 
 withConnection' :: Bool
                 -> ByteString
                 -> Maybe Int
                 -> (Connection -> IO a)
                 -> IO a
-withConnection' https host port = bracket acquire closeConnection
+withConnection' https host port action = bracket acquire closeConnection action
 
  where
   acquire = case https of

lib/GHCup/Download/Utils.hs

@@ -1,6 +1,10 @@
 {-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
 {-# LANGUAGE TypeFamilies          #-}
 
 
@@ -51,7 +55,7 @@ uriToQuadruple URI {..} = do
   let queryBS =
         BS.intercalate "&"
           . fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
-          $ queryPairs uriQuery
+          $ (queryPairs uriQuery)
       port =
         preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
       fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS

lib/GHCup/Errors.hs

@@ -1,38 +1,18 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE DataKinds               #-}
 {-# LANGUAGE ExistentialQuantification #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeOperators           #-}
-{-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE DataKinds #-}
 
-{-|
-Module      : GHCup.Errors
-Description : GHCup error types
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
 module GHCup.Errors where
 
 import           GHCup.Types
 
-import           Codec.Archive
 import           Control.Exception.Safe
 import           Data.ByteString                ( ByteString )
-import           Data.CaseInsensitive           ( CI )
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           Haskus.Utils.Variant
-import           Text.PrettyPrint               hiding ( (<>) )
-import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
-import           URI.ByteString
-
-import qualified Data.Map.Strict               as M
-import qualified Data.Text                     as T
+import           HPath
 
 
 
@@ -46,286 +26,103 @@ import qualified Data.Text                     as T
 data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
   deriving Show
 
-instance Pretty NoCompatiblePlatform where
-  pPrint (NoCompatiblePlatform str') =
-    text ("Could not find a compatible platform. Got: " ++ str')
-
--- | Unable to find a download for the requested version/distro.
+-- | Unable to find a download for the requested versio/distro.
 data NoDownload = NoDownload
   deriving Show
 
-instance Pretty NoDownload where
-  pPrint NoDownload =
-    text "Unable to find a download for the requested version/distro."
-
 -- | No update available or necessary.
 data NoUpdate = NoUpdate
   deriving Show
 
-instance Pretty NoUpdate where
-  pPrint NoUpdate = text "No update available or necessary."
-
 -- | The Architecture is unknown and unsupported.
 data NoCompatibleArch = NoCompatibleArch String
   deriving Show
 
-instance Pretty NoCompatibleArch where
-  pPrint (NoCompatibleArch arch) =
-    text ("The Architecture is unknown or unsupported. Got: " ++ arch)
-
 -- | Unable to figure out the distribution of the host.
 data DistroNotFound = DistroNotFound
   deriving Show
 
-instance Pretty DistroNotFound where
-  pPrint DistroNotFound =
-    text "Unable to figure out the distribution of the host."
-
 -- | The archive format is unknown. We don't know how to extract it.
-data UnknownArchive = UnknownArchive FilePath
+data UnknownArchive = UnknownArchive ByteString
   deriving Show
 
-instance Pretty UnknownArchive where
-  pPrint (UnknownArchive file) =
-    text $ "The archive format is unknown. We don't know how to extract the file " <> file
-
 -- | The scheme is not supported (such as ftp).
 data UnsupportedScheme = UnsupportedScheme
   deriving Show
 
-instance Pretty UnsupportedScheme where
-  pPrint UnsupportedScheme = text "The scheme is not supported (such as ftp)."
-
 -- | Unable to copy a file.
 data CopyError = CopyError String
   deriving Show
 
-instance Pretty CopyError where
-  pPrint (CopyError reason) =
-    text ("Unable to copy a file. Reason was: " ++ reason)
-
 -- | Unable to find a tag of a tool.
 data TagNotFound = TagNotFound Tag Tool
   deriving Show
 
-instance Pretty TagNotFound where
-  pPrint (TagNotFound tag tool) =
-    text "Unable to find tag" <+> pPrint tag <+> text "of tool" <+> pPrint tool
-
--- | Unable to find the next version of a tool (the one after the currently
--- set one).
-data NextVerNotFound = NextVerNotFound Tool
-  deriving Show
-
-instance Pretty NextVerNotFound where
-  pPrint (NextVerNotFound tool) =
-    text "Unable to find next (the one after the currently set one) version of tool" <+> pPrint tool
-
 -- | The tool (such as GHC) is already installed with that version.
 data AlreadyInstalled = AlreadyInstalled Tool Version
   deriving Show
 
-instance Pretty AlreadyInstalled where
-  pPrint (AlreadyInstalled tool ver') =
-    pPrint tool <+> text "-" <+> pPrint ver' <+> text "is already installed"
-
--- | The Directory is supposed to be empty, but wasn't.
-data DirNotEmpty = DirNotEmpty {path :: FilePath}
-
-instance Pretty DirNotEmpty where
-  pPrint (DirNotEmpty path) = do
-    text $ "The directory was expected to be empty, but isn't: " <> path
-
 -- | The tool is not installed. Some operations rely on a tool
 -- to be installed (such as setting the current GHC version).
-data NotInstalled = NotInstalled Tool GHCTargetVersion
+data NotInstalled = NotInstalled Tool Version
   deriving Show
 
-instance Pretty NotInstalled where
-  pPrint (NotInstalled tool ver) =
-    text "The version" <+> pPrint ver <+> text "of the tool" <+> pPrint tool <+> text "is not installed."
-
 -- | An executable was expected to be in PATH, but was not found.
-data NotFoundInPATH = NotFoundInPATH FilePath
+data NotFoundInPATH = NotFoundInPATH (Path Rel)
   deriving Show
 
-instance Pretty NotFoundInPATH where
-  pPrint (NotFoundInPATH exe) =
-    text $ "The exe " <> exe <> " was not found in PATH."
-
 -- | JSON decoding failed.
 data JSONError = JSONDecodeError String
   deriving Show
 
-instance Pretty JSONError where
-  pPrint (JSONDecodeError err) =
-    text $ "JSON decoding failed with: " <> err
-
 -- | A file that is supposed to exist does not exist
 -- (e.g. when we use file scheme to "download" something).
-data FileDoesNotExistError = FileDoesNotExistError FilePath
+data FileDoesNotExistError = FileDoesNotExistError ByteString
   deriving Show
 
-instance Pretty FileDoesNotExistError where
-  pPrint (FileDoesNotExistError file) =
-    text $ "File " <> file <> " does not exist."
-
--- | The file already exists
--- (e.g. when we use isolated installs with the same path).
--- (e.g. This is done to prevent any overwriting)
-data FileAlreadyExistsError = FileAlreadyExistsError FilePath
-  deriving Show
-
-instance Pretty FileAlreadyExistsError where
-  pPrint (FileAlreadyExistsError file) =
-    text $ "File " <> file <> " Already exists."
-
-data TarDirDoesNotExist = TarDirDoesNotExist TarDir
-  deriving Show
-
-instance Pretty TarDirDoesNotExist where
-  pPrint (TarDirDoesNotExist dir) =
-    text "Tar directory does not exist:" <+> pPrint dir
-
 -- | File digest verification failed.
-data DigestError = DigestError FilePath Text Text
+data DigestError = DigestError Text Text
   deriving Show
 
-instance Pretty DigestError where
-  pPrint (DigestError fp currentDigest expectedDigest) =
-    text "Digest error for" <+> text (fp <> ": expected")
-      <+> text (T.unpack expectedDigest) <+> text "but got" <+> pPrint currentDigest <+> text
-      "\nConsider removing the file in case it's cached and try again."
-
--- | File digest verification failed.
-data GPGError = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => GPGError (V xs)
-
-deriving instance Show GPGError
-
-instance Pretty GPGError where
-  pPrint (GPGError reason) = text "GPG verify failed:" <+> pPrint reason
-
 -- | Unexpected HTTP status.
-data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
+data HTTPStatusError = HTTPStatusError Int
   deriving Show
 
-instance Pretty HTTPStatusError where
-  pPrint (HTTPStatusError status _) =
-    text "Unexpected HTTP status:" <+> pPrint status
-
--- | Malformed headers.
-data MalformedHeaders = MalformedHeaders Text
-  deriving Show
-
-instance Pretty MalformedHeaders where
-  pPrint (MalformedHeaders h) =
-    text "Headers are malformed: " <+> pPrint h
-
--- | Unexpected HTTP status.
-data HTTPNotModified = HTTPNotModified Text
-  deriving Show
-
-instance Pretty HTTPNotModified where
-  pPrint (HTTPNotModified etag) =
-    text "Remote resource not modifed, etag was:" <+> pPrint etag
-
 -- | The 'Location' header was expected during a 3xx redirect, but not found.
 data NoLocationHeader = NoLocationHeader
   deriving Show
 
-instance Pretty NoLocationHeader where
-  pPrint NoLocationHeader =
-    text "The 'Location' header was expected during a 3xx redirect, but not found."
-
 -- | Too many redirects.
 data TooManyRedirs = TooManyRedirs
   deriving Show
 
-instance Pretty TooManyRedirs where
-  pPrint TooManyRedirs =
-    text "Too many redirections."
-
 -- | A patch could not be applied.
 data PatchFailed = PatchFailed
   deriving Show
 
-instance Pretty PatchFailed where
-  pPrint PatchFailed =
-    text "A patch could not be applied."
-
 -- | The tool requirements could not be found.
 data NoToolRequirements = NoToolRequirements
   deriving Show
 
-instance Pretty NoToolRequirements where
-  pPrint NoToolRequirements =
-    text "The Tool requirements could not be found."
-
-data InvalidBuildConfig = InvalidBuildConfig Text
-  deriving Show
-
-instance Pretty InvalidBuildConfig where
-  pPrint (InvalidBuildConfig reason) =
-    text "The build config is invalid. Reason was:" <+> pPrint reason
-
-data NoToolVersionSet = NoToolVersionSet Tool
-  deriving Show
-
-instance Pretty NoToolVersionSet where
-  pPrint (NoToolVersionSet tool) =
-    text "No version is set for tool" <+> pPrint tool <+> text "."
-
-data NoNetwork = NoNetwork
-  deriving Show
-
-instance Pretty NoNetwork where
-  pPrint NoNetwork =
-    text "A download was required or requested, but '--offline' was specified."
-
-data HadrianNotFound = HadrianNotFound
-  deriving Show
-
-instance Pretty HadrianNotFound where
-  pPrint HadrianNotFound =
-    text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
-
 
     -------------------------
     --[ High-level errors ]--
     -------------------------
 
 -- | A download failed. The underlying error is encapsulated.
-data DownloadFailed = forall xs . (ToVariantMaybe DownloadFailed xs, PopVariant DownloadFailed xs, Show (V xs), Pretty (V xs)) => DownloadFailed (V xs)
-
-instance Pretty DownloadFailed where
-  pPrint (DownloadFailed reason) =
-    case reason of
-      VMaybe (_ :: DownloadFailed) -> pPrint reason
-      _ -> text "Download failed:" <+> pPrint reason
+data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es)
 
 deriving instance Show DownloadFailed
 
 
 -- | A build failed.
-data BuildFailed = forall es . (ToVariantMaybe BuildFailed es, PopVariant BuildFailed es, Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
-
-instance Pretty BuildFailed where
-  pPrint (BuildFailed path reason) =
-    case reason of
-      VMaybe (_ :: BuildFailed) -> pPrint reason
-      _ -> text "BuildFailed failed in dir" <+> text (path <> ":") <+> pPrint reason
+data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
 
 deriving instance Show BuildFailed
 
 
 -- | Setting the current GHC version failed.
-data GHCupSetError = forall es . (ToVariantMaybe GHCupSetError es, PopVariant GHCupSetError es, Show (V es), Pretty (V es)) => GHCupSetError (V es)
-
-instance Pretty GHCupSetError where
-  pPrint (GHCupSetError reason) =
-    case reason of
-      VMaybe (_ :: GHCupSetError) -> pPrint reason
-      _ -> text "Setting the current GHC version failed:" <+> pPrint reason
+data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
 
 deriving instance Show GHCupSetError
 
@@ -339,75 +136,4 @@ deriving instance Show GHCupSetError
 data ParseError = ParseError String
   deriving Show
 
-instance Pretty ParseError where
-  pPrint (ParseError reason) =
-    text "Parsing failed:" <+> pPrint reason
-
 instance Exception ParseError
-
-
-data UnexpectedListLength = UnexpectedListLength String
-  deriving Show
-
-instance Pretty UnexpectedListLength where
-  pPrint (UnexpectedListLength reason) =
-    text "List length unexpected:" <+> pPrint reason
-
-instance Exception UnexpectedListLength
-
-data NoUrlBase = NoUrlBase Text
-  deriving Show
-
-instance Pretty NoUrlBase where
-  pPrint (NoUrlBase url) =
-    text "Couldn't get a base filename from url" <+> pPrint url
-
-instance Exception NoUrlBase
-
-
-
-    ------------------------
-    --[ orphan instances ]--
-    ------------------------
-
-instance Pretty (V '[]) where
-   {-# INLINABLE pPrint #-}
-   pPrint _ = undefined
-
-instance
-   ( Pretty x
-   , Pretty (V xs)
-   ) => Pretty (V (x ': xs))
-   where
-      pPrint v = case popVariantHead v of
-         Right x -> pPrint x
-         Left xs -> pPrint xs
-
-instance Pretty URIParseError where
-  pPrint (MalformedScheme reason) =
-    text "Failed to parse URI. Malformed scheme:" <+> text (show reason)
-  pPrint MalformedUserInfo =
-    text "Failed to parse URI. Malformed user info."
-  pPrint MalformedQuery =
-    text "Failed to parse URI. Malformed query."
-  pPrint MalformedFragment =
-    text "Failed to parse URI. Malformed fragment."
-  pPrint MalformedHost =
-    text "Failed to parse URI. Malformed host."
-  pPrint MalformedPort =
-    text "Failed to parse URI. Malformed port."
-  pPrint MalformedPath =
-    text "Failed to parse URI. Malformed path."
-  pPrint (OtherError err) =
-    text "Failed to parse URI:" <+> pPrint err
-
-instance Pretty ArchiveResult where
-  pPrint ArchiveFatal = text "Archive result: fatal"
-  pPrint ArchiveFailed = text "Archive result: failed"
-  pPrint ArchiveWarn = text "Archive result: warning"
-  pPrint ArchiveRetry = text "Archive result: retry"
-  pPrint ArchiveOk = text "Archive result: Ok"
-  pPrint ArchiveEOF = text "Archive result: EOF"
-
-instance Pretty T.Text where
-  pPrint = text . T.unpack

lib/GHCup/Platform.hs

@@ -6,51 +6,39 @@
 {-# LANGUAGE TemplateHaskell       #-}
 
 
-{-|
-Module      : GHCup.Plaform
-Description : Retrieving platform information
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
 module GHCup.Platform where
 
 
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Bash
 import           GHCup.Utils.File
-import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 import           GHCup.Utils.String.QQ
 
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
+import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Data.ByteString                ( ByteString )
 import           Data.Foldable
 import           Data.Maybe
+import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Versions
+import           HPath
+import           HPath.IO
 import           Haskus.Utils.Variant.Excepts
 import           Prelude                 hiding ( abs
                                                 , readFile
                                                 , writeFile
                                                 )
 import           System.Info
-import           System.Directory
-import           System.OsRelease
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix
 
 import qualified Data.Text                     as T
-import qualified Data.Text.IO                  as T
-
-
 
     --------------------------
     --[ Platform detection ]--
@@ -58,9 +46,12 @@ import qualified Data.Text.IO                  as T
 
 
 -- | Get the full platform request, consisting of architecture, distro, ...
-platformRequest :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
+platformRequest :: (MonadLogger m, MonadCatch m, MonadIO m)
                 => Excepts
-                     '[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
+                     '[ NoCompatiblePlatform
+                      , NoCompatibleArch
+                      , DistroNotFound
+                      ]
                      m
                      PlatformRequest
 platformRequest = do
@@ -71,21 +62,15 @@ platformRequest = do
 
 getArchitecture :: Either NoCompatibleArch Architecture
 getArchitecture = case arch of
-  "x86_64"      -> Right A_64
-  "i386"        -> Right A_32
-  "powerpc"     -> Right A_PowerPC
-  "powerpc64"   -> Right A_PowerPC64
-  "powerpc64le" -> Right A_PowerPC64
-  "sparc"       -> Right A_Sparc
-  "sparc64"     -> Right A_Sparc64
-  "arm"         -> Right A_ARM
-  "aarch64"     -> Right A_ARM64
-  what          -> Left (NoCompatibleArch what)
+  "x86_64" -> Right A_64
+  "i386"   -> Right A_32
+  what     -> Left (NoCompatibleArch what)
 
 
-getPlatform :: (Alternative m, MonadReader env m, HasLog env, MonadCatch m, MonadIO m, MonadFail m)
+
+getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
             => Excepts
-                 '[NoCompatiblePlatform, DistroNotFound]
+                 '[NoCompatiblePlatform , DistroNotFound]
                  m
                  PlatformResult
 getPlatform = do
@@ -95,37 +80,40 @@ getPlatform = do
       pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
     "darwin" -> do
       ver <-
-        either (const Nothing) Just
+        ( either (const Nothing) Just
           . versioning
-          -- TODO: maybe do this somewhere else
-          . decUTF8Safe'
-        <$> getDarwinVersion
+          . getMajorVersion
+          . decUTF8Safe
+          )
+          <$> getDarwinVersion
       pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
     "freebsd" -> do
       ver <-
-        either (const Nothing) Just . versioning . decUTF8Safe'
+        (either (const Nothing) Just . versioning . decUTF8Safe)
           <$> getFreeBSDVersion
       pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
-    "mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
     what -> throwE $ NoCompatiblePlatform what
-  lift $ logDebug $ "Identified Platform as: " <> T.pack (prettyShow pfr)
+  lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
   pure pfr
  where
-  getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
-  getDarwinVersion = lift $ fmap _stdOut $ executeOut "sw_vers"
+  getMajorVersion = T.intercalate "." . take 2 . T.split (== '.')
+  getFreeBSDVersion =
+    liftIO $ fmap _stdOut $ executeOut [rel|freebsd-version|] [] Nothing
+  getDarwinVersion = liftIO $ fmap _stdOut $ executeOut [rel|sw_vers|]
                                                         ["-productVersion"]
                                                         Nothing
 
 
-getLinuxDistro :: (Alternative m, MonadCatch m, MonadIO m, MonadFail m)
+getLinuxDistro :: (MonadCatch m, MonadIO m)
                => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
 getLinuxDistro = do
   -- TODO: don't do alternative on IO, because it hides bugs
-  (name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ lift $ asum
-    [ liftIO try_os_release
+  (name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
+    [ try_os_release
     , try_lsb_release_cmd
-    , liftIO try_redhat_release
-    , liftIO try_debian_version
+    , try_lsb_release
+    , try_redhat_release
+    , try_debian_version
     ]
   let parsedVer = ver >>= either (const Nothing) Just . versioning
       distro    = if
@@ -142,38 +130,49 @@ getLinuxDistro = do
         | otherwise                -> UnknownLinux
   pure (distro, parsedVer)
  where
-  hasWord t = any (\x -> match (regex x) (T.unpack t))
+  hasWord t matches = foldr (\x y -> match (regex x) (T.unpack t) || y)
+                            False
+                            matches
    where
     regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
 
-  lsb_release_cmd :: FilePath
-  lsb_release_cmd = "lsb-release"
-  redhat_release :: FilePath
-  redhat_release = "/etc/redhat-release"
-  debian_version :: FilePath
-  debian_version = "/etc/debian_version"
+  os_release :: Path Abs
+  os_release = [abs|/etc/os-release|]
+  lsb_release :: Path Abs
+  lsb_release = [abs|/etc/lsb-release|]
+  lsb_release_cmd :: Path Rel
+  lsb_release_cmd = [rel|lsb-release|]
+  redhat_release :: Path Abs
+  redhat_release = [abs|/etc/redhat-release|]
+  debian_version :: Path Abs
+  debian_version = [abs|/etc/debian_version|]
 
   try_os_release :: IO (Text, Maybe Text)
   try_os_release = do
-    Just OsRelease{ name = name, version_id = version_id } <-
-      fmap osRelease <$> parseOsRelease
-    pure (T.pack name, fmap T.pack version_id)
+    (Just name) <- getAssignmentValueFor os_release "NAME"
+    ver         <- getAssignmentValueFor os_release "VERSION_ID"
+    pure (T.pack name, fmap T.pack ver)
 
-  try_lsb_release_cmd :: (MonadFail m, MonadIO m)
-                      => m (Text, Maybe Text)
+  try_lsb_release_cmd :: IO (Text, Maybe Text)
   try_lsb_release_cmd = do
-    (Just _) <- liftIO $ findExecutable lsb_release_cmd
+    (Just _) <- findExecutable lsb_release_cmd
     name     <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
     ver      <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
-    pure (decUTF8Safe' name, Just $ decUTF8Safe' ver)
+    pure (decUTF8Safe name, Just $ decUTF8Safe ver)
+
+  try_lsb_release :: IO (Text, Maybe Text)
+  try_lsb_release = do
+    (Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
+    ver         <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
+    pure (T.pack name, fmap T.pack ver)
 
   try_redhat_release :: IO (Text, Maybe Text)
   try_redhat_release = do
-    t <- T.readFile redhat_release
+    t <- fmap decUTF8Safe' $ readFile redhat_release
     let nameRegex n =
           makeRegexOpts compIgnoreCase
                         execBlank
-                        ([s|\<|] <> fS n <> [s|\>|] :: ByteString) :: Regex
+                        (([s|\<|] <> fS n <> [s|\>|] :: ByteString)) :: Regex
     let verRegex =
           makeRegexOpts compIgnoreCase
                         execBlank
@@ -191,5 +190,5 @@ getLinuxDistro = do
 
   try_debian_version :: IO (Text, Maybe Text)
   try_debian_version = do
-    ver <- T.readFile debian_version
-    pure (T.pack "debian", Just ver)
+    ver <- readFile debian_version
+    pure (T.pack "debian", Just . decUTF8Safe' $ ver)

lib/GHCup/Requirements.hs

@@ -1,23 +1,12 @@
 {-# LANGUAGE OverloadedStrings #-}
 
-{-|
-Module      : GHCup.Requirements
-Description : Requirements utilities
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
 module GHCup.Requirements where
 
 import           GHCup.Types
 import           GHCup.Types.JSON               ( )
 import           GHCup.Types.Optics
-import           GHCup.Version
 
 import           Control.Applicative
-import           Data.List                      ( find )
 import           Data.Maybe
 import           Optics
 import           Prelude                 hiding ( abs
@@ -25,7 +14,6 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 
-import qualified Data.Map.Strict               as M
 import qualified Data.Text                     as T
 
 
@@ -36,34 +24,23 @@ getCommonRequirements :: PlatformResult
                       -> ToolRequirements
                       -> Maybe Requirements
 getCommonRequirements pr tr =
-  with_distro <|> without_distro_ver <|> without_distro
- where
-  with_distro        = distro_preview _platform _distroVersion
-  without_distro_ver = distro_preview _platform (const Nothing)
-  without_distro     = distro_preview (set _Linux UnknownLinux . _platform) (const Nothing)
-
-  distro_preview f g =
-    let platformVersionSpec =
-          preview (ix GHC % ix Nothing % ix (f pr)) tr
-        mv' = g pr
-    in  fmap snd
-          .   find
-                (\(mverRange, _) -> maybe
-                  (isNothing mv')
-                  (\range -> maybe False (`versionRange` range) mv')
-                  mverRange
-                )
-          .   M.toList
-          =<< platformVersionSpec
+  preview (ix GHC % ix Nothing % ix (_platform pr) % ix (_distroVersion pr)) tr
+    <|> preview (ix GHC % ix Nothing % ix (_platform pr) % ix Nothing) tr
+    <|> preview
+          ( ix GHC
+          % ix Nothing
+          % ix (set _Linux UnknownLinux $ _platform pr)
+          % ix Nothing
+          )
+          tr
 
 
 prettyRequirements :: Requirements -> T.Text
 prettyRequirements Requirements {..} =
   let d = if not . null $ _distroPKGs
-        then "\n  Please ensure the following distro packages "
-          <> "are installed before continuing (you can exit ghcup "
-          <> "and return at any time): "
-          <> T.intercalate " " _distroPKGs
+        then
+          "\n  Install the following distro packages: "
+            <> T.intercalate " " _distroPKGs
         else ""
       n = if not . T.null $ _notes then "\n  Note: " <> _notes else ""
   in  "System requirements " <> d <> n

lib/GHCup/Types.hs

@@ -1,54 +1,16 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE CPP               #-}
-{-# LANGUAGE BangPatterns      #-}
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE DeriveGeneric     #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE DeriveGeneric #-}
 
-{-|
-Module      : GHCup.Types
-Description : GHCup types
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
-module GHCup.Types
-  ( module GHCup.Types
-#if defined(BRICK)
-  , Key(..)
-#endif
-  )
-  where
+module GHCup.Types where
 
-import           Control.DeepSeq                ( NFData, rnf )
 import           Data.Map.Strict                ( Map )
-import           Data.List.NonEmpty             ( NonEmpty (..) )
 import           Data.Text                      ( Text )
 import           Data.Versions
-import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
+import           HPath
 import           URI.ByteString
-#if defined(BRICK)
-import           Graphics.Vty                   ( Key(..) )
-#endif
 
-import qualified Data.Text                     as T
 import qualified GHC.Generics                  as GHC
 
 
-#if !defined(BRICK)
-data Key = KEsc  | KChar Char | KBS | KEnter
-         | KLeft | KRight | KUp | KDown
-         | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
-         | KFun Int | KBackTab | KPrtScr | KPause | KIns
-         | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
-    deriving (Eq,Show,Read,Ord,GHC.Generic)
-#endif
-
 
     --------------------
     --[ GHCInfo Tree ]--
@@ -58,12 +20,9 @@ data Key = KEsc  | KChar Char | KBS | KEnter
 data GHCupInfo = GHCupInfo
   { _toolRequirements :: ToolRequirements
   , _ghcupDownloads   :: GHCupDownloads
-  , _globalTools      :: Map GlobalTool DownloadInfo
   }
   deriving (Show, GHC.Generic)
 
-instance NFData GHCupInfo
-
 
 
     -------------------------
@@ -74,7 +33,7 @@ instance NFData GHCupInfo
 type ToolRequirements = Map Tool ToolReqVersionSpec
 type ToolReqVersionSpec = Map (Maybe Version) PlatformReqSpec
 type PlatformReqSpec = Map Platform PlatformReqVersionSpec
-type PlatformReqVersionSpec = Map (Maybe VersionRange) Requirements
+type PlatformReqVersionSpec = Map (Maybe Versioning) Requirements
 
 
 data Requirements = Requirements
@@ -83,8 +42,6 @@ data Requirements = Requirements
   }
   deriving (Show, GHC.Generic)
 
-instance NFData Requirements
-
 
 
 
@@ -100,121 +57,45 @@ type GHCupDownloads = Map Tool ToolVersionSpec
 type ToolVersionSpec = Map Version VersionInfo
 type ArchitectureSpec = Map Architecture PlatformSpec
 type PlatformSpec = Map Platform PlatformVersionSpec
-type PlatformVersionSpec = Map (Maybe VersionRange) DownloadInfo
+type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
 
 
 -- | An installable tool.
 data Tool = GHC
           | Cabal
           | GHCup
-          | HLS
-          | Stack
-  deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
-
-instance Pretty Tool where
-  pPrint GHC = text "ghc"
-  pPrint Cabal = text "cabal"
-  pPrint GHCup = text "ghcup"
-  pPrint HLS = text "hls"
-  pPrint Stack = text "stack"
-
-instance NFData Tool
-
-data GlobalTool = ShimGen
-  deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
-
-instance NFData GlobalTool
+  deriving (Eq, GHC.Generic, Ord, Show)
 
 
 -- | All necessary information of a tool version, including
 -- source download and per-architecture downloads.
 data VersionInfo = VersionInfo
-  { _viTags        :: [Tag]              -- ^ version specific tag
-  , _viChangeLog   :: Maybe URI
-  , _viSourceDL    :: Maybe DownloadInfo -- ^ source tarball
-  , _viArch        :: ArchitectureSpec   -- ^ descend for binary downloads per arch
-  -- informative messages
-  , _viPostInstall :: Maybe Text
-  , _viPostRemove  :: Maybe Text
-  , _viPreCompile  :: Maybe Text
+  { _viTags      :: [Tag]              -- ^ version specific tag
+  , _viChangeLog :: Maybe URI
+  , _viSourceDL  :: Maybe DownloadInfo -- ^ source tarball
+  , _viArch      :: ArchitectureSpec   -- ^ descend for binary downloads per arch
   }
-  deriving (Eq, GHC.Generic, Show)
-
-instance NFData VersionInfo
+  deriving (Eq, Show)
 
 
 -- | A tag. These are currently attached to a version of a tool.
 data Tag = Latest
          | Recommended
-         | Prerelease
-         | Base PVP
-         | Old                -- ^ old versions are hidden by default in TUI
-         | UnknownTag String  -- ^ used for upwardscompat
-         deriving (Ord, Eq, GHC.Generic, Show) -- FIXME: manual JSON instance
+         deriving (Ord, Eq, Show)
 
-instance NFData Tag
-
-tagToString :: Tag -> String
-tagToString Recommended        = "recommended"
-tagToString Latest             = "latest"
-tagToString Prerelease         = "prerelease"
-tagToString (Base       pvp'') = "base-" ++ T.unpack (prettyPVP pvp'')
-tagToString (UnknownTag t    ) = t
-tagToString Old                = ""
-
-instance Pretty Tag where
-  pPrint Recommended        = text "recommended"
-  pPrint Latest             = text "latest"
-  pPrint Prerelease         = text "prerelease"
-  pPrint (Base       pvp'') = text ("base-" ++ T.unpack (prettyPVP pvp''))
-  pPrint (UnknownTag t    ) = text t
-  pPrint Old                = mempty
 
 data Architecture = A_64
                   | A_32
-                  | A_PowerPC
-                  | A_PowerPC64
-                  | A_Sparc
-                  | A_Sparc64
-                  | A_ARM
-                  | A_ARM64
   deriving (Eq, GHC.Generic, Ord, Show)
 
-instance NFData Architecture
-
-archToString :: Architecture -> String
-archToString A_64 = "x86_64"
-archToString A_32 = "i386"
-archToString A_PowerPC = "powerpc"
-archToString A_PowerPC64 = "powerpc64"
-archToString A_Sparc = "sparc"
-archToString A_Sparc64 = "sparc64"
-archToString A_ARM = "arm"
-archToString A_ARM64 = "aarch64"
-
-instance Pretty Architecture where
-  pPrint = text . archToString
 
 data Platform = Linux LinuxDistro
               -- ^ must exit
               | Darwin
               -- ^ must exit
               | FreeBSD
-              | Windows
-              -- ^ must exit
   deriving (Eq, GHC.Generic, Ord, Show)
 
-instance NFData Platform
-
-platformToString :: Platform -> String
-platformToString (Linux distro) = "linux-" ++ distroToString distro
-platformToString Darwin = "darwin"
-platformToString FreeBSD = "freebsd"
-platformToString Windows = "windows"
-
-instance Pretty Platform where
-  pPrint = text . platformToString
-
 data LinuxDistro = Debian
                  | Ubuntu
                  | Mint
@@ -231,35 +112,16 @@ data LinuxDistro = Debian
                  -- ^ must exit
   deriving (Eq, GHC.Generic, Ord, Show)
 
-instance NFData LinuxDistro
-
-distroToString :: LinuxDistro -> String
-distroToString Debian = "debian"
-distroToString Ubuntu = "ubuntu"
-distroToString Mint = "mint"
-distroToString Fedora = "fedora"
-distroToString CentOS = "centos"
-distroToString RedHat = "redhat"
-distroToString Alpine = "alpine"
-distroToString AmazonLinux = "amazon"
-distroToString Gentoo = "gentoo"
-distroToString Exherbo = "exherbo"
-distroToString UnknownLinux = "unknown"
-
-instance Pretty LinuxDistro where
-  pPrint = text . distroToString
-
 
 -- | An encapsulation of a download. This can be used
 -- to download, extract and install a tool.
 data DownloadInfo = DownloadInfo
   { _dlUri    :: URI
-  , _dlSubdir :: Maybe TarDir
+  , _dlSubdir :: Maybe (Path Rel)
   , _dlHash   :: Text
   }
-  deriving (Eq, Ord, GHC.Generic, Show)
+  deriving (Eq, Show)
 
-instance NFData DownloadInfo
 
 
 
@@ -268,201 +130,25 @@ instance NFData DownloadInfo
     --------------
 
 
--- | How to descend into a tar archive.
-data TarDir = RealDir FilePath
-            | RegexDir String     -- ^ will be compiled to regex, the first match will "win"
-            deriving (Eq, Ord, GHC.Generic, Show)
-
-instance NFData TarDir
-
-instance Pretty TarDir where
-  pPrint (RealDir path) = text path
-  pPrint (RegexDir regex) = text regex
-
-
 -- | Where to fetch GHCupDownloads from.
 data URLSource = GHCupURL
                | OwnSource URI
                | OwnSpec GHCupInfo
-               | AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
-               deriving (GHC.Generic, Show)
-
-instance NFData URLSource
-instance NFData (URIRef Absolute) where
-  rnf (URI !_ !_ !_ !_ !_) = ()
-
-
-data UserSettings = UserSettings
-  { uCache       :: Maybe Bool
-  , uNoVerify    :: Maybe Bool
-  , uVerbose     :: Maybe Bool
-  , uKeepDirs    :: Maybe KeepDirs
-  , uDownloader  :: Maybe Downloader
-  , uKeyBindings :: Maybe UserKeyBindings
-  , uUrlSource   :: Maybe URLSource
-  , uNoNetwork   :: Maybe Bool
-  , uGPGSetting  :: Maybe GPGSetting
-  }
-  deriving (Show, GHC.Generic)
-
-defaultUserSettings :: UserSettings
-defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
-
-fromSettings :: Settings -> Maybe KeyBindings -> UserSettings
-fromSettings Settings{..} Nothing =
-  UserSettings {
-      uCache = Just cache
-    , uNoVerify = Just noVerify
-    , uVerbose = Just verbose
-    , uKeepDirs = Just keepDirs
-    , uDownloader = Just downloader
-    , uNoNetwork = Just noNetwork
-    , uKeyBindings = Nothing
-    , uUrlSource = Just urlSource
-    , uGPGSetting = Just gpgSetting
-  }
-fromSettings Settings{..} (Just KeyBindings{..}) =
-  let ukb = UserKeyBindings
-            { kUp           = Just bUp        
-            , kDown         = Just bDown      
-            , kQuit         = Just bQuit      
-            , kInstall      = Just bInstall   
-            , kUninstall    = Just bUninstall 
-            , kSet          = Just bSet       
-            , kChangelog    = Just bChangelog 
-            , kShowAll      = Just bShowAllVersions
-            , kShowAllTools = Just bShowAllTools
-            }
-  in UserSettings {
-      uCache = Just cache
-    , uNoVerify = Just noVerify
-    , uVerbose = Just verbose
-    , uKeepDirs = Just keepDirs
-    , uDownloader = Just downloader
-    , uNoNetwork = Just noNetwork
-    , uKeyBindings = Just ukb
-    , uUrlSource = Just urlSource
-    , uGPGSetting = Just gpgSetting
-  }
-
-data UserKeyBindings = UserKeyBindings
-  { kUp        :: Maybe Key
-  , kDown      :: Maybe Key
-  , kQuit      :: Maybe Key
-  , kInstall   :: Maybe Key
-  , kUninstall :: Maybe Key
-  , kSet       :: Maybe Key
-  , kChangelog :: Maybe Key
-  , kShowAll   :: Maybe Key
-  , kShowAllTools :: Maybe Key
-  }
-  deriving (Show, GHC.Generic)
-
-data KeyBindings = KeyBindings
-  { bUp        :: Key
-  , bDown      :: Key
-  , bQuit      :: Key
-  , bInstall   :: Key
-  , bUninstall :: Key
-  , bSet       :: Key
-  , bChangelog :: Key
-  , bShowAllVersions :: Key
-  , bShowAllTools :: Key
-  }
-  deriving (Show, GHC.Generic)
-
-instance NFData KeyBindings
-instance NFData Key
-
-defaultKeyBindings :: KeyBindings
-defaultKeyBindings = KeyBindings
-  { bUp = KUp
-  , bDown = KDown
-  , bQuit = KChar 'q'
-  , bInstall = KChar 'i'
-  , bUninstall = KChar 'u'
-  , bSet = KChar 's'
-  , bChangelog = KChar 'c'
-  , bShowAllVersions = KChar 'a'
-  , bShowAllTools = KChar 't'
-  }
-
-data AppState = AppState
-  { settings :: Settings
-  , dirs :: Dirs
-  , keyBindings :: KeyBindings
-  , ghcupInfo :: GHCupInfo
-  , pfreq :: PlatformRequest
-  , loggerConfig :: LoggerConfig
-  } deriving (Show, GHC.Generic)
-
-instance NFData AppState
-
-data LeanAppState = LeanAppState
-  { settings :: Settings
-  , dirs :: Dirs
-  , keyBindings :: KeyBindings
-  , loggerConfig :: LoggerConfig
-  } deriving (Show, GHC.Generic)
-
-instance NFData LeanAppState
+               deriving Show
 
 
 data Settings = Settings
-  { cache      :: Bool
-  , noVerify   :: Bool
-  , keepDirs   :: KeepDirs
-  , downloader :: Downloader
-  , verbose    :: Bool
-  , urlSource  :: URLSource
-  , noNetwork  :: Bool
-  , gpgSetting :: GPGSetting
-  , noColor    :: Bool -- this also exists in LoggerConfig
+  { cache    :: Bool
+  , noVerify :: Bool
   }
-  deriving (Show, GHC.Generic)
+  deriving Show
 
-instance NFData Settings
-
-data Dirs = Dirs
-  { baseDir  :: FilePath
-  , binDir   :: FilePath
-  , cacheDir :: FilePath
-  , logsDir  :: FilePath
-  , confDir  :: FilePath
-  , recycleDir :: FilePath -- mainly used on windows
-  }
-  deriving (Show, GHC.Generic)
-
-instance NFData Dirs
-
-data KeepDirs = Always
-              | Errors
-              | Never
-  deriving (Eq, Show, Ord, GHC.Generic)
-
-instance NFData KeepDirs
-
-data Downloader = Curl
-                | Wget
-#if defined(INTERNAL_DOWNLOADER)
-                | Internal
-#endif
-  deriving (Eq, Show, Ord, GHC.Generic)
-
-instance NFData Downloader
-
-data GPGSetting = GPGStrict
-                | GPGLax
-                | GPGNone
-  deriving (Eq, Show, Ord, GHC.Generic)
-
-instance NFData GPGSetting
 
 data DebugInfo = DebugInfo
-  { diBaseDir  :: FilePath
-  , diBinDir   :: FilePath
-  , diGHCDir   :: FilePath
-  , diCacheDir :: FilePath
+  { diBaseDir  :: Path Abs
+  , diBinDir   :: Path Abs
+  , diGHCDir   :: Path Abs
+  , diCacheDir :: Path Abs
   , diArch     :: Architecture
   , diPlatform :: PlatformResult
   }
@@ -479,110 +165,11 @@ data PlatformResult = PlatformResult
   { _platform      :: Platform
   , _distroVersion :: Maybe Versioning
   }
-  deriving (Eq, Show, GHC.Generic)
-
-instance NFData PlatformResult
-
-platResToString :: PlatformResult -> String
-platResToString PlatformResult { _platform = plat, _distroVersion = Just v' }
-  = show plat <> ", " <> T.unpack (prettyV v')
-platResToString PlatformResult { _platform = plat, _distroVersion = Nothing }
-  = show plat
-
-instance Pretty PlatformResult where
-  pPrint = text . platResToString
+  deriving (Eq, Show)
 
 data PlatformRequest = PlatformRequest
   { _rArch     :: Architecture
   , _rPlatform :: Platform
   , _rVersion  :: Maybe Versioning
   }
-  deriving (Eq, Show, GHC.Generic)
-
-instance NFData PlatformRequest
-
-pfReqToString :: PlatformRequest -> String
-pfReqToString (PlatformRequest arch plat ver) =
-  archToString arch ++ "-" ++ platformToString plat ++ pver
- where
-  pver = case ver of
-           Just v' -> "-" ++ T.unpack (prettyV v')
-           Nothing -> ""
-
-instance Pretty PlatformRequest where
-  pPrint = text . pfReqToString
-
--- | A GHC identified by the target platform triple
--- and the version.
-data GHCTargetVersion = GHCTargetVersion
-  { _tvTarget  :: Maybe Text
-  , _tvVersion :: Version
-  }
-  deriving (Ord, Eq, Show)
-
-data GitBranch = GitBranch
-  { ref  :: String
-  , repo :: Maybe String
-  }
-  deriving (Ord, Eq, Show)
-
-mkTVer :: Version -> GHCTargetVersion
-mkTVer = GHCTargetVersion Nothing
-
-tVerToText :: GHCTargetVersion -> Text
-tVerToText (GHCTargetVersion (Just t) v') = t <> "-" <> prettyVer v'
-tVerToText (GHCTargetVersion Nothing  v') = prettyVer v'
-
--- | Assembles a path of the form: <target-triple>-<version>
-instance Pretty GHCTargetVersion where
-  pPrint = text . T.unpack . tVerToText
-
-
--- | A comparator and a version.
-data VersionCmp = VR_gt Versioning
-                | VR_gteq Versioning
-                | VR_lt Versioning
-                | VR_lteq Versioning
-                | VR_eq Versioning
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-instance NFData VersionCmp
-
-
--- | A version range. Supports && and ||, but not  arbitrary
--- combinations. This is a little simplified.
-data VersionRange = SimpleRange (NonEmpty VersionCmp) -- And
-                  | OrRange (NonEmpty VersionCmp) VersionRange
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-instance NFData VersionRange
-
-instance Pretty Versioning where
-  pPrint = text . T.unpack . prettyV
-
-instance Pretty Version where
-  pPrint = text . T.unpack . prettyVer
-
-instance Show (a -> b) where
-  show _ = "<function>"
-
-instance Show (IO ()) where
-  show _ = "<io>"
-
-
-data LogLevel = Warn
-              | Info
-              | Debug
-              | Error
-  deriving (Eq, Ord, Show)
-
-data LoggerConfig = LoggerConfig
-  { lcPrintDebug   :: Bool            -- ^ whether to print debug in colorOutter
-  , consoleOutter  :: T.Text -> IO () -- ^ how to write the console output
-  , fileOutter     :: T.Text -> IO () -- ^ how to write the file output
-  , fancyColors    :: Bool
-  }
-  deriving Show
-
-instance NFData LoggerConfig where
-  rnf (LoggerConfig !lcPrintDebug !_ !_ !fancyColors) = rnf (lcPrintDebug, fancyColors)
+  deriving (Eq, Show)

lib/GHCup/Types/JSON.hs

@@ -10,72 +10,38 @@
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
 
-{-|
-Module      : GHCup.Types.JSON
-Description : GHCup JSON types/instances
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
 module GHCup.Types.JSON where
 
 import           GHCup.Types
-import           GHCup.Utils.MegaParsec
 import           GHCup.Utils.Prelude
-import           GHCup.Utils.Logger             () -- TH is broken shite and needs GHCup.Utils.Logger for linking, although we don't depend on the file.
-                                                   -- This is due to the boot file.
 
-import           Control.Applicative            ( (<|>) )
 import           Data.Aeson
 import           Data.Aeson.TH
 import           Data.Aeson.Types
-import           Data.List.NonEmpty             ( NonEmpty(..) )
 import           Data.Text.Encoding            as E
 import           Data.Versions
-import           Data.Void
+import           Data.Word8
+import           HPath
 import           URI.ByteString
-import           Text.Casing
 
-import qualified Data.List.NonEmpty            as NE
+import qualified Data.ByteString               as BS
 import qualified Data.Text                     as T
-import qualified Text.Megaparsec               as MP
-import qualified Text.Megaparsec.Char          as MPC
 
 
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Architecture
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''MChunk
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
 deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GlobalTool
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GPGSetting
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
 
-instance ToJSON Tag where
-  toJSON Latest             = String "Latest"
-  toJSON Recommended        = String "Recommended"
-  toJSON Prerelease         = String "Prerelease"
-  toJSON Old                = String "old"
-  toJSON (Base       pvp'') = String ("base-" <> prettyPVP pvp'')
-  toJSON (UnknownTag x    ) = String (T.pack x)
-
-instance FromJSON Tag where
-  parseJSON = withText "Tag" $ \t -> case T.unpack t of
-    "Latest"                             -> pure Latest
-    "Recommended"                        -> pure Recommended
-    "Prerelease"                         -> pure Prerelease
-    "old"                                -> pure Old
-    ('b' : 'a' : 's' : 'e' : '-' : ver') -> case pvp (T.pack ver') of
-      Right x -> pure $ Base x
-      Left  e -> fail . show $ e
-    x -> pure (UnknownTag x)
 
 instance ToJSON URI where
   toJSON = toJSON . decUTF8Safe . serializeURIRef'
@@ -109,10 +75,10 @@ instance ToJSONKey (Maybe Versioning) where
 
 instance FromJSONKey (Maybe Versioning) where
   fromJSONKey = FromJSONKeyTextParser $ \t ->
-    if t == T.pack "unknown_versioning" then pure Nothing else just t
+    if t == T.pack "unknown_versioning" then pure Nothing else pure $ just t
    where
     just t = case versioning t of
-      Right x -> pure $ Just x
+      Right x -> pure x
       Left  e -> fail $ "Failure in (Maybe Versioning) (FromJSONKey)" <> show e
 
 instance ToJSONKey Platform where
@@ -120,13 +86,11 @@ instance ToJSONKey Platform where
     Darwin  -> T.pack "Darwin"
     FreeBSD -> T.pack "FreeBSD"
     Linux d -> T.pack ("Linux_" <> show d)
-    Windows -> T.pack "Windows"
 
 instance FromJSONKey Platform where
   fromJSONKey = FromJSONKeyTextParser $ \t -> if
     | T.pack "Darwin" == t -> pure Darwin
     | T.pack "FreeBSD" == t -> pure FreeBSD
-    | T.pack "Windows" == t -> pure Windows
     | T.pack "Linux_" `T.isPrefixOf` t -> case
         T.stripPrefix (T.pack "Linux_") t
       of
@@ -142,7 +106,7 @@ instance FromJSONKey Platform where
                   $  "Unexpected failure in decoding LinuxDistro: "
                   <> show dstr
         Nothing -> fail "Unexpected failure in Platform stripPrefix"
-    | otherwise -> fail "Failure in Platform (FromJSONKey)"
+    | otherwise -> fail $ "Failure in Platform (FromJSONKey)"
 
 instance ToJSONKey Architecture where
   toJSONKey = genericToJSONKey defaultJSONKeyOptions
@@ -157,10 +121,10 @@ instance ToJSONKey (Maybe Version) where
 
 instance FromJSONKey (Maybe Version) where
   fromJSONKey = FromJSONKeyTextParser $ \t ->
-    if t == T.pack "unknown_version" then pure Nothing else just t
+    if t == T.pack "unknown_version" then pure Nothing else pure $ just t
    where
     just t = case version t of
-      Right x -> pure $ Just x
+      Right x -> pure x
       Left  e -> fail $ "Failure in (Maybe Version) (FromJSONKey)" <> show e
 
 instance ToJSON Version where
@@ -179,146 +143,21 @@ instance FromJSONKey Version where
     Right x -> pure x
     Left  e -> fail $ "Failure in Version (FromJSONKey)" <> show e
 
-instance ToJSON PVP where
-  toJSON = toJSON . prettyPVP
-
-instance FromJSON PVP where
-  parseJSON = withText "PVP" $ \t -> case pvp t of
-    Right x -> pure x
-    Left  e -> fail $ "Failure in PVP (FromJSON)" <> show e
-
 instance ToJSONKey Tool where
   toJSONKey = genericToJSONKey defaultJSONKeyOptions
 
 instance FromJSONKey Tool where
   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
 
-instance ToJSONKey GlobalTool where
-  toJSONKey = genericToJSONKey defaultJSONKeyOptions
+instance ToJSON (Path Rel) where
+  toJSON p = case and . fmap isAscii . BS.unpack $ fp of
+    True  -> toJSON . decUTF8Safe $ fp
+    False -> String "/not/a/valid/path"
+    where fp = toFilePath p
 
-instance FromJSONKey GlobalTool where
-  fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
-
-instance ToJSON TarDir where
-  toJSON (RealDir  p) = toJSON p
-  toJSON (RegexDir r) = object ["RegexDir" .= r]
-
-instance FromJSON TarDir where
-  parseJSON v = realDir v <|> regexDir v
-   where
-    realDir = withText "TarDir" $ \t -> do
-      fp <- parseJSON (String t)
-      pure (RealDir fp)
-    regexDir = withObject "TarDir" $ \o -> do
-      r <- o .: "RegexDir"
-      pure $ RegexDir r
-
-
-instance ToJSON VersionCmp where
-  toJSON = String . versionCmpToText
-
-instance FromJSON VersionCmp where
-  parseJSON = withText "VersionCmp" $ \t -> do
-    case MP.parse versionCmpP "" t of
-      Right r -> pure r
-      Left  e -> fail (MP.errorBundlePretty e)
-
-versionCmpToText :: VersionCmp -> T.Text
-versionCmpToText (VR_gt   ver') = "> " <> prettyV ver'
-versionCmpToText (VR_gteq ver') = ">= " <> prettyV ver'
-versionCmpToText (VR_lt   ver') = "< " <> prettyV ver'
-versionCmpToText (VR_lteq ver') = "<= " <> prettyV ver'
-versionCmpToText (VR_eq   ver') = "== " <> prettyV ver'
-
-versionCmpP :: MP.Parsec Void T.Text VersionCmp
-versionCmpP =
-  fmap VR_gt (MP.try $ MPC.space *> MP.chunk ">" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_gteq
-          (MP.try $ MPC.space *> MP.chunk ">=" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_lt
-          (MP.try $ MPC.space *> MP.chunk "<" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_lteq
-          (MP.try $ MPC.space *> MP.chunk "<=" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_eq
-          (MP.try $ MPC.space *> MP.chunk "==" *> MPC.space *> versioningEnd)
-    <|> fmap
-          VR_eq
-          (MP.try $ MPC.space *> versioningEnd)
-
-instance ToJSON VersionRange where
-  toJSON = String . verRangeToText
-
-verRangeToText :: VersionRange -> T.Text
-verRangeToText  (SimpleRange cmps) =
-  let inner = foldr1 (\x y -> x <> " && " <> y)
-                     (versionCmpToText <$> NE.toList cmps)
-  in  "( " <> inner <> " )"
-verRangeToText (OrRange cmps range) =
-  let left  = verRangeToText (SimpleRange cmps)
-      right = verRangeToText range
-  in  left <> " || " <> right
-
-instance FromJSON VersionRange where
-  parseJSON = withText "VersionRange" $ \t -> do
-    case MP.parse versionRangeP "" t of
-      Right r -> pure r
-      Left  e -> fail (MP.errorBundlePretty e)
-
-versionRangeP :: MP.Parsec Void T.Text VersionRange
-versionRangeP = go <* MP.eof
- where
-  go =
-    MP.try orParse
-      <|> MP.try (fmap SimpleRange andParse)
-      <|> fmap (SimpleRange . pure) versionCmpP
-
-  orParse :: MP.Parsec Void T.Text VersionRange
-  orParse =
-    (\a o -> OrRange a o)
-      <$> (MP.try andParse <|> fmap pure versionCmpP)
-      <*> (MPC.space *> MP.chunk "||" *> MPC.space *> go)
-
-  andParse :: MP.Parsec Void T.Text (NonEmpty VersionCmp)
-  andParse =
-    fmap (\h t -> h :| t)
-         (MPC.space *> MP.chunk "(" *> MPC.space *> versionCmpP)
-      <*> MP.try (MP.many (MPC.space *> MP.chunk "&&" *> MPC.space *> versionCmpP))
-      <*  MPC.space
-      <*  MP.chunk ")"
-      <*  MPC.space
-
-versioningEnd :: MP.Parsec Void T.Text Versioning
-versioningEnd =
-  MP.try (verP (MP.chunk " " <|> MP.chunk ")" <|> MP.chunk "&&") <* MPC.space)
-    <|> versioning'
-
-instance ToJSONKey (Maybe VersionRange) where
-  toJSONKey = toJSONKeyText $ \case
-    Just x -> verRangeToText x
-    Nothing -> "unknown_versioning"
-
-instance FromJSONKey (Maybe VersionRange)  where
-  fromJSONKey = FromJSONKeyTextParser $ \t ->
-    if t == T.pack "unknown_versioning" then pure Nothing else just t
-   where
-    just t = case MP.parse versionRangeP "" t of
-      Right x -> pure $ Just x
-      Left  e -> fail $ "Failure in (Maybe VersionRange) (FromJSONKey)" <> MP.errorBundlePretty e
-
-
-
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
-deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
-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
-deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
-
-deriveToJSON defaultOptions { fieldLabelModifier = kebab } ''Settings
-deriveToJSON defaultOptions { fieldLabelModifier = drop 2 . kebab } ''KeyBindings -- move under key-bindings key
+instance FromJSON (Path Rel) where
+  parseJSON = withText "HPath Rel" $ \t -> do
+    let d = encodeUtf8 t
+    case parseRel d of
+      Right x -> pure x
+      Left  e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e

lib/GHCup/Types/Optics.hs

@@ -1,32 +1,13 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE ConstraintKinds       #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE MultiParamTypeClasses   #-}
-{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE TemplateHaskell #-}
 
-{-|
-Module      : GHCup.Types.Optics
-Description : GHCup optics
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
 module GHCup.Types.Optics where
 
 import           GHCup.Types
 
-import           Control.Monad.Reader
-import           Data.ByteString         ( ByteString )
+import           Data.ByteString                ( ByteString )
 import           Optics
 import           URI.ByteString
 
-
 makePrisms ''Tool
 makePrisms ''Architecture
 makePrisms ''LinuxDistro
@@ -38,8 +19,6 @@ makeLenses ''DownloadInfo
 makeLenses ''Tag
 makeLenses ''VersionInfo
 
-makeLenses ''GHCTargetVersion
-
 makeLenses ''GHCupInfo
 
 uriSchemeL' :: Lens' (URIRef Absolute) Scheme
@@ -68,95 +47,3 @@ pathL' = lensVL pathL
 
 queryL' :: Lens' (URIRef a) Query
 queryL' = lensVL queryL
-
-
-
-    ----------------------
-    --[ Lens utilities ]--
-    ----------------------
-
-
-gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a)
-     => m a
-gets = asks (^. labelOptic @f)
-
-
-getAppState :: MonadReader AppState m => m AppState
-getAppState = ask
-
-
-getLeanAppState :: ( MonadReader env m
-                   , LabelOptic' "settings"    A_Lens env Settings
-                   , LabelOptic' "dirs"        A_Lens env Dirs
-                   , LabelOptic' "keyBindings" A_Lens env KeyBindings
-                   , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-                   )
-                => m LeanAppState
-getLeanAppState = do
-  s <- gets @"settings"
-  d <- gets @"dirs"
-  k <- gets @"keyBindings"
-  l <- gets @"loggerConfig"
-  pure (LeanAppState s d k l)
-
-
-getSettings :: ( MonadReader env m
-               , LabelOptic' "settings" A_Lens env Settings
-               )
-            => m Settings
-getSettings = gets @"settings"
-
-
-getDirs :: ( MonadReader env m
-           , LabelOptic' "dirs" A_Lens env Dirs
-           )
-        => m Dirs
-getDirs = gets @"dirs"
-
-
-getLogCleanup :: ( MonadReader env m
-                 , LabelOptic' "logCleanup" A_Lens env (IO ())
-                 )
-              => m (IO ())
-getLogCleanup = gets @"logCleanup"
-
-
-getKeyBindings :: ( MonadReader env m
-                  , LabelOptic' "keyBindings" A_Lens env KeyBindings
-                  )
-               => m KeyBindings
-getKeyBindings = gets @"keyBindings"
-
-
-getGHCupInfo :: ( MonadReader env m
-                , LabelOptic' "ghcupInfo" A_Lens env GHCupInfo
-                )
-             => m GHCupInfo
-getGHCupInfo = gets @"ghcupInfo"
-
-
-getPlatformReq :: ( MonadReader env m
-                  , LabelOptic' "pfreq" A_Lens env PlatformRequest
-                  )
-               => m PlatformRequest
-getPlatformReq = gets @"pfreq"
-
-
-type HasSettings env = (LabelOptic' "settings" A_Lens env Settings)
-type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
-type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
-type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
-type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
-type HasLog env = (LabelOptic' "loggerConfig" A_Lens env LoggerConfig)
-
-
-getCache :: (MonadReader env m, HasSettings env) => m Bool
-getCache = getSettings <&> cache
-
-
-getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
-getDownloader = getSettings <&> downloader
-
-
-instance LabelOptic "dirs" A_Lens Dirs Dirs Dirs Dirs where
-  labelOptic = lens id (\_ d -> d)

lib/GHCup/Utils.hs-boot

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

lib/GHCup/Utils/Bash.hs

@@ -0,0 +1,69 @@
+module GHCup.Utils.Bash
+  ( findAssignment
+  , equalsAssignmentWith
+  , getRValue
+  , getAssignmentValueFor
+  )
+where
+
+import           Control.Monad
+import           Data.ByteString.UTF8           ( toString )
+import           Data.List
+import           Data.Maybe
+import           HPath
+import           HPath.IO
+import           Language.Bash.Parse
+import           Language.Bash.Syntax
+import           Language.Bash.Word
+import           Prelude                 hiding ( readFile )
+
+import qualified Data.ByteString.Lazy.UTF8     as UTF8
+
+
+extractAssignments :: List -> [Assign]
+extractAssignments (List stms) = join $ fmap getAssign $ getCommands stms
+ where
+  getCommands :: [Statement] -> [Command]
+  getCommands = join . fmap commands . catMaybes . fmap findPipes
+   where
+    findPipes (Statement (Last p@(Pipeline{})) Sequential) = Just p
+    findPipes _ = Nothing
+
+  getAssign :: Command -> [Assign]
+  getAssign (Command (SimpleCommand ass _) _) = ass
+  getAssign _ = []
+
+
+-- | Find an assignment matching the predicate in the given file.
+findAssignment :: Path b -> (Assign -> Bool) -> IO (Maybe Assign)
+findAssignment p predicate = do
+  fileContents <- readFile p
+  -- TODO: this should accept bytestring:
+  --       https://github.com/knrafto/language-bash/issues/37
+  case parse (toString . toFilePath $ p) (UTF8.toString fileContents) of
+    Left  e -> fail $ show e
+    Right l -> pure $ find predicate (extractAssignments $ l)
+
+
+-- | Check that the assignment is of the form Foo= ignoring the
+-- right hand-side.
+equalsAssignmentWith :: String -> Assign -> Bool
+equalsAssignmentWith n ass = case ass of
+  (Assign (Parameter name' Nothing) Equals _) -> n == name'
+  _ -> False
+
+
+-- | This pretty-prints the right hand of an Equals assignment, removing
+-- quotations. No evaluation is performed.
+getRValue :: Assign -> Maybe String
+getRValue ass = case ass of
+  (Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
+  _ -> Nothing
+
+
+-- | Given a bash assignment such as Foo="Bar" in the given file,
+-- will return "Bar" (without quotations).
+getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
+getAssignmentValueFor p n = do
+  mass <- findAssignment p (equalsAssignmentWith n)
+  pure (mass >>= getRValue)

lib/GHCup/Utils/Dirs.hs

@@ -1,318 +1,78 @@
-{-# 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
-  , mkGhcupTmpDir
-  , parseGHCupGHCDir
-  , relativeSymlink
-  , withGHCupTmpDir
-  , getConfigFilePath
-#if !defined(IS_WINDOWS)
-  , useXDG
-#endif
-  , cleanupTrash
-  )
-where
+module GHCup.Utils.Dirs where
 
 
-import           GHCup.Errors
-import           GHCup.Types
 import           GHCup.Types.JSON               ( )
-import           GHCup.Types.Optics
-import           GHCup.Utils.MegaParsec
-import           GHCup.Utils.Logger
 import           GHCup.Utils.Prelude
 
+import           Control.Applicative
 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           Control.Monad.Trans.Resource
 import           Data.Maybe
-import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
-import           Haskus.Utils.Variant.Excepts
+import           Data.Versions
+import           HPath
+import           HPath.IO
 import           Optics
-import           System.Directory                                                
-import           System.DiskSpace                                                
-import           System.Environment
-import           System.FilePath
-import           System.IO.Temp
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import           System.Posix.Env.ByteString    ( getEnv
+                                                , getEnvDefault
+                                                )
+import           System.Posix.Temp.ByteString   ( mkdtemp )
 
-import qualified Data.ByteString               as BS
-import qualified Data.Text                     as T
-import qualified Data.YAML.Aeson               as Y
-import qualified Text.Megaparsec               as MP
-import Control.Concurrent (threadDelay)
+import qualified Data.ByteString.UTF8          as UTF8
+import qualified System.Posix.FilePath         as FP
+import qualified System.Posix.User             as PU
 
 
 
-    ------------------------------
-    --[ 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 = do
-#if defined(IS_WINDOWS)
-  bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
-  pure (bdir </> "ghcup")
-#else
-  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")
-#endif
-
-
--- | ~/.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 = do
-#if defined(IS_WINDOWS)
-  ghcupBaseDir
-#else
-  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")
-#endif
-
-
--- | 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 = do
-#if defined(IS_WINDOWS)
-  ghcupBaseDir <&> (</> "bin")
-#else
-  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")
-#endif
-
-
--- | 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 = do
-#if defined(IS_WINDOWS)
-  ghcupBaseDir <&> (</> "cache")
-#else
-  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")
-#endif
-
-
--- | 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 = do
-#if defined(IS_WINDOWS)
-  ghcupBaseDir <&> (</> "logs")
-#else
-  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")
-#endif
-
-
--- | '~/.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 snd . Y.decode1Strict $ contents'
-
-
     -------------------------
     --[ GHCup directories ]--
     -------------------------
 
 
--- | ~/.ghcup/ghc by default.
-ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
-ghcupGHCBaseDir = do
-  Dirs {..}  <- getDirs
-  pure (baseDir </> "ghc")
+ghcupBaseDir :: IO (Path Abs)
+ghcupBaseDir = do
+  bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+    Just r  -> parseAbs r
+    Nothing -> liftIO getHomeDirectory
+  pure (bdir </> [rel|.ghcup|])
 
+ghcupGHCBaseDir :: IO (Path Abs)
+ghcupGHCBaseDir = ghcupBaseDir <&> (</> [rel|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 :: Version -> IO (Path Abs)
 ghcupGHCDir ver = do
   ghcbasedir <- ghcupGHCBaseDir
-  let verdir = T.unpack $ tVerToText ver
+  verdir     <- parseRel (verToBS ver)
   pure (ghcbasedir </> verdir)
 
 
--- | See 'ghcupToolParser'.
-parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
-parseGHCupGHCDir (T.pack -> fp) =
-  throwEither $ MP.parse ghcTargetVerP "" fp
+ghcupBinDir :: IO (Path Abs)
+ghcupBinDir = ghcupBaseDir <&> (</> [rel|bin|])
+
+ghcupCacheDir :: IO (Path Abs)
+ghcupCacheDir = ghcupBaseDir <&> (</> [rel|cache|])
+
+ghcupLogsDir :: IO (Path Abs)
+ghcupLogsDir = ghcupBaseDir <&> (</> [rel|logs|])
 
 
-mkGhcupTmpDir :: ( MonadReader env m
-                 , HasDirs env
-                 , MonadUnliftIO m
-                 , HasLog env
-                 , MonadCatch m
-                 , MonadThrow m
-                 , MonadMask m
-                 , MonadIO m)
-              => m FilePath
+mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
 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))
+  tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
+  tmp    <- liftIO $ mkdtemp $ (tmpdir FP.</> "ghcup-")
+  parseAbs tmp
 
 
+withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
+withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
 
 
     --------------
@@ -320,40 +80,11 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
     --------------
 
 
-#if !defined(IS_WINDOWS)
-useXDG :: IO Bool
-useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
-#endif
-
-
-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))
-
+getHomeDirectory :: IO (Path Abs)
+getHomeDirectory = do
+  e <- getEnv "HOME"
+  case e of
+    Just fp -> parseAbs fp
+    Nothing -> do
+      h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
+      parseAbs $ UTF8.fromString h -- this is a guess

lib/GHCup/Utils/File.hs

@@ -1,17 +1,382 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
-module GHCup.Utils.File (
-  module GHCup.Utils.File.Common,
-#if IS_WINDOWS
-  module GHCup.Utils.File.Windows
-#else
-  module GHCup.Utils.File.Posix
-#endif
-) where
+module GHCup.Utils.File where
 
-import GHCup.Utils.File.Common
-#if IS_WINDOWS
-import GHCup.Utils.File.Windows
-#else
-import GHCup.Utils.File.Posix
-#endif
+import           GHCup.Utils.Dirs
+import           GHCup.Utils.Prelude
+
+import           Control.Concurrent
+import           Control.Exception              ( evaluate )
+import           Control.Exception.Safe
+import           Control.Monad
+import           Data.ByteString                ( ByteString )
+import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
+import           Data.Char
+import           Data.Foldable
+import           Data.Functor
+import           Data.IORef
+import           Data.Maybe
+import           GHC.Foreign                    ( peekCStringLen )
+import           GHC.IO.Encoding                ( getLocaleEncoding )
+import           GHC.IO.Exception
+import           HPath
+import           HPath.IO
+import           Optics
+import           Streamly
+import           Streamly.External.ByteString
+import           Streamly.External.ByteString.Lazy
+import           System.Console.Pretty
+import           System.Console.Regions
+import           System.IO
+import           System.IO.Error
+import           System.Posix.Directory.ByteString
+import           System.Posix.FD               as FD
+import           System.Posix.FilePath   hiding ( (</>) )
+import           System.Posix.Foreign           ( oExcl )
+import "unix"    System.Posix.IO.ByteString
+                                         hiding ( openFd )
+import           System.Posix.Process           ( ProcessStatus(..) )
+import           System.Posix.Types
+
+
+import qualified Control.Exception             as EX
+import qualified Data.Text                     as T
+import qualified System.Posix.Process.ByteString
+                                               as SPPB
+import           Streamly.External.Posix.DirStream
+import qualified Streamly.Internal.Memory.ArrayStream
+                                               as AS
+import qualified Streamly.FileSystem.Handle    as FH
+import qualified Streamly.Internal.Data.Unfold as SU
+import qualified Streamly.Prelude              as S
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as L
+import qualified "unix-bytestring" System.Posix.IO.ByteString
+                                               as SPIB
+
+
+-- | Bool signals whether the regions should be cleaned.
+data StopThread = StopThread Bool
+  deriving Show
+
+instance Exception StopThread
+
+
+data ProcessError = NonZeroExit Int ByteString [ByteString]
+                  | PTerminated ByteString [ByteString]
+                  | PStopped ByteString [ByteString]
+                  | NoSuchPid ByteString [ByteString]
+                  deriving Show
+
+
+data CapturedProcess = CapturedProcess
+  { _exitCode :: ExitCode
+  , _stdOut   :: ByteString
+  , _stdErr   :: ByteString
+  }
+  deriving (Eq, Show)
+
+makeLenses ''CapturedProcess
+
+
+readFd :: Fd -> IO L.ByteString
+readFd fd = do
+  handle' <- fdToHandle fd
+  fromChunksIO $ (S.unfold (SU.finallyIO hClose FH.readChunks) handle')
+
+
+-- | Read the lines of a file into a stream. The stream holds
+-- a file handle as a resource and will close it once the stream
+-- terminates (either through exception or because it's drained).
+readFileLines :: Path b -> IO (SerialT IO ByteString)
+readFileLines p = do
+  stream <- readFileStream p
+  pure
+    . (fmap fromArray)
+    . AS.splitOn (fromIntegral $ ord '\n')
+    . (fmap toArray)
+    $ stream
+
+
+-- | Find the given executable by searching all *absolute* PATH components.
+-- Relative paths in PATH are ignored.
+--
+-- This shouldn't throw IO exceptions, unless getting the environment variable
+-- PATH does.
+findExecutable :: Path Rel -> IO (Maybe (Path Abs))
+findExecutable ex = do
+  sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
+  -- We don't want exceptions to mess up our result. If we can't
+  -- figure out if a file exists, then treat it as a negative result.
+  asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
+    -- asum for short-circuiting behavior
+    (\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
+    sPaths
+
+
+-- | Execute the given command and collect the stdout, stderr and the exit code.
+-- The command is run in a subprocess.
+executeOut :: Path b            -- ^ command as filename, e.g. 'ls'
+           -> [ByteString]      -- ^ arguments to the command
+           -> Maybe (Path Abs)  -- ^ chdir to this path
+           -> IO CapturedProcess
+executeOut path args chdir = captureOutStreams $ do
+  maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+  SPPB.executeFile (toFilePath path) True args Nothing
+
+
+execLogged :: ByteString       -- ^ thing to execute
+           -> Bool             -- ^ whether to search PATH for the thing
+           -> [ByteString]     -- ^ args for the thing
+           -> Path Rel         -- ^ log filename
+           -> Maybe (Path Abs) -- ^ optionally chdir into this
+           -> Maybe [(ByteString, ByteString)] -- ^ optional environment
+           -> IO (Either ProcessError ())
+execLogged exe spath args lfile chdir env = do
+  ldir    <- ghcupLogsDir
+  logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
+  bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
+ where
+  action fd = do
+    actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
+      -- start the thread that logs to stdout in a region
+      done <- newEmptyMVar
+      tid  <-
+        forkIO
+        $ EX.handle (\(_ :: StopThread) -> pure ())
+        $ EX.handle (\(_ :: IOException) -> pure ())
+        $ flip finally (putMVar done ())
+        $ printToRegion fd stdoutRead 6
+
+      -- fork our subprocess
+      pid <- SPPB.forkProcess $ do
+        void $ dupTo stdoutWrite stdOutput
+        void $ dupTo stdoutWrite stdError
+        closeFd stdoutWrite
+        closeFd stdoutRead
+
+        -- execute the action
+        maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+        SPPB.executeFile exe spath args env
+
+      closeFd stdoutWrite
+
+      -- wait for the subprocess to finish
+      e <- SPPB.getProcessStatus True True pid >>= \case
+        i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
+        i                        -> pure $ toProcessError exe args i
+
+      -- make sure the logging thread stops
+      case e of
+        Left  _ -> EX.throwTo tid (StopThread False)
+        Right _ -> EX.throwTo tid (StopThread True)
+      takeMVar done
+
+      closeFd stdoutRead
+      pure e
+
+  -- Reads fdIn and logs the output in a continous scrolling area
+  -- of 'size' terminal lines. Also writes to a log file.
+  printToRegion fileFd fdIn size = do
+    ref <- newIORef ([] :: [ByteString])
+    displayConsoleRegions $ do
+      rs <- sequence . replicate size . openConsoleRegion $ Linear
+      flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
+        $ handle
+            (\(StopThread b) -> do
+              when b (forM_ rs closeConsoleRegion)
+              EX.throw (StopThread b)
+            )
+        $ do
+            hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
+            -- wait for explicit stop from the parent to signal what cleanup to run
+            forever (threadDelay 5000)
+
+   where
+    -- action to perform line by line
+    lineAction ref rs bs' = do
+      modifyIORef' ref (swapRegs bs')
+      regs <- readIORef ref
+      forM (zip regs rs) $ \(bs, r) -> do
+        setConsoleRegion r $ do
+          w <- consoleWidth
+          return
+            . T.pack
+            . color Blue
+            . T.unpack
+            . decUTF8Safe
+            . trim w
+            . (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
+            $ bs
+        SPIB.fdWrite fileFd (bs <> "\n")
+
+
+    swapRegs bs regs | length regs < size = regs ++ [bs]
+                     | otherwise          = tail regs ++ [bs]
+
+    -- trim output line to terminal width
+    trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
+              | otherwise                 = bs
+
+    -- read an entire line from the file descriptor (removes the newline char)
+    readLine fd' = do
+      bs <- SPIB.fdRead fd' 1
+      if
+        | bs == "\n" -> pure ""
+        | bs == ""   -> pure ""
+        | otherwise  -> fmap (bs <>) $ readLine fd'
+
+    readTilEOF action' fd' = do
+      bs <- readLine fd'
+      void $ action' bs
+      readTilEOF action' fd'
+
+
+-- | Capture the stdout and stderr of the given action, which
+-- is run in a subprocess. Stdin is closed. You might want to
+-- 'race' this to make sure it terminates.
+captureOutStreams :: IO a
+                     -- ^ the action to execute in a subprocess
+                  -> IO CapturedProcess
+captureOutStreams action = do
+  actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
+    actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
+      pid <- SPPB.forkProcess $ do
+        -- dup stdout
+        void $ dupTo childStdoutWrite stdOutput
+        closeFd childStdoutWrite
+        closeFd parentStdoutRead
+
+        -- dup stderr
+        void $ dupTo childStderrWrite stdError
+        closeFd childStderrWrite
+        closeFd parentStderrRead
+
+        -- execute the action
+        a <- action
+        void $ evaluate a
+
+      -- close everything we don't need
+      closeFd childStdoutWrite
+      closeFd childStderrWrite
+
+      -- start thread that writes the output
+      refOut <- newIORef BS.empty
+      refErr <- newIORef BS.empty
+      done   <- newEmptyMVar
+      _      <-
+        forkIO
+        $ EX.handle (\(_ :: StopThread) -> pure ())
+        $ EX.handle (\(_ :: IOException) -> pure ())
+        $ flip finally (putMVar done ())
+        $ writeStds parentStdoutRead parentStderrRead refOut refErr
+
+      status <- SPPB.getProcessStatus True True pid
+      takeMVar done
+
+      case status of
+        -- readFd will take care of closing the fd
+        Just (SPPB.Exited es) -> do
+          stdout' <- readIORef refOut
+          stderr' <- readIORef refErr
+          pure $ CapturedProcess { _exitCode = es
+                                 , _stdOut   = stdout'
+                                 , _stdErr   = stderr'
+                                 }
+
+        _ -> throwIO $ userError $ ("No such PID " ++ show pid)
+
+ where
+  writeStds pout perr rout rerr = do
+    doneOut <- newEmptyMVar
+    void
+      $ forkIO
+      $ hideError eofErrorType
+      $ flip finally (putMVar doneOut ())
+      $ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
+    doneErr <- newEmptyMVar
+    void
+      $ forkIO
+      $ hideError eofErrorType
+      $ flip finally (putMVar doneErr ())
+      $ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
+    takeMVar doneOut
+    takeMVar doneErr
+
+  readTilEOF ~action' fd' = do
+    bs <- SPIB.fdRead fd' 512
+    void $ action' bs
+    readTilEOF action' fd'
+
+
+actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
+actionWithPipes a =
+  createPipe >>= \(p1, p2) -> (flip finally) (cleanup [p1, p2]) $ a (p1, p2)
+
+cleanup :: [Fd] -> IO ()
+cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
+
+
+
+-- | Create a new regular file in write-only mode. The file must not exist.
+createRegularFileFd :: FileMode -> Path b -> IO Fd
+createRegularFileFd fm dest =
+  FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
+
+
+-- | Thin wrapper around `executeFile`.
+exec :: ByteString       -- ^ thing to execute
+     -> Bool             -- ^ whether to search PATH for the thing
+     -> [ByteString]     -- ^ args for the thing
+     -> Maybe (Path Abs) -- ^ optionally chdir into this
+     -> Maybe [(ByteString, ByteString)] -- ^ optional environment
+     -> IO (Either ProcessError ())
+exec exe spath args chdir env = do
+  pid <- SPPB.forkProcess $ do
+    maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+    SPPB.executeFile exe spath args env
+
+  fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
+
+
+toProcessError :: ByteString
+               -> [ByteString]
+               -> Maybe ProcessStatus
+               -> Either ProcessError ()
+toProcessError exe args mps = case mps of
+  Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
+  Just (SPPB.Exited ExitSuccess    ) -> Right ()
+  Just (Terminated _ _             ) -> Left $ PTerminated exe args
+  Just (Stopped _                  ) -> Left $ PStopped exe args
+  Nothing                            -> Left $ NoSuchPid exe args
+
+
+-- | Convert the String to a ByteString with the current
+-- system encoding.
+unsafePathToString :: Path b -> IO FilePath
+unsafePathToString p = do
+  enc <- getLocaleEncoding
+  unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
+
+
+-- | Search for a file in the search paths.
+--
+-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
+searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
+searchPath paths needle = go paths
+ where
+  go [] = pure Nothing
+  go (x : xs) =
+    hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
+      $ do
+          dirStream <- openDirStream (toFilePath x)
+          S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
+            >>= \case
+                  Just _  -> pure $ Just (x </> needle)
+                  Nothing -> go xs
+  isMatch basedir p = do
+    if p == toFilePath needle
+      then isExecutable (basedir </> needle)
+      else pure False

lib/GHCup/Utils/File/Common.hs

@@ -1,120 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE ViewPatterns      #-}
-
-module GHCup.Utils.File.Common where
-
-import           GHCup.Utils.Prelude
-
-import           Control.Monad.Reader
-import           Data.Maybe
-import           Data.Text               ( Text )
-import           Data.Void
-import           GHC.IO.Exception
-import           Optics                  hiding ((<|), (|>))
-import           System.Directory
-import           System.FilePath
-import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
-import           Text.Regex.Posix
-
-import qualified Data.Text                     as T
-import qualified Data.ByteString.Lazy          as BL
-import qualified Text.Megaparsec               as MP
-
-
-
-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
-
-
-
--- | Search for a file in the search paths.
---
--- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
-searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
-searchPath paths needle = go paths
- where
-  go [] = pure Nothing
-  go (x : xs) =
-    hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
-      $ do
-          contents <- listDirectory x
-          findM (isMatch x) contents >>= \case
-            Just _ -> pure $ Just (x </> needle)
-            Nothing -> go xs
-  isMatch basedir p = do
-    if p == needle
-      then isExecutable (basedir </> needle)
-      else pure False
-
-  isExecutable :: FilePath -> IO Bool
-  isExecutable file = executable <$> getPermissions file
-
-
--- | Check wether a binary is shadowed by another one that comes before
--- it in PATH. Returns the path to said binary, if any.
-isShadowed :: FilePath -> IO (Maybe FilePath)
-isShadowed p = do
-  let dir = takeDirectory p
-  let fn = takeFileName p
-  spaths <- liftIO getSearchPath
-  if dir `elem` spaths
-  then do
-    let shadowPaths = takeWhile (/= dir) spaths
-    searchPath shadowPaths fn
-  else pure Nothing
-
-
--- | Check whether the binary is in PATH. This returns only `True`
--- if the directory containing the binary is part of PATH.
-isInPath :: FilePath -> IO Bool
-isInPath p = do
-  let dir = takeDirectory p
-  let fn = takeFileName p
-  spaths <- liftIO getSearchPath
-  if dir `elem` spaths
-  then isJust <$> searchPath [dir] fn
-  else pure False
-
-
-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
-  contents <- listDirectory path
-  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/Utils/File/Common.hs-boot

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

lib/GHCup/Utils/File/Posix.hs

@@ -1,399 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts  #-}
-
-{-|
-Module      : GHCup.Utils.File.Posix
-Description : File and unix APIs
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : POSIX
-
-This module handles file and executable handling.
-Some of these functions use sophisticated logging.
--}
-module GHCup.Utils.File.Posix where
-
-import           GHCup.Utils.File.Common
-import           GHCup.Utils.Prelude
-import           GHCup.Utils.Logger
-import           GHCup.Types
-import           GHCup.Types.Optics
-
-import           Control.Concurrent
-import           Control.Concurrent.Async
-import           Control.Exception              ( evaluate )
-import           Control.Exception.Safe
-import           Control.Monad
-import           Control.Monad.Reader
-import           Control.Monad.Trans.State.Strict
-import           Data.ByteString                ( ByteString )
-import           Data.Foldable
-import           Data.IORef
-import           Data.Sequence                  ( Seq, (|>) )
-import           Data.List
-import           Data.Word8
-import           GHC.IO.Exception
-import           System.Console.Terminal.Common
-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
-
-
-import qualified Control.Exception             as EX
-import qualified Data.Sequence                 as Sq
-import qualified Data.Text                     as T
-import qualified Data.Text.Encoding            as E
-import qualified System.Posix.Process          as SPP
-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
-                                               as SPIB
-
-
-
--- | Execute the given command and collect the stdout, stderr and the exit code.
--- The command is run in a subprocess.
-executeOut :: MonadIO m
-           => FilePath          -- ^ command as filename, e.g. 'ls'
-           -> [String]          -- ^ arguments to the command
-           -> Maybe FilePath    -- ^ chdir to this path
-           -> m CapturedProcess
-executeOut path args chdir = liftIO $ captureOutStreams $ do
-  maybe (pure ()) changeWorkingDirectory chdir
-  SPP.executeFile path True args Nothing
-
-
-execLogged :: ( MonadReader env m
-              , HasSettings env
-              , HasDirs env
-              , MonadIO m
-              , MonadThrow m)
-           => FilePath         -- ^ thing to execute
-           -> [String]         -- ^ args for the thing
-           -> Maybe FilePath   -- ^ optionally chdir into this
-           -> FilePath         -- ^ log filename (opened in append mode)
-           -> Maybe [(String, String)] -- ^ optional environment
-           -> m (Either ProcessError ())
-execLogged exe args chdir lfile env = do
-  Settings {..} <- getSettings
-  Dirs {..} <- getDirs
-  let logfile = logsDir </> lfile <> ".log"
-  liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
-                   closeFd
-                   (action verbose noColor)
- where
-  action verbose no_color fd = do
-    actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-      -- start the thread that logs to stdout
-      pState <- newEmptyMVar
-      done   <- newEmptyMVar
-      void
-        $ forkIO
-        $ EX.handle (\(_ :: IOException) -> pure ())
-        $ EX.finally
-            (if verbose
-              then tee fd stdoutRead
-              else printToRegion fd stdoutRead 6 pState no_color
-            )
-            (putMVar done ())
-
-      -- fork the subprocess
-      pid <- SPP.forkProcess $ do
-        void $ dupTo stdoutWrite stdOutput
-        void $ dupTo stdoutWrite stdError
-        closeFd stdoutRead
-        closeFd stdoutWrite
-
-        -- execute the action
-        maybe (pure ()) changeWorkingDirectory chdir
-        void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
-
-      closeFd stdoutWrite
-
-      -- wait for the subprocess to finish
-      e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
-      putMVar pState (either (const False) (const True) e)
-
-      void $ race (takeMVar done) (threadDelay (1000000 * 3))
-      closeFd stdoutRead
-
-      pure e
-
-  tee :: Fd -> Fd -> IO ()
-  tee fileFd = readTilEOF lineAction
-
-   where
-    lineAction :: ByteString -> IO ()
-    lineAction bs' = do
-      void $ SPIB.fdWrite fileFd (bs' <> "\n")
-      void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-
-  -- Reads fdIn and logs the output in a continous scrolling area
-  -- of 'size' terminal lines. Also writes to a log file.
-  printToRegion :: Fd -> Fd -> Int -> MVar Bool -> Bool -> IO ()
-  printToRegion fileFd fdIn size pState no_color = do
-    -- init region
-    forM_ [1..size] $ \_ -> BS.putStr "\n"
-
-    void $ flip runStateT mempty
-      $ do
-        handle
-          (\(ex :: SomeException) -> do
-            ps <- liftIO $ takeMVar pState
-            when ps (liftIO $ BS.putStr (pos1 <> moveLineUp size <> clearScreen))
-            throw ex
-          ) $ readTilEOF lineAction fdIn
-
-   where
-    clearScreen :: ByteString
-    clearScreen = "\x1b[0J"
-    clearLine :: ByteString
-    clearLine = "\x1b[2K"
-    moveLineUp :: Int -> ByteString
-    moveLineUp n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "A"
-    moveLineDown :: Int -> ByteString
-    moveLineDown n = "\x1b[" <> E.encodeUtf8 (T.pack (show n)) <> "B"
-    pos1 :: ByteString
-    pos1 = "\r"
-    overwriteNthLine :: Int -> ByteString -> ByteString
-    overwriteNthLine n str = pos1 <> moveLineUp n <> clearLine <> str <> moveLineDown n <> pos1
-
-    blue :: ByteString -> ByteString
-    blue bs 
-      | no_color = bs
-      | otherwise = "\x1b[0;34m" <> bs <> "\x1b[0m"
-
-    -- action to perform line by line
-    lineAction :: (MonadMask m, MonadIO m)
-               => ByteString
-               -> StateT (Seq ByteString) m ()
-    lineAction = \bs' -> do
-      void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
-      modify (swapRegs bs')
-      liftIO TP.size >>= \case
-        Nothing -> pure ()
-        Just (Window _ w) -> do
-          regs <- get
-          liftIO $ forM_ (Sq.zip regs (Sq.fromList [0..(Sq.length regs - 1)])) $ \(bs, i) -> do
-              BS.putStr
-              . overwriteNthLine (size - i)
-              . trim w
-              . blue
-              . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
-              $ bs
-
-    swapRegs :: a -> Seq a -> Seq a
-    swapRegs bs = \regs -> if
-      | Sq.length regs < size -> regs |> bs
-      | otherwise             -> Sq.drop 1 regs |> bs
-
-    -- trim output line to terminal width
-    trim :: Int -> ByteString -> ByteString
-    trim w = \bs -> if
-      | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
-      | otherwise                 -> bs
-
-  -- Consecutively read from Fd in 512 chunks until we hit
-  -- newline or EOF.
-  readLine :: MonadIO m
-           => Fd          -- ^ input file descriptor
-           -> ByteString  -- ^ rest buffer (read across newline)
-           -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
-  readLine fd = go
-   where
-    go inBs = do
-      -- if buffer is not empty, process it first
-      mbs <- if BS.length inBs == 0
-               -- otherwise attempt read
-               then liftIO
-                    $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
-                    $ fmap Just
-                    $ SPIB.fdRead fd 512
-               else pure $ Just inBs
-      case mbs of
-        Nothing -> pure ("", "", True)
-        Just bs -> do
-          -- split on newline
-          let (line, rest) = BS.span (/= _lf) bs
-          if
-            | BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-            -- if rest is empty, then there was no newline, process further
-            | otherwise           -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
-
-  readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
-  readTilEOF ~action' fd' = go mempty
-   where
-    go bs' = do
-      (bs, rest, eof) <- readLine fd' bs'
-      if eof
-         then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
-         else void (action' bs) >> go rest
-
-
--- | Capture the stdout and stderr of the given action, which
--- is run in a subprocess. Stdin is closed. You might want to
--- 'race' this to make sure it terminates.
-captureOutStreams :: IO a
-                     -- ^ the action to execute in a subprocess
-                  -> IO CapturedProcess
-captureOutStreams action = do
-  actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
-    actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
-      pid <- SPP.forkProcess $ do
-        -- dup stdout
-        void $ dupTo childStdoutWrite stdOutput
-        closeFd childStdoutWrite
-        closeFd parentStdoutRead
-
-        -- dup stderr
-        void $ dupTo childStderrWrite stdError
-        closeFd childStderrWrite
-        closeFd parentStderrRead
-
-        -- execute the action
-        a <- action
-        void $ evaluate a
-
-      -- close everything we don't need
-      closeFd childStdoutWrite
-      closeFd childStderrWrite
-
-      -- start thread that writes the output
-      refOut <- newIORef BL.empty
-      refErr <- newIORef BL.empty
-      done   <- newEmptyMVar
-      _      <-
-        forkIO
-        $ EX.handle (\(_ :: IOException) -> pure ())
-        $ flip EX.finally (putMVar done ())
-        $ writeStds parentStdoutRead parentStderrRead refOut refErr
-
-      status <- SPP.getProcessStatus True True pid
-      void $ race (takeMVar done) (threadDelay (1000000 * 3))
-
-      case status of
-        -- readFd will take care of closing the fd
-        Just (SPP.Exited es) -> do
-          stdout' <- readIORef refOut
-          stderr' <- readIORef refErr
-          pure $ CapturedProcess { _exitCode = es
-                                 , _stdOut   = stdout'
-                                 , _stdErr   = stderr'
-                                 }
-
-        _ -> throwIO $ userError ("No such PID " ++ show pid)
-
- where
-  writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
-  writeStds pout perr rout rerr = do
-    doneOut <- newEmptyMVar
-    void
-      $ forkIO
-      $ hideError eofErrorType
-      $ flip EX.finally (putMVar doneOut ())
-      $ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
-    doneErr <- newEmptyMVar
-    void
-      $ forkIO
-      $ hideError eofErrorType
-      $ flip EX.finally (putMVar doneErr ())
-      $ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
-    takeMVar doneOut
-    takeMVar doneErr
-
-  readTilEOF ~action' fd' = do
-    bs <- SPIB.fdRead fd' 512
-    void $ action' bs
-    readTilEOF action' fd'
-
-
-actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
-actionWithPipes a =
-  createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
-
-cleanup :: [Fd] -> IO ()
-cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-
-
-
--- | Create a new regular file in write-only mode. The file must not exist.
-createRegularFileFd :: FileMode -> FilePath -> IO Fd
-createRegularFileFd fm dest =
-  openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
-
-
--- | Thin wrapper around `executeFile`.
-exec :: MonadIO m
-     => String           -- ^ thing to execute
-     -> [String]         -- ^ args for the thing
-     -> Maybe FilePath   -- ^ optionally chdir into this
-     -> Maybe [(String, String)] -- ^ optional environment
-     -> m (Either ProcessError ())
-exec exe args chdir env = liftIO $ do
-  pid <- SPP.forkProcess $ do
-    maybe (pure ()) changeWorkingDirectory chdir
-    SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
-
-  fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
-
-
-toProcessError :: FilePath
-               -> [String]
-               -> Maybe ProcessStatus
-               -> Either ProcessError ()
-toProcessError exe args mps = case mps of
-  Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
-  Just (SPP.Exited ExitSuccess    ) -> Right ()
-  Just (Terminated _ _             ) -> Left $ PTerminated exe args
-  Just (Stopped _                  ) -> Left $ PStopped exe args
-  Nothing                            -> Left $ NoSuchPid exe args
-
-
-
-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/Utils/File/Windows.hs

@@ -1,266 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts  #-}
-
-{-|
-Module      : GHCup.Utils.File.Windows
-Description : File and windows APIs
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : Windows
-
-This module handles file and executable handling.
-Some of these functions use sophisticated logging.
--}
-module GHCup.Utils.File.Windows where
-
-import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
-import           GHCup.Utils.Dirs
-import           GHCup.Utils.File.Common
-import           GHCup.Types
-import           GHCup.Types.Optics
-
-import           Control.Concurrent
-import           Control.DeepSeq
-import           Control.Exception.Safe
-import           Control.Monad
-import           Control.Monad.Reader
-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
-
-
-
-toProcessError :: FilePath
-               -> [FilePath]
-               -> ExitCode
-               -> Either ProcessError ()
-toProcessError exe args exitcode = case exitcode of
-  (ExitFailure xi) -> Left $ NonZeroExit xi exe args
-  ExitSuccess -> Right ()
-
-
--- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it
--- lets you pass 'CreateProcess' giving better flexibility.
---
--- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess
--- record will be ignored.
---
--- @since 1.2.3.0
-readCreateProcessWithExitCodeBS
-    :: CreateProcess
-    -> BL.ByteString
-    -> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr
-readCreateProcessWithExitCodeBS cp input = do
-    let cp_opts = cp {
-                    std_in  = CreatePipe,
-                    std_out = CreatePipe,
-                    std_err = CreatePipe
-                  }
-    withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $
-      \mb_inh mb_outh mb_errh ph ->
-        case (mb_inh, mb_outh, mb_errh) of
-          (Just inh, Just outh, Just errh) -> do
-
-            out <- BS.hGetContents outh
-            err <- BS.hGetContents errh
-
-            -- fork off threads to start consuming stdout & stderr
-            withForkWait  (EX.evaluate $ rnf out) $ \waitOut ->
-             withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do
-
-              -- now write any input
-              unless (BL.null input) $
-                ignoreSigPipe $ BL.hPut inh input
-              -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
-              ignoreSigPipe $ hClose inh
-
-              -- wait on the output
-              waitOut
-              waitErr
-
-              hClose outh
-              hClose errh
-
-            -- wait on the process
-            ex <- waitForProcess ph
-            return (ex, BL.fromStrict out, BL.fromStrict err)
-
-          (Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle."
-          (_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle."
-          (_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle."
- where
-  ignoreSigPipe :: IO () -> IO ()
-  ignoreSigPipe = EX.handle $ \e -> case e of
-                                     IOError { ioe_type  = ResourceVanished
-                                             , ioe_errno = Just ioe }
-                                       | Errno ioe == ePIPE -> return ()
-                                     _ -> throwIO e
-  -- wrapper so we can get exceptions with the appropriate function name.
-  withCreateProcess_
-    :: String
-    -> CreateProcess
-    -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a)
-    -> IO a
-  withCreateProcess_ fun c action =
-      EX.bracketOnError (createProcess_ fun c) cleanupProcess
-                       (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph)
-
--- | Fork a thread while doing something else, but kill it if there's an
--- exception.
---
--- This is important in the cases above because we want to kill the thread
--- that is holding the Handle lock, because when we clean up the process we
--- try to close that handle, which could otherwise deadlock.
---
-withForkWait :: IO () -> (IO () ->  IO a) -> IO a
-withForkWait async' body = do
-  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
-  mask $ \restore -> do
-    tid <- forkIO $ try (restore async') >>= putMVar waitVar
-    let wait' = takeMVar waitVar >>= either throwIO return
-    restore (body wait') `EX.onException` killThread tid
-
-
--- | Execute the given command and collect the stdout, stderr and the exit code.
--- The command is run in a subprocess.
-executeOut :: MonadIO m
-           => FilePath          -- ^ command as filename, e.g. 'ls'
-           -> [String]          -- ^ arguments to the command
-           -> Maybe FilePath    -- ^ chdir to this path
-           -> m CapturedProcess
-executeOut path args chdir = do
-  cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir })
-  (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp ""
-  pure $ CapturedProcess exit out err
-
-
-execLogged :: ( MonadReader env m
-              , HasDirs env
-              , HasSettings env
-              , MonadIO m
-              , MonadThrow m)
-           => FilePath         -- ^ thing to execute
-           -> [String]         -- ^ args for the thing
-           -> Maybe FilePath   -- ^ optionally chdir into this
-           -> FilePath         -- ^ log filename (opened in append mode)
-           -> Maybe [(String, String)] -- ^ optional environment
-           -> m (Either ProcessError ())
-execLogged exe args chdir lfile env = do
-  Dirs {..} <- getDirs
-  let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
-      stderrLogfile = logsDir </> lfile <> ".stderr.log"
-  cp <- createProcessWithMingwPath ((proc exe args)
-    { cwd = chdir
-    , env = env
-    , std_in = CreatePipe
-    , std_out = CreatePipe
-    , std_err = CreatePipe
-    })
-  fmap (toProcessError exe args)
-    $ liftIO
-    $ withCreateProcess cp
-    $ \_ mout merr ph ->
-        case (mout, merr) of
-          (Just cStdout, Just cStderr) -> do
-            withForkWait (tee stdoutLogfile cStdout) $ \waitOut ->
-              withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do
-                waitOut
-                waitErr
-            waitForProcess ph
-          _ -> fail "Could not acquire out/err handle"
-
- where
-  tee :: FilePath -> Handle -> IO ()
-  tee logFile handle' = go
-    where
-      go = do
-        some <- BS.hGetSome handle' 512
-        if BS.null some
-          then pure ()
-          else do
-            void $ BS.appendFile logFile some
-            void $ BS.hPut stdout some
-            go
-        
-
--- | Thin wrapper around `executeFile`.
-exec :: MonadIO m
-     => FilePath       -- ^ thing to execute
-     -> [FilePath]     -- ^ args for the thing
-     -> Maybe FilePath   -- ^ optionally chdir into this
-     -> Maybe [(String, String)] -- ^ optional environment
-     -> m (Either ProcessError ())
-exec exe args chdir env = do
-  cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env })
-  exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
-  pure $ toProcessError exe args exit_code
-
-
--- | Thin wrapper around `executeFile`.
-execShell :: MonadIO m
-          => FilePath       -- ^ thing to execute
-          -> [FilePath]     -- ^ args for the thing
-          -> Maybe FilePath   -- ^ optionally chdir into this
-          -> Maybe [(String, String)] -- ^ optional environment
-          -> m (Either ProcessError ())
-execShell exe args chdir env = do
-  let cmd = exe <> " " <> concatMap (' ':) args
-  cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env })
-  exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p
-  pure $ toProcessError cmd [] exit_code
-
-
-chmod_755 :: MonadIO m => FilePath -> m ()
-chmod_755 fp =
-  let perm = setOwnerWritable True emptyPermissions
-  in liftIO $ setPermissions fp perm
-
-
-createProcessWithMingwPath :: MonadIO m
-                          => CreateProcess
-                          -> m CreateProcess
-createProcessWithMingwPath cp = do
-  msys2Dir <- liftIO ghcupMsys2Dir
-  cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp)
-  let mingWPaths = [msys2Dir </> "usr" </> "bin"
-                   ,msys2Dir </> "mingw64" </> "bin"]
-      paths = ["PATH", "Path"]
-      curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths
-      newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths)
-      envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths
-      envWithNewPath = Map.insert "Path" newPath envWithoutPath
-  liftIO $ setEnv "Path" newPath
-  pure $ cp { env = Just $ Map.toList envWithNewPath }
-
-ghcupMsys2Dir :: IO FilePath
-ghcupMsys2Dir =
-  lookupEnv "GHCUP_MSYS2" >>= \case
-    Just fp -> pure fp
-    Nothing -> do
-      baseDir <- liftIO ghcupBaseDir
-      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/Utils/Logger.hs

@@ -1,131 +1,60 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE QuasiQuotes      #-}
-{-# LANGUAGE DataKinds        #-}
-{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE QuasiQuotes           #-}
 
-{-|
-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.Utils.Logger where
 
-import           GHCup.Types
-import           GHCup.Types.Optics
-import {-# SOURCE #-} GHCup.Utils.File.Common
-import           GHCup.Utils.String.QQ
+import           GHCup.Utils
 
-import           Control.Exception.Safe
 import           Control.Monad
-import           Control.Monad.IO.Class
-import           Control.Monad.Reader
-import           Data.Text               ( Text )
-import           Optics
+import           Control.Monad.Logger
+import           HPath
+import           HPath.IO
 import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
-import           System.FilePath
 import           System.IO.Error
-import           Text.Regex.Posix
 
 import qualified Data.ByteString               as B
-import GHCup.Utils.Prelude
-import qualified Data.Text                     as T
-
-logInfo :: ( MonadReader env m
-           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-           , MonadIO m
-           )
-        => Text
-        -> m ()
-logInfo = logInternal Info
-
-logWarn :: ( MonadReader env m
-           , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-           , MonadIO m
-           )
-        => Text
-        -> m ()
-logWarn = logInternal Warn
-
-logDebug :: ( MonadReader env m
-            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-            , MonadIO m
-            )
-         => Text
-         -> m ()
-logDebug = logInternal Debug
-
-logError :: ( MonadReader env m
-            , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-            , MonadIO m
-            )
-         => Text
-         -> m ()
-logError = logInternal Error
 
 
-logInternal :: ( MonadReader env m
-               , LabelOptic' "loggerConfig" A_Lens env LoggerConfig
-               , MonadIO m
-               ) => LogLevel
-                 -> Text
-                 -> m ()
-logInternal logLevel msg = do
-  LoggerConfig {..} <- gets @"loggerConfig"
-  let color' c = if fancyColors then color c else id
-  let style' = case logLevel of
-        Debug   -> style Bold . color' Blue
-        Info    -> style Bold . color' Green
-        Warn    -> style Bold . color' Yellow
-        Error   -> style Bold . color' Red
-  let l = case logLevel of
-        Debug   -> style' "[ Debug ]"
-        Info    -> style' "[ Info  ]"
-        Warn    -> style' "[ Warn  ]"
-        Error   -> style' "[ Error ]"
-  let strs = T.split (== '\n') msg
-  let out = case strs of
-              [] -> T.empty
-              (x:xs) -> 
-                  foldr (\a b -> a <> "\n" <> b) mempty
-                . ((l <> " " <> x) :)
-                . fmap (\line' -> style' "[ ...   ] " <> line' )
-                $ xs
-
-  when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
-    $ liftIO $ consoleOutter out
-
-  -- raw output
-  let lr = case logLevel of
-        Debug   -> "Debug:"
-        Info    -> "Info:"
-        Warn    -> "Warn:"
-        Error   -> "Error:"
-  let outr = lr <> " " <> msg <> "\n"
-  liftIO $ fileOutter outr
+data LoggerConfig = LoggerConfig
+  { lcPrintDebug :: Bool                  -- ^ whether to print debug in colorOutter
+  , colorOutter  :: B.ByteString -> IO () -- ^ how to write the color output
+  , rawOutter    :: B.ByteString -> IO () -- ^ how to write the full raw output
+  }
 
 
-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 </>)
+myLoggerT :: LoggerConfig -> LoggingT m a -> m a
+myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
+ where
+  mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+  mylogger _ _ level str' = do
+    -- color output
+    let l = case level of
+          LevelDebug   -> toLogStr (style Bold $ color Blue "[ Debug ]")
+          LevelInfo    -> toLogStr (style Bold $ color Green "[ Info  ]")
+          LevelWarn    -> toLogStr (style Bold $ color Yellow "[ Warn  ]")
+          LevelError   -> toLogStr (style Bold $ color Red "[ Error ]")
+          LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
+    let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
 
-  liftIO $ writeFile logfile ""
+    when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
+      $ colorOutter out
+
+    -- raw output
+    let lr = case level of
+          LevelDebug   -> toLogStr "Debug: "
+          LevelInfo    -> toLogStr "Info:"
+          LevelWarn    -> toLogStr "Warn:"
+          LevelError   -> toLogStr "Error:"
+          LevelOther t -> toLogStr t <> toLogStr ":"
+    let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
+    rawOutter outr
+
+
+initGHCupFileLogging :: Path Rel -> IO (Path Abs)
+initGHCupFileLogging context = do
+  logs <- ghcupLogsDir
+  let logfile = logs </> context
+  createDirIfMissing newDirPerms logs
+  hideError doesNotExistErrorType $ deleteFile logfile
+  createRegularFile newFilePerms logfile
   pure logfile

lib/GHCup/Utils/Logger.hs-boot

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

lib/GHCup/Utils/MegaParsec.hs

@@ -1,124 +0,0 @@
-{-# LANGUAGE CPP                  #-}
-{-# LANGUAGE OverloadedStrings    #-}
-
-{-|
-Module      : GHCup.Utils.MegaParsec
-Description : MegaParsec utilities
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
-module GHCup.Utils.MegaParsec where
-
-import           GHCup.Types
-
-import           Control.Applicative
-#if !MIN_VERSION_base(4,13,0)
-import           Control.Monad.Fail             ( MonadFail )
-#endif
-import           Data.Functor
-import           Data.Maybe
-import           Data.Text                      ( Text )
-import           Data.Versions
-import           Data.Void
-import           System.FilePath
-
-import qualified Data.List.NonEmpty            as NE
-import qualified Data.Text                     as T
-import qualified Text.Megaparsec               as MP
-
-
-choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
-choice' []       = fail "Empty list"
-choice' [x     ] = x
-choice' (x : xs) = MP.try x <|> choice' xs
-
-
-parseUntil :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
-parseUntil p = do
-  (MP.try (MP.lookAhead p) $> mempty)
-    <|> (do
-          c  <- T.singleton <$> MP.anySingle
-          c2 <- parseUntil p
-          pure (c `mappend` c2)
-        )
-
-parseUntil1 :: MP.Parsec Void Text a -> MP.Parsec Void Text Text
-parseUntil1 p = do
-  i1 <- MP.getOffset
-  t <- parseUntil p
-  i2 <- MP.getOffset
-  if i1 == i2 then fail "empty parse" else pure t
-
-
-
--- | Parses e.g.
---   * armv7-unknown-linux-gnueabihf-ghc
---   * armv7-unknown-linux-gnueabihf-ghci
-ghcTargetBinP :: Text -> MP.Parsec Void Text (Maybe Text, Text)
-ghcTargetBinP t =
-  (,)
-    <$> (   MP.try
-            (Just <$> parseUntil1 (MP.chunk "-" *> MP.chunk t) <* MP.chunk "-"
-            )
-        <|> ((\ _ x -> x) Nothing <$> mempty)
-        )
-    <*> (MP.chunk t <* MP.eof)
-
-
--- | Extracts the version from @ProjectVersion="8.10.5"@.
-ghcProjectVersion :: MP.Parsec Void Text Version
-ghcProjectVersion = do
-  _ <- MP.chunk "ProjectVersion=\""
-  ver <- parseUntil1 $ MP.chunk "\""
-  MP.setInput ver
-  version'
-
-
--- | Extracts target triple and version from e.g.
---   * armv7-unknown-linux-gnueabihf-8.8.3
---   * armv7-unknown-linux-gnueabihf-8.8.3
-ghcTargetVerP :: MP.Parsec Void Text GHCTargetVersion
-ghcTargetVerP =
-  (\x y -> GHCTargetVersion x y)
-    <$> (MP.try (Just <$> parseUntil1 (MP.chunk "-" *> verP') <* MP.chunk "-")
-        <|> ((\ _ x -> x) Nothing <$> mempty)
-        )
-    <*> (version' <* MP.eof)
- where
-  verP' :: MP.Parsec Void Text Text
-  verP' = do
-    v <- version'
-    let startsWithDigists =
-          and
-            . take 3
-            . concatMap
-              (map
-                (\case
-                  (Digits _) -> True
-                  (Str    _) -> False
-                ) . NE.toList)
-            . NE.toList
-            $ _vChunks v
-    if startsWithDigists && isNothing (_vEpoch v)
-      then pure $ prettyVer v
-      else fail "Oh"
-
-
-verP :: MP.Parsec Void Text Text -> MP.Parsec Void Text Versioning
-verP suffix = do
-  ver <- parseUntil suffix
-  if T.null ver
-    then fail "empty version"
-    else do
-      rest <- MP.getInput
-      MP.setInput ver
-      v <- versioning'
-      MP.setInput rest
-      pure v
-
-
-pathSep :: MP.Parsec Void Text Char
-pathSep = MP.oneOf pathSeparators

lib/GHCup/Utils/Prelude.hs

@@ -1,67 +1,32 @@
-{-# LANGUAGE CPP                 #-}
 {-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveLift          #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
 
-{-|
-Module      : GHCup.Utils.Prelude
-Description : MegaParsec utilities
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
-
-GHCup specific prelude. Lots of Excepts functionality.
--}
 module GHCup.Utils.Prelude where
 
-#if defined(IS_WINDOWS)
-import           GHCup.Types
-#endif
-import           GHCup.Errors
-import           GHCup.Types.Optics
-import {-# SOURCE #-} GHCup.Utils.Logger
-
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
-import           Control.Monad.Reader
+import           Control.Monad.Trans.Class      ( lift )
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub, intercalate, stripPrefix, isPrefixOf, dropWhileEnd )
-import           Data.Maybe
-import           Data.Foldable
-import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
 import           Data.String
 import           Data.Text                      ( Text )
 import           Data.Versions
-import           Data.Word8                  hiding ( isDigit )
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
-import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
 import           System.IO.Error
-#if defined(IS_WINDOWS)
-import           System.IO.Temp
-#endif
-import           System.IO.Unsafe
-import           System.Directory
-import           System.FilePath
+import           System.Posix.Env.ByteString    ( getEnvironment )
 
-#if defined(IS_WINDOWS)
-import           Control.Retry
-import           GHC.IO.Exception
-#endif
-
-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
@@ -69,20 +34,8 @@ 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
-#if defined(IS_WINDOWS)
-import qualified System.Win32.File             as Win32
-#endif
 
 
--- $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
@@ -165,7 +118,7 @@ lE' :: forall e' e es a m
     => (e' -> e)
     -> Either e' a
     -> Excepts es m a
-lE' f = liftE . veitherToExcepts . fromEither . first f
+lE' f = liftE . veitherToExcepts . fromEither . bimap f id
 
 lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
 lEM em = lift em >>= lE
@@ -175,15 +128,7 @@ lEM' :: forall e' e es a m
      => (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)
-                             , MonadReader env m
-                             , HasLog env
-                             , MonadIO m
-                             , Monad m) => Excepts es m () -> Excepts '[] m ()
-catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
+lEM' f em = lift em >>= lE . bimap f id
 
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
@@ -220,19 +165,14 @@ liftIOException errType ex =
     . 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 :: [IOErrorType] -> a -> IO a -> IO a
 hideErrorDef errs def =
-  handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else liftIO $ ioError e)
+  handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)
 
 
-hideErrorDefM :: (MonadIO m, MonadCatch m) => [IOErrorType] -> m a -> m a -> m a
+hideErrorDefM :: [IOErrorType] -> IO a -> IO a -> IO a
 hideErrorDefM errs def =
-  handleIO (\e -> if ioeGetErrorType e `elem` errs then def else liftIO $ ioError e)
+  handleIO (\e -> if ioeGetErrorType e `elem` errs then def else ioError e)
 
 
 -- TODO: does this work?
@@ -242,8 +182,8 @@ hideExcept :: forall e es es' a m
            -> a
            -> Excepts es m a
            -> Excepts es' m a
-hideExcept _ a =
-  catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a))
+hideExcept _ a action =
+  catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
 
 
 hideExcept' :: forall e es es' m
@@ -251,8 +191,8 @@ hideExcept' :: forall e es es' m
             => e
             -> Excepts es m ()
             -> Excepts es' m ()
-hideExcept' _ =
-  catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ()))
+hideExcept' _ action =
+  catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
 
 
 reThrowAll :: forall e es es' a m
@@ -278,17 +218,9 @@ throwEither a = case a of
   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
-
-
 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
@@ -299,28 +231,20 @@ removeLensFieldLabel str' =
   maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
 
 
-pvpToVersion :: MonadThrow m => PVP -> m Version
+addToCurrentEnv :: MonadIO m
+                => [(ByteString, ByteString)]
+                -> m [(ByteString, ByteString)]
+addToCurrentEnv adds = do
+  cEnv <- liftIO $ getEnvironment
+  pure (adds ++ cEnv)
+
+
+pvpToVersion :: PVP -> Version
 pvpToVersion =
-  either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . prettyPVP
+  either (\_ -> error "Couldn't convert PVP to Version") id
+    . version
+    . prettyPVP
 
-versionToPVP :: MonadThrow m => Version -> m PVP
-versionToPVP v = either (\_ -> alternative v) pure . 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)
-
-  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.
@@ -329,418 +253,3 @@ 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 = do
-#if defined(IS_WINDOWS)
-  Dirs { recycleDir } <- getDirs
-  tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
-  let dest = tmp </> takeFileName fp
-  liftIO (Win32.moveFileEx fp (Just dest) 0)
-      `catch`
-      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
-      `finally`
-        (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-#else
-  liftIO $ removePathForcibly fp
-#endif
-
-
-rmPathForcibly :: ( MonadIO m
-                  , MonadMask m
-                  )
-               => FilePath
-               -> m ()
-rmPathForcibly fp =
-#if defined(IS_WINDOWS)
-  recover (liftIO $ removePathForcibly fp)
-#else
-  liftIO $ removePathForcibly fp
-#endif
-
-
-rmDirectory :: (MonadIO m, MonadMask m)
-            => FilePath
-            -> m ()
-rmDirectory fp =
-#if defined(IS_WINDOWS)
-  recover (liftIO $ removeDirectory fp)
-#else
-  liftIO $ removeDirectory fp
-#endif
-
-
--- 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 = do
-#if defined(IS_WINDOWS)
-  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 (Win32.moveFileEx fp (Just dest) 0)
-    `catch`
-      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
-    `finally`
-      (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-#else
-  liftIO $ removeFile fp
-#endif
-
-
-rmFile :: ( MonadIO m
-          , MonadMask m
-          )
-      => FilePath
-      -> m ()
-rmFile fp =
-#if defined(IS_WINDOWS)
-  recover (liftIO $ removeFile fp)
-#else
-  liftIO $ removeFile fp
-#endif
-
-
-rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
-                => FilePath
-                -> m ()
-rmDirectoryLink fp = 
-#if defined(IS_WINDOWS)
-  recover (liftIO $ removeDirectoryLink fp)
-#else
-  liftIO $ removeDirectoryLink fp
-#endif
-
-
-#if defined(IS_WINDOWS)
-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)
-#endif
-
-
-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/Utils/String/QQ.hs

@@ -1,35 +1,25 @@
 {-# LANGUAGE TemplateHaskell #-}
 
-{-|
-Module      : GHCup.Utils.String.QQ
-Description : String quasi quoters
-Copyright   : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufell@posteo.de> 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
-
-QuasiQuoter for non-interpolated strings, texts and bytestrings.
-
-The "s" quoter contains a multi-line string with no interpolation at all,
-except that the leading newline is trimmed and carriage returns stripped.
-
-@
-{-\# LANGUAGE QuasiQuotes #-}
-import Data.Text (Text)
-import Data.String.QQ
-foo :: Text -- "String", "ByteString" etc also works
-foo = [s|
-Well here is a
-    multi-line string!
-|]
-@
-
-Any instance of the IsString type is permitted.
-
-(For GHC versions 6, write "[$s||]" instead of "[s||]".)
-
--}
+-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
+--
+-- The "s" quoter contains a multi-line string with no interpolation at all,
+-- except that the leading newline is trimmed and carriage returns stripped.
+--
+-- @
+-- {-\# LANGUAGE QuasiQuotes #-}
+-- import Data.Text (Text)
+-- import Data.String.QQ
+-- foo :: Text -- "String", "ByteString" etc also works
+-- foo = [s|
+-- Well here is a
+--     multi-line string!
+-- |]
+-- @
+--
+-- Any instance of the IsString type is permitted.
+--
+-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
+--
 module GHCup.Utils.String.QQ
   ( s
   )
@@ -44,14 +34,15 @@ import           Language.Haskell.TH.Quote
 -- The pattern portion is undefined.
 s :: QuasiQuoter
 s = QuasiQuoter
-  (\s' -> case all isAscii s' of
+  (\s' -> case and $ fmap isAscii s' of
     True  -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
     False -> fail "Not ascii"
   )
-  (error "Cannot use s as a pattern")
-  (error "Cannot use s as a type")
-  (error "Cannot use s as a dec")
+  (error "Cannot use q as a pattern")
+  (error "Cannot use q as a type")
+  (error "Cannot use q as a dec")
  where
   removeCRs = filter (/= '\r')
   trimLeadingNewline ('\n' : xs) = xs
   trimLeadingNewline xs          = xs
+

lib/GHCup/Utils/Version/QQ.hs

@@ -7,15 +7,6 @@
 {-# LANGUAGE TemplateHaskell    #-}
 
 
-{-|
-Module      : GHCup.Utils.Version.QQ
-Description : Version quasi-quoters
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
 module GHCup.Utils.Version.QQ where
 
 import           Data.Data
@@ -42,8 +33,6 @@ deriving instance Data SemVer
 deriving instance Lift SemVer
 deriving instance Data Mess
 deriving instance Lift Mess
-deriving instance Data MChunk
-deriving instance Lift MChunk
 deriving instance Data PVP
 deriving instance Lift PVP
 deriving instance Lift VSep
@@ -53,11 +42,12 @@ deriving instance Data VUnit
 
 #if !MIN_VERSION_base(4,13,0)
 deriving instance Lift (NonEmpty Word)
+instance Lift Text
 #endif
 
 qq :: (Text -> Q Exp) -> QuasiQuoter
 qq quoteExp' = QuasiQuoter
-  { quoteExp  = \s -> quoteExp' . T.pack $ s
+  { quoteExp  = (\s -> quoteExp' . T.pack $ s)
   , quotePat  = \_ ->
     fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
   , quoteType = \_ ->
@@ -101,4 +91,4 @@ liftText :: T.Text -> Q Exp
 liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
 
 liftDataWithText :: Data a => a -> Q Exp
-liftDataWithText = dataToExpQ (fmap liftText . cast)
+liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)

lib/GHCup/Version.hs

@@ -1,52 +1,22 @@
 {-# LANGUAGE QuasiQuotes       #-}
 
 
-{-|
-Module      : GHCup.Version
-Description : Version information and version handling.
-Copyright   : (c) Julian Ospald, 2020
-License     : LGPL-3.0
-Maintainer  : hasufell@hasufell.de
-Stability   : experimental
-Portability : portable
--}
 module GHCup.Version where
 
-import           GHCup.Types
-import           Paths_ghcup (version)
+import           GHCup.Utils.Version.QQ
 
-import           Data.Version (Version(versionBranch))
-import           Data.Versions hiding (version)
+import           Data.Versions
 import           URI.ByteString
 import           URI.ByteString.QQ
 
-import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
 
--- | This reflects the API version of the YAML.
---
--- Note that when updating this, CI requires that the file exsists AND the same file exists at
--- 'https://www.haskell.org/ghcup/exp/ghcup-<ver>.yaml' with some newlines added.
+-- | This reflects the API version of the JSON.
 ghcupURL :: URI
-ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.6.yaml|]
+ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
 
--- | The current ghcup version.
 ghcUpVer :: PVP
-ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version
+ghcUpVer = [pver|0.1.4|]
 
--- | ghcup version as numeric string.
 numericVer :: String
 numericVer = T.unpack . prettyPVP $ ghcUpVer
-
-versionCmp :: Versioning -> VersionCmp -> Bool
-versionCmp ver1 (VR_gt ver2)   = ver1 > ver2
-versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2
-versionCmp ver1 (VR_lt ver2)   = ver1 < ver2
-versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2
-versionCmp ver1 (VR_eq ver2)   = ver1 == ver2
-
-versionRange :: Versioning -> VersionRange -> Bool
-versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps
-versionRange ver' (OrRange cmps range) = 
-  versionRange ver' (SimpleRange cmps) || versionRange ver' range
-

lib/System/Console/Terminal/Common.hs

@@ -1,43 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveTraversable #-}
-
-#if __GLASGOW_HASKELL__ >= 702
-#define LANGUAGE_DeriveGeneric
-{-# LANGUAGE DeriveGeneric #-}
-#endif
-
-module System.Console.Terminal.Common
-  ( Window(..)
-  ) where
-
-import Data.Data (Typeable, Data)
-
-#if __GLASGOW_HASKELL__ < 710
-import Data.Foldable (Foldable)
-import Data.Traversable (Traversable)
-#endif
-
-#ifdef LANGUAGE_DeriveGeneric
-import GHC.Generics
-  ( Generic
-#if __GLASGOW_HASKELL__ >= 706
-  , Generic1
-#endif
-  )
-#endif
-
--- | Terminal window width and height
-data Window a = Window
-  { height :: !a
-  , width  :: !a
-  } deriving
-    ( Show, Eq, Read, Data, Typeable
-    , Foldable, Functor, Traversable
-#ifdef LANGUAGE_DeriveGeneric
-    , Generic
-#if __GLASGOW_HASKELL__ >= 706
-    , Generic1
-#endif
-#endif
-    )

lib/System/Console/Terminal/Posix.hsc

@@ -1,65 +0,0 @@
-{-# LANGUAGE CApiFFI #-}
-
-module System.Console.Terminal.Posix
-  ( size, fdSize, hSize
-  ) where
-
-import System.Console.Terminal.Common
-import Control.Exception (catch)
-import Data.Typeable (cast)
-import Foreign
-import Foreign.C.Error
-import Foreign.C.Types
-import GHC.IO.FD (FD(FD, fdFD))
-import GHC.IO.Handle.Internals (withHandle_)
-import GHC.IO.Handle.Types (Handle, Handle__(Handle__, haDevice))
-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 706)
-import Prelude hiding (catch)
-#endif
-import System.Posix.Types (Fd(Fd))
-
-#include <sys/ioctl.h>
-#include <unistd.h>
-
-
-#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
-
-
--- Interesting part of @struct winsize@
-data CWin = CWin CUShort CUShort
-
-instance Storable CWin where
-  sizeOf _ = (#size struct winsize)
-  alignment _ = (#alignment struct winsize)
-  peek ptr = do
-    row <- (#peek struct winsize, ws_row) ptr
-    col <- (#peek struct winsize, ws_col) ptr
-    return $ CWin row col
-  poke ptr (CWin row col) = do
-    (#poke struct winsize, ws_row) ptr row
-    (#poke struct winsize, ws_col) ptr col
-
-
-fdSize :: Integral n => Fd -> IO (Maybe (Window n))
-fdSize (Fd fd) = with (CWin 0 0) $ \ws -> do
-  _ <- throwErrnoIfMinus1 "ioctl" $
-    ioctl fd (#const TIOCGWINSZ) ws
-  CWin row col <- peek ws
-  return . Just $ Window (fromIntegral row) (fromIntegral col)
- `catch`
-  handler
- where
-  handler :: IOError -> IO (Maybe (Window h))
-  handler _ = return Nothing
-
-foreign import capi "sys/ioctl.h ioctl"
-  ioctl :: CInt -> CULong -> Ptr CWin -> IO CInt
-
-size :: Integral n => IO (Maybe (Window n))
-size = fdSize (Fd (#const STDOUT_FILENO))
-
-hSize :: Integral n => Handle -> IO (Maybe (Window n))
-hSize h = withHandle_ "hSize" h $ \Handle__ { haDevice = dev } ->
-  case cast dev of
-    Nothing -> return Nothing
-    Just FD { fdFD = fd } -> fdSize (Fd fd)

scoop-better-shimexe/LICENSE-MIT

@@ -1,9 +0,0 @@
-MIT License
-
-Copyright (c) 2019 Grégoire Geis
-
-Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:
-
-The above copyright notice and this permission notice (including the next paragraph) shall be included in all copies or substantial portions of the Software.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

scoop-better-shimexe/LICENSE-UNLICENSE

@@ -1,10 +0,0 @@
-This is free and unencumbered software released into the public domain.
-
-Anyone is free to copy, modify, publish, use, compile, sell, or distribute this software, either in source code form or as a compiled binary, for any purpose, commercial or non-commercial, and by any means.
-
-In jurisdictions that recognize copyright laws, the author or authors of this software dedicate any and all copyright interest in the software to the public domain. We make this dedication for the benefit of the public at large and to the detriment of our heirs and 
-successors. We intend this dedication to be an overt act of relinquishment in perpetuity of all present and future rights to this software under copyright law.
-
-THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
-
-For more information, please refer to <http://unlicense.org/>

scoop-better-shimexe/README.md

@@ -1,71 +0,0 @@
-# `shim.c`
-
-[`shim.c`](./shim.c) is a simple Windows program that, when started:
-1. Looks for a file with the exact same name as the running program, but with
-   the extension `shim` (e.g. `C:\bin\foo.exe` will read the file `C:\bin\foo.shim`).
-2. Reads and [parses](#shim-format) the files into a
-   [Scoop](https://github.com/lukesampson/scoop) shim format.
-3. Executes the target executable with the given arguments.
-
-`shim.c` was originally made to replace [Scoop](https://github.com/lukesampson/scoop)'s
-[`shim.cs`](https://github.com/lukesampson/scoop/blob/96de9c14bb483f9278e4b0a9e22b1923ee752901/supporting/shimexe/shim.cs)
-since it had several important flaws:
-1. [It was made in C#](https://github.com/lukesampson/scoop/tree/96de9c14bb483f9278e4b0a9e22b1923ee752901/supporting/shimexe),
-   and thus required an instantiation of a .NET command line app everytime it was started,
-   which can make a command run much slower than if it had been ran directly;
-2. [It](https://github.com/lukesampson/scoop/issues/2339) [did](https://github.com/lukesampson/scoop/issues/1896)
-   [not](https://github.com/felixse/FluentTerminal/issues/221) handle Ctrl+C and other
-   signals correctly, which could be quite infuriating (and essentially killing REPLs and long-running apps).
-
-[`shim.c`](./shim.c) is:
-- **Faster**, because it does not use the .NET Framework, and parses the `.shim` file in a simpler way.
-- **More efficient**, because by the time the target of the shim is started, all allocated memory will have been freed.
-- And more importantly, it **works better**:
-  - Signals originating from pressing `Ctrl+C` are ignored, and therefore handled directly by the spawned child.
-    Your processes and REPLs will no longer close when pressing `Ctrl+C`.
-  - Children are automatically killed when the shim process is killed. No more orphaned processes and weird behaviors.
-
-> **Note**: This project is not affiliated with [Scoop](https://github.com/lukesampson/scoop).
-
-
-## Installation for Scoop
-
-- In a Visual Studio command prompt, run `cl /O1 shim.c`.
-- Replace any `.exe` in `scoop\shims` by `shim.exe`.
-
-An additional script, `repshims.bat`, is provided. It will replace all `.exe`s in the user's Scoop directory
-by `shim.exe`.
-
-
-## Example
-
-Given the following shim `gs.shim`:
-```
-path = C:\Program Files\Git\git.exe
-args = status -u
-```
-
-In this directory, where `gs.exe` is the compiled `shim.c`:
-```
-C:\Bin\
-   gs.exe
-   gs.shim
-```
-
-Then calling `gs -s` will run the program `C:\Program Files\Git\git.exe status -u -s`.
-
-
-## Shim format
-
-Shims follow the same format as Scoop's shims: line-separated `key = value` pairs.
-```
-path = C:\Program Files\Git\git.exe
-args = status -uno
-```
-
-`path` is a required value, but `args` can be omitted. Also, do note that lines **must** end with a line feed.
-
-
-## License
-
-`SPDX-License-Identifier: MIT OR Unlicense`

scoop-better-shimexe/repshims.bat

@@ -1,15 +0,0 @@
-@echo off
-
-if not defined SCOOP set SCOOP=%USERPROFILE%\scoop
-
-for %%x in ("%SCOOP%\shims\*.exe") do (
-  echo Replacing %%x by new shim.
-  copy /B /Y shim.exe "%%~x" >NUL
-)
-
-if not defined SCOOP_GLOBAL set SCOOP_GLOBAL=%ProgramData%\scoop
-
-for %%x in ("%SCOOP_GLOBAL%\shims\*.exe") do (
-  echo Replacing %%x by new shim.
-  copy /B /Y shim.exe "%%~x" >NUL
-)

scoop-better-shimexe/shim.c

@@ -1,256 +0,0 @@
-#pragma comment(lib, "SHELL32.LIB")
-
-#include <stdio.h>
-#include <stdlib.h>
-#include <wchar.h>
-#include <Windows.h>
-
-#ifndef ERROR_ELEVATION_REQUIRED
-#  define ERROR_ELEVATION_REQUIRED 740
-#endif
-
-#define MAX_FILENAME_SIZE 512
-
-BOOL WINAPI ctrlhandler(DWORD fdwCtrlType)
-{
-  switch (fdwCtrlType) {
-    // Ignore all events, and let the child process
-    // handle them.
-    case CTRL_C_EVENT:
-    case CTRL_CLOSE_EVENT:
-    case CTRL_LOGOFF_EVENT:
-    case CTRL_BREAK_EVENT:
-    case CTRL_SHUTDOWN_EVENT:
-      return TRUE;
-
-    default:
-      return FALSE;
-  }
-}
-
-int compute_program_length(const wchar_t* commandline)
-{
-  int i = 0;
-
-  if (commandline[0] == L'"') {
-    // Wait till end of string
-    i++;
-
-    for (;;) {
-      wchar_t c = commandline[i++];
-
-      if (c == 0)
-        return i - 1;
-      else if (c == L'\\')
-        i++;
-      else if (c == L'"')
-        return i;
-    }
-  } else {
-    for (;;) {
-      wchar_t c = commandline[i++];
-
-      if (c == 0)
-        return i - 1;
-      else if (c == L'\\')
-        i++;
-      else if (c == L' ')
-        return i;
-    }
-  }
-}
-
-int main()
-{
-  DWORD exit_code = 0;
-
-  wchar_t* path = NULL;
-  wchar_t* args = NULL;
-  wchar_t* cmd = NULL;
-
-  // Find filename of current executable.
-  wchar_t filename[MAX_FILENAME_SIZE + 2];
-  const unsigned int filename_size = GetModuleFileNameW(NULL, filename, MAX_FILENAME_SIZE);
-
-  if (filename_size >= MAX_FILENAME_SIZE) {
-    fprintf(stderr, "The filename of the program is too long to handle.\n");
-
-    exit_code = 1;
-    goto cleanup;
-  }
-
-  // Use filename of current executable to find .shim
-  filename[filename_size - 3] = L's';
-  filename[filename_size - 2] = L'h';
-  filename[filename_size - 1] = L'i';
-  filename[filename_size - 0] = L'm';
-  filename[filename_size + 1] =  0 ;
-
-  FILE* shim_file;
-
-  if ((shim_file = _wfsopen(filename, L"r,ccs=UTF-8", _SH_DENYNO)) == NULL) {
-    fprintf(stderr, "Cannot open shim file for read.\n");
-
-    exit_code = 1;
-    goto cleanup;
-  }
-
-  size_t command_length = 256;
-  size_t path_length;
-  size_t args_length;
-
-  // Read shim
-  wchar_t linebuf[8192];
-
-  for (;;) {
-    const wchar_t* line = fgetws(linebuf, 8192, shim_file);
-
-    if (line == NULL)
-      break;
-
-    if (line[4] != L' ' || line[5] != L'=' || line[6] != L' ')
-      continue;
-
-    const int linelen = wcslen(line);
-    const int len = linelen - 8 + (line[linelen - 1] != '\n');
-
-    if (line[0] == L'p' && line[1] == L'a' && line[2] == L't' && line[3] == L'h') {
-      // Reading path
-      path = calloc(len + 1, sizeof(wchar_t));
-      wmemcpy(path, line + 7, len);
-
-      command_length += len;
-      path_length = len;
-
-      continue;
-    }
-
-    if (line[0] == L'a' && line[1] == L'r' && line[2] == L'g' && line[3] == L's') {
-      // Reading args
-      args = calloc(len + 1, sizeof(wchar_t));
-      wmemcpy(args, line + 7, len);
-
-      command_length += len + 1;
-      args_length = len;
-
-      continue;
-    }
-
-    continue;
-  }
-
-  fclose(shim_file);
-
-  if (path == NULL) {
-    fprintf(stderr, "Could not read shim file.\n");
-
-    exit_code = 1;
-    goto cleanup;
-  }
-
-  // Find length of command to run
-  wchar_t* given_cmd = GetCommandLineW();
-  const int program_length = compute_program_length(given_cmd);
-
-  given_cmd += program_length;
-
-  const int given_length = wcslen(given_cmd);
-
-  command_length += given_length;
-
-  // Start building command to run, using '[path] [args]', as given by shim.
-  cmd = calloc(command_length, sizeof(wchar_t));
-  int cmd_i = 0;
-
-  wmemcpy(cmd, path, path_length);
-  cmd[path_length] = ' ';
-  cmd_i += path_length + 1;
-
-  if (args != NULL) {
-    wmemcpy(cmd + path_length + 1, args, args_length);
-    cmd[path_length + args_length + 1] = ' ';
-    cmd_i += args_length + 1;
-  }
-
-  // Copy all given arguments to command
-  wmemcpy(cmd + cmd_i, given_cmd, given_length);
-
-  // Find out if the target program is a console app
-  SHFILEINFOW sfi = {0};
-  const BOOL is_windows_app = HIWORD(SHGetFileInfoW(path, -1, &sfi, sizeof(sfi), SHGFI_EXETYPE));
-
-  if (is_windows_app)
-    // Unfortunately, this technique will still show a window for a fraction of time,
-    // but there's just no workaround.
-    FreeConsole();
-
-  // Create job object, which can be attached to child processes
-  // to make sure they terminate when the parent terminates as well.
-  JOBOBJECT_EXTENDED_LIMIT_INFORMATION jeli = {0};
-  HANDLE jobHandle = CreateJobObject(NULL, NULL);
-
-  jeli.BasicLimitInformation.LimitFlags = JOB_OBJECT_LIMIT_KILL_ON_JOB_CLOSE | JOB_OBJECT_LIMIT_SILENT_BREAKAWAY_OK;
-  SetInformationJobObject(jobHandle, JobObjectExtendedLimitInformation, &jeli, sizeof(jeli));
-
-  // Start subprocess
-  STARTUPINFOW si = {0};
-  PROCESS_INFORMATION pi = {0};
-
-  if (CreateProcessW(NULL, cmd, NULL, NULL, TRUE, CREATE_SUSPENDED, NULL, NULL, &si, &pi)) {
-    AssignProcessToJobObject(jobHandle, pi.hProcess);
-    ResumeThread(pi.hThread);
-  } else {
-    if (GetLastError() == ERROR_ELEVATION_REQUIRED) {
-      // We must elevate the process, which is (basically) impossible with
-      // CreateProcess, and therefore we fallback to ShellExecuteEx,
-      // which CAN create elevated processes, at the cost of opening a new separate
-      // window.
-      // Theorically, this could be fixed (or rather, worked around) using pipes
-      // and IPC, but... this is a question for another day.
-      SHELLEXECUTEINFOW sei = {0};
-
-      sei.cbSize       = sizeof(SHELLEXECUTEINFOW);
-      sei.fMask        = SEE_MASK_NOCLOSEPROCESS;
-      sei.lpFile       = path;
-      sei.lpParameters = cmd + path_length + 1;
-      sei.nShow        = SW_SHOW;
-
-      if (!ShellExecuteExW(&sei)) {
-        fprintf(stderr, "Unable to create elevated process: error %li.", GetLastError());
-
-        exit_code = 1;
-        goto cleanup;
-      }
-
-      pi.hProcess = sei.hProcess;
-    } else {
-      fprintf(stderr, "Could not create process with command '%ls'.\n", cmd);
-
-      exit_code = 1;
-      goto cleanup;
-    }
-  }
-
-  // Ignore Ctrl-C and other signals
-  if (!SetConsoleCtrlHandler(ctrlhandler, TRUE))
-    fprintf(stderr, "Could not set control handler; Ctrl-C behavior may be invalid.\n");
-
-  // Wait till end of process
-  WaitForSingleObject(pi.hProcess, INFINITE);
-
-  GetExitCodeProcess(pi.hProcess, &exit_code);
-
-  // Dispose of everything
-  CloseHandle(pi.hThread);
-  CloseHandle(pi.hProcess);
-  CloseHandle(jobHandle);
-
-cleanup:
-
-  // Free obsolete buffers
-  free(path);
-  free(args);
-  free(cmd);
-
-  return (int)exit_code;
-}

scripts/bootstrap/bootstrap-haskell

@@ -1,699 +0,0 @@
-#!/bin/sh
-
-# This script downloads the 'ghcup' binary into '~/.ghcup/bin/' and then runs an interactive
-# installation that lets you choose various options. Below is a list of environment variables
-# that affect the installation procedure.
-
-# Main settings:
-#   * BOOTSTRAP_HASKELL_NONINTERACTIVE - any nonzero value for noninteractive installation
-#   * BOOTSTRAP_HASKELL_NO_UPGRADE - any nonzero value to not trigger the upgrade
-#   * BOOTSTRAP_HASKELL_MINIMAL - any nonzero value to only install ghcup
-#   * GHCUP_USE_XDG_DIRS - any nonzero value to respect The XDG Base Directory Specification
-#   * BOOTSTRAP_HASKELL_VERBOSE - any nonzero value for more verbose installation
-#   * BOOTSTRAP_HASKELL_GHC_VERSION - the ghc version to install
-#   * BOOTSTRAP_HASKELL_CABAL_VERSION - the cabal version to install
-#   * BOOTSTRAP_HASKELL_INSTALL_STACK - whether to install latest stack
-#   * BOOTSTRAP_HASKELL_INSTALL_HLS - whether to install latest hls
-#   * BOOTSTRAP_HASKELL_ADJUST_BASHRC - whether to adjust PATH in bashrc (prepend)
-#   * BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG - whether to adjust mingw paths in cabal.config on windows
-
-# License: LGPL-3.0
-
-
-# safety subshell to avoid executing anything in case this script is not downloaded properly
-(
-
-plat="$(uname -s)"
-arch=$(uname -m)
-ghver="0.1.17.1"
-base_url="https://downloads.haskell.org/~ghcup"
-
-export GHCUP_SKIP_UPDATE_CHECK=yes
-
-case "${plat}" in
-        MSYS*|MINGW*)
-			: "${GHCUP_INSTALL_BASE_PREFIX:=/c}"
-			GHCUP_DIR=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup")
-			GHCUP_BIN=$(cygpath -u "${GHCUP_INSTALL_BASE_PREFIX}/ghcup/bin")
-			: "${GHCUP_MSYS2:=${GHCUP_DIR}/msys64}"
-			;;
-		*)
-			: "${GHCUP_INSTALL_BASE_PREFIX:=$HOME}"
-			export GHCUP_USE_XDG_DIRS
-
-			if [ -n "${GHCUP_USE_XDG_DIRS}" ] ; then
-				GHCUP_DIR=${XDG_DATA_HOME:=$HOME/.local/share}/ghcup
-				GHCUP_BIN=${XDG_BIN_HOME:=$HOME/.local/bin}
-			else
-				GHCUP_DIR=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup
-				GHCUP_BIN=${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin
-			fi
-			;;
-esac
-
-: "${BOOTSTRAP_HASKELL_GHC_VERSION:=recommended}"
-: "${BOOTSTRAP_HASKELL_CABAL_VERSION:=recommended}"
-
-
-die() {
-    if [ -n "${NO_COLOR}" ] ; then
-        (>&2 printf "%s\\n" "$1")
-    else
-        (>&2 printf "\\033[0;31m%s\\033[0m\\n" "$1")
-    fi
-    exit 2
-}
-
-warn() {
-    if [ -n "${NO_COLOR}" ] ; then
-        printf "%s\\n" "$1"
-    else
-        case "${plat}" in
-                MSYS*|MINGW*)
-                    echo -e "\\033[0;35m$1\\033[0m"
-                    ;;
-                *)
-                    printf "\\033[0;35m%s\\033[0m\\n" "$1"
-                    ;;
-        esac
-    fi
-}
-
-yellow() {
-    if [ -n "${NO_COLOR}" ] ; then
-        printf "%s\\n" "$1"
-    else
-        case "${plat}" in
-                MSYS*|MINGW*)
-                    echo -e "\\033[0;33m$1\\033[0m"
-                    ;;
-                *)
-                    printf "\\033[0;33m%s\\033[0m\\n" "$1"
-                    ;;
-        esac
-    fi
-}
-
-green() {
-    if [ -n "${NO_COLOR}" ] ; then
-        printf "%s\\n" "$1"
-    else
-        case "${plat}" in
-                MSYS*|MINGW*)
-                    echo -e "\\033[0;32m$1\\033[0m"
-                    ;;
-                *)
-                    printf "\\033[0;32m%s\\033[0m\\n" "$1"
-                    ;;
-        esac
-    fi
-}
-
-edo() {
-    "$@" || die "\"$*\" failed!"
-}
-
-eghcup() {
-	edo _eghcup "$@"
-}
-
-_eghcup() {
-	if [ -n "${BOOTSTRAP_HASKELL_YAML}" ] ; then
-		args="-s ${BOOTSTRAP_HASKELL_YAML}"
-	fi
-    if [ -z "${BOOTSTRAP_HASKELL_VERBOSE}" ] ; then
-        "${GHCUP_BIN}/ghcup" ${args} "$@"
-    else
-        "${GHCUP_BIN}/ghcup" ${args} --verbose "$@"
-    fi
-}
-
-_done() {
-	echo
-	echo "==============================================================================="
-	case "${plat}" in
-			MSYS*|MINGW*)
-				green
-				green "All done!"
-				green
-				green "In a new powershell or cmd.exe session, now you can..."
-				green
-				green "Start a simple repl via:"
-				green "  ghci"
-				green
-				green "Start a new haskell project in the current directory via:"
-				green "  cabal init --interactive"
-				green
-				green "Install other GHC versions and tools via:"
-				green "  ghcup list"
-				green "  ghcup install <tool> <version>"
-				green
-				green "To install system libraries and update msys2/mingw64,"
-				green "open the \"Mingw haskell shell\""
-				green "and the \"Mingw package management docs\""
-				green "desktop shortcuts."
-				;;
-			*)
-				green
-				green "All done!"
-				green
-				green "To start a simple repl, run:"
-				green "  ghci"
-				green
-				green "To start a new haskell project in the current directory, run:"
-				green "  cabal init --interactive"
-				green
-				green "To install other GHC versions and tools, run:"
-				green "  ghcup tui"
-				;;
-
-	esac
-
-
-	exit 0
-}
-
-download_ghcup() {
-
-    case "${plat}" in
-        "linux"|"Linux")
-			case "${arch}" in
-				x86_64|amd64)
-					# we could be in a 32bit docker container, in which
-					# case uname doesn't give us what we want
-					if [ "$(getconf LONG_BIT)" = "32" ] ; then
-						_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
-					elif [ "$(getconf LONG_BIT)" = "64" ] ; then
-						_url=${base_url}/${ghver}/x86_64-linux-ghcup-${ghver}
-					else
-						die "Unknown long bit size: $(getconf LONG_BIT)"
-					fi
-					;;
-				i*86)
-					_url=${base_url}/${ghver}/i386-linux-ghcup-${ghver}
-					;;
-				armv7*)
-					_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
-					;;
-				aarch64|arm64|armv8l)
-					# we could be in a 32bit docker container, in which
-					# case uname doesn't give us what we want
-					if [ "$(getconf LONG_BIT)" = "32" ] ; then
-						_url=${base_url}/${ghver}/armv7-linux-ghcup-${ghver}
-					elif [ "$(getconf LONG_BIT)" = "64" ] ; then
-						_url=${base_url}/${ghver}/aarch64-linux-ghcup-${ghver}
-					else
-						die "Unknown long bit size: $(getconf LONG_BIT)"
-					fi
-					;;
-				*) die "Unknown architecture: ${arch}"
-					;;
-			esac
-			;;
-        "FreeBSD"|"freebsd")
-			case "${arch}" in
-				x86_64|amd64)
-					;;
-				i*86)
-					die "i386 currently not supported!"
-					;;
-				*) die "Unknown architecture: ${arch}"
-					;;
-			esac
-			_url=${base_url}/${ghver}/x86_64-portbld-freebsd-ghcup-${ghver}
-            ;;
-        "Darwin"|"darwin")
-			case "${arch}" in
-				x86_64|amd64)
-					_url=${base_url}/${ghver}/x86_64-apple-darwin-ghcup-${ghver}
-					;;
-				aarch64|arm64|armv8l)
-					_url=${base_url}/${ghver}/aarch64-apple-darwin-ghcup-${ghver}
-					;;
-				i*86)
-					die "i386 currently not supported!"
-					;;
-				*) die "Unknown architecture: ${arch}"
-					;;
-			esac
-			;;
-        MSYS*|MINGW*)
-			case "${arch}" in
-				x86_64|amd64)
-					_url=${base_url}/${ghver}/x86_64-mingw64-ghcup-${ghver}.exe
-					;;
-				*) die "Unknown architecture: ${arch}"
-					;;
-			esac
-			;;
-        *) die "Unknown platform: ${plat}"
-			;;
-    esac
-    case "${plat}" in
-        MSYS*|MINGW*)
-			edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup.exe
-			edo chmod +x "${GHCUP_BIN}"/ghcup.exe
-			;;
-		*)
-			edo curl -Lf "${_url}" > "${GHCUP_BIN}"/ghcup
-			edo chmod +x "${GHCUP_BIN}"/ghcup
-			;;
-	esac
-
-	edo mkdir -p "${GHCUP_DIR}"
-
-	# we may overwrite this in adjust_bashrc
-	cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
-		export PATH="\$HOME/.cabal/bin:${GHCUP_BIN}:\$PATH"
-		EOF
-
-	# shellcheck disable=SC1090
-    edo . "${GHCUP_DIR}"/env
-    eghcup upgrade
-}
-
-# Figures out the users login shell and sets
-# GHCUP_PROFILE_FILE and MY_SHELL variables.
-find_shell() {
-	case $SHELL in
-		*/zsh) # login shell is zsh
-			GHCUP_PROFILE_FILE="$HOME/.zshrc"
-			MY_SHELL="zsh" ;;
-		*/bash) # login shell is bash
-			GHCUP_PROFILE_FILE="$HOME/.bashrc"
-			MY_SHELL="bash" ;;
-		*/sh) # login shell is sh, but might be a symlink to bash or zsh
-			if [ -n "${BASH}" ] ; then
-				GHCUP_PROFILE_FILE="$HOME/.bashrc"
-				MY_SHELL="bash"
-			elif [ -n "${ZSH_VERSION}" ] ; then
-				GHCUP_PROFILE_FILE="$HOME/.zshrc"
-				MY_SHELL="zsh"
-			else
-				return
-			fi
-			;;
-		*/fish) # login shell is fish
-			GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
-			MY_SHELL="fish" ;;
-		*) return ;;
-	esac
-}
-
-# Ask user if they want to adjust the bashrc.
-ask_bashrc() {
-	if [ -n "${BOOTSTRAP_HASKELL_ADJUST_BASHRC}" ] ; then
-		return 1
-	elif [ -z "${MY_SHELL}" ] ; then
-		return 0
-	fi
-
-	while true; do
-		if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
-			echo "-------------------------------------------------------------------------------"
-
-			warn ""
-			warn "Detected ${MY_SHELL} shell on your system..."
-			warn "Do you want ghcup to automatically add the required PATH variable to \"${GHCUP_PROFILE_FILE}\"?"
-			warn ""
-			warn "[P] Yes, prepend  [A] Yes, append  [N] No  [?] Help (default is \"P\")."
-			warn ""
-
-			read -r bashrc_answer </dev/tty
-		else
-			return 0
-		fi
-		case $bashrc_answer in
-			[Pp]* | "")
-				return 1
-				;;
-			[Aa]*)
-				return 2
-				;;
-			[Nn]*)
-				return 0;;
-			*)
-				echo "Possible choices are:"
-				echo
-				echo "P - Yes, prepend to PATH, taking precedence (default)"
-				echo "A - Yes, append to PATH"
-				echo "N - No, don't mess with my configuration"
-				echo
-				echo "Please make your choice and press ENTER."
-				;;
-		esac
-	done
-
-	unset bashrc_answer
-}
-
-# Needs 'find_shell' to be called beforehand.
-adjust_bashrc() {
-	case $1 in
-		1)
-			cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
-				export PATH="\$HOME/.cabal/bin:${GHCUP_BIN}:\$PATH"
-				EOF
-			;;
-		2)
-			cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
-				export PATH="\$PATH:\$HOME/.cabal/bin:${GHCUP_BIN}"
-				EOF
-			;;
-		*) ;;
-	esac
-
-	case $1 in
-		1 | 2)
-			case $MY_SHELL in
-				"")
-					warn_path "Couldn't figure out login shell!"
-					return
-					;;
-				fish)
-					mkdir -p "${GHCUP_PROFILE_FILE%/*}"
-					sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
-					case $1 in
-						1)
-							echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; set -gx PATH \$HOME/.cabal/bin $GHCUP_BIN \$PATH # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
-							;;
-						2)
-							echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME ; set -gx PATH \$HOME/.cabal/bin \$PATH $GHCUP_BIN # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
-							;;
-					esac
-					break ;;
-				bash)
-					sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
-					echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
-					case "${plat}" in
-						"Darwin"|"darwin")
-							if ! grep -q "ghcup-env" "${HOME}/.bash_profile" ; then
-								echo "[[ -f ~/.bashrc ]] && source ~/.bashrc # ghcup-env" >> "${HOME}/.bash_profile"
-							fi
-							;;
-						MSYS*|MINGW*)
-							if [ ! -e "${HOME}/.bash_profile" ] ; then
-								echo '# generated by ghcup' > "${HOME}/.bash_profile"
-								echo 'test -f ~/.profile && . ~/.profile' >> "${HOME}/.bash_profile"
-								echo 'test -f ~/.bashrc && . ~/.bashrc' >> "${HOME}/.bash_profile"
-							fi
-							;;
-					esac
-					break ;;
-
-				zsh)
-					sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
-					echo "[ -f \"${GHCUP_DIR}/env\" ] && source \"${GHCUP_DIR}/env\" # ghcup-env" >> "${GHCUP_PROFILE_FILE}"
-					break ;;
-			esac
-			echo
-			echo "==============================================================================="
-			echo
-			warn "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
-			warn "or type \"source ${GHCUP_DIR}/env\" to apply them in your current terminal session."
-			return
-			;;
-		*)
-			warn_path
-			;;
-	esac
-}
-
-warn_path() {
-	echo
-	echo "==============================================================================="
-	echo
-	[ -n "$1" ] && warn "$1"
-	yellow "In order to run ghc and cabal, you need to adjust your PATH variable."
-	yellow "To do so, you may want to run 'source $GHCUP_DIR/env' in your current terminal"
-	yellow "session as well as your shell configuration (e.g. ~/.bashrc)."
-
-}
-
-adjust_cabal_config() {
-	edo cabal user-config -a "extra-prog-path: $(cygpath -w "$GHCUP_BIN"), $(cygpath -w "$HOME"/AppData/Roaming/cabal/bin), $(cygpath -w "$GHCUP_MSYS2"/usr/bin), $(cygpath -w "$GHCUP_MSYS2"/mingw64/bin)" -a "extra-include-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/include)" -a "extra-lib-dirs: $(cygpath -w "$GHCUP_MSYS2"/mingw64/lib)" -f init
-}
-
-ask_cabal_config_init() {
-	case "${plat}" in
-			MSYS*|MINGW*)
-				if [ -n "${BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG}" ] ; then
-					return 1
-				fi
-
-				if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
-					echo "-------------------------------------------------------------------------------"
-					warn "Create an initial cabal.config including relevant msys2 paths (recommended)?"
-					warn "[Y] Yes  [N] No  [?] Help (default is \"Y\")."
-					echo
-					while true; do
-						read -r mingw_answer </dev/tty
-
-						case $mingw_answer in
-							[Yy]* | "")
-								return 1 ;;
-							[Nn]*)
-								return 0 ;;
-							*)
-								echo "Possible choices are:"
-								echo
-								echo "Y - Yes, create a cabal.config with pre-set paths to msys2/mingw64 (default)"
-								echo "N - No, leave the current/default cabal config untouched"
-								echo
-								echo "Please make your choice and press ENTER."
-								;;
-						esac
-					done
-				else
-					return 1
-				fi
-				;;
-	esac
-
-	unset mingw_answer
-
-    return 0
-}
-
-do_cabal_config_init() {
-	case "${plat}" in
-			MSYS*|MINGW*)
-		case $1 in
-			1)
-				adjust_cabal_config
-				;;
-			0)
-				echo "Make sure that your global cabal.config references the correct mingw64 paths (extra-prog-path, extra-include-dirs and extra-lib-dirs)."
-				echo "And set the environment variable GHCUP_MSYS2 to the root path of your msys2 installation."
-				sleep 5
-				return ;;
-			*) ;;
-		esac
-	esac
-}
-
-ask_hls() {
-	if [ -n "${BOOTSTRAP_HASKELL_INSTALL_HLS}" ] ; then
-		return 1
-	fi
-
-	if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
-		echo "-------------------------------------------------------------------------------"
-
-		warn "Do you want to install haskell-language-server (HLS)?"
-		warn "HLS is a language-server that provides IDE-like functionality"
-		warn "and can integrate with different editors, such as Vim, Emacs, VS Code, Atom, ..."
-		warn "Also see https://github.com/haskell/haskell-language-server/blob/master/README.md"
-		warn ""
-		warn "[Y] Yes  [N] No  [?] Help (default is \"N\")."
-		warn ""
-
-		while true; do
-			read -r hls_answer </dev/tty
-
-			case $hls_answer in
-				[Yy]*)
-					return 1
-					;;
-				[Nn]* | "")
-					return 0
-					;;
-				*)
-					echo "Possible choices are:"
-					echo
-					echo "Y - Yes, install the haskell-langauge-server"
-					echo "N - No, don't install anything more (default)"
-					echo
-					echo "Please make your choice and press ENTER."
-					;;
-			esac
-		done
-	else
-		return 0
-	fi
-
-	unset hls_answer
-}
-
-ask_stack() {
-	if [ -n "${BOOTSTRAP_HASKELL_INSTALL_STACK}" ] ; then
-		return 1
-	fi
-
-	if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
-		echo "-------------------------------------------------------------------------------"
-
-		warn "Do you want to install stack?"
-		warn "Stack is a haskell build tool similar to cabal that is used by some projects."
-		warn "Also see https://docs.haskellstack.org/"
-		warn ""
-		warn "[Y] Yes  [N] No  [?] Help (default is \"N\")."
-		warn ""
-
-		while true; do
-			read -r stack_answer </dev/tty
-
-			case $stack_answer in
-				[Yy]*)
-					return 1 ;;
-				[Nn]* | "")
-					return 0 ;;
-				*)
-					echo "Possible choices are:"
-					echo
-					echo "Y - Yes, install stack"
-					echo "N - No, don't install anything more (default)"
-					echo
-					echo "Please make your choice and press ENTER."
-					;;
-			esac
-		done
-	else
-		return 0
-	fi
-
-	unset stack_answer
-}
-
-
-find_shell
-
-
-echo
-echo "Welcome to Haskell!"
-echo
-echo "This script will download and install the following binaries:"
-echo "  * ghcup - The Haskell toolchain installer"
-echo "  * ghc   - The Glasgow Haskell Compiler"
-echo "  * cabal - The Cabal build tool for managing Haskell software"
-echo "  * stack - (optional) A cross-platform program for developing Haskell projects"
-echo "  * hls   - (optional) A language server for developers to integrate with their editor/IDE"
-echo
-if [ -z "${GHCUP_USE_XDG_DIRS}" ] ; then
-	echo "ghcup installs only into the following directory,"
-    echo "which can be removed anytime:"
-	case "${plat}" in
-			MSYS*|MINGW*)
-				echo "  $(cygpath -w "$GHCUP_DIR")"
-				;;
-			*)
-				echo "  $GHCUP_DIR"
-				;;
-	esac
-else
-	echo "ghcup installs into XDG directories as long as"
-    echo "'GHCUP_USE_XDG_DIRS' is set."
-fi
-echo
-
-if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
-    warn "Press ENTER to proceed or ctrl-c to abort."
-    warn "Note that this script can be re-run at any given time."
-    # Wait for user input to continue.
-    # shellcheck disable=SC2034
-    read -r answer </dev/tty
-fi
-
-ask_bashrc
-ask_bashrc_answer=$?
-ask_cabal_config_init
-ask_cabal_config_init_answer=$?
-if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
-	ask_hls
-	ask_hls_answer=$?
-	ask_stack
-	ask_stack_answer=$?
-fi
-
-edo mkdir -p "${GHCUP_BIN}"
-
-if command -V "ghcup" >/dev/null 2>&1 ; then
-    if [ -z "${BOOTSTRAP_HASKELL_NO_UPGRADE}" ] ; then
-        _eghcup upgrade || download_ghcup
-    fi
-else
-	download_ghcup
-fi
-
-echo
-echo "$(if [ -n "${BOOTSTRAP_HASKELL_YAML}" ] ; then ghcup -s "${BOOTSTRAP_HASKELL_YAML}" tool-requirements ; else ghcup tool-requirements ; fi)"
-echo
-
-if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
-    warn "Press ENTER to proceed or ctrl-c to abort."
-    warn "Installation may take a while."
-    echo
-
-    # Wait for user input to continue.
-    # shellcheck disable=SC2034
-    read -r answer </dev/tty
-fi
-
-if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
-	eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
-
-	eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
-	eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
-
-	do_cabal_config_init $ask_cabal_config_init_answer
-
-	edo cabal new-update
-else # don't install ghc and cabal
-	case "${plat}" in
-			MSYS*|MINGW*)
-				# need to bootstrap cabal to initialize config on windows
-				# we'll remove it afterwards
-				tmp_dir="$(mktemp -d)"
-				eghcup --cache install cabal -i "${tmp_dir}" "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
-				PATH="${tmp_dir}:$PATH" do_cabal_config_init $ask_cabal_config_init_answer
-				rm "${tmp_dir}/cabal"
-				unset tmp_dir
-				;;
-			*)
-				;;
-	esac
-fi
-
-case $ask_hls_answer in
-	1)
-		_eghcup --cache install hls || warn "HLS installation failed, continuing anyway"
-		;;
-	*) ;;
-esac
-
-case $ask_stack_answer in
-	1)
-		_eghcup --cache install stack || warn "Stack installation failed, continuing anyway"
-		;;
-	*) ;;
-esac
-
-
-adjust_bashrc $ask_bashrc_answer
-
-
-_done
-
-)
-
-# vim: tabstop=4 shiftwidth=4 expandtab

scripts/bootstrap/bootstrap-haskell.ps1

@@ -1,590 +0,0 @@
-<#
-    .SYNOPSIS
-    Script to bootstrap a Haskell environment
-
-    .DESCRIPTION
-    This is the windows GHCup installer, installing:
-
-    * ghcup - The Haskell toolchain installer"
-    * ghc   - The Glasgow Haskell Compiler"
-    * msys2 - Unix-style toolchain needed for dependencies and tools
-    * cabal - The Cabal build tool for managing Haskell software"
-    * stack - (optional) A cross-platform program for developing Haskell projects"
-    * hls   - (optional) A language server for developers to integrate with their editor/IDE"
-    
-	By default, the installation is non-interactive, unless you run it with 'Interactive $true'.
-#>
-param (
-    # Run an interactive installation
-    [switch]$Interactive,
-    # Do minimal installation of ghcup and msys2 only
-    [switch]$Minimal,
-    # Run the final bootstrap script via 'bash' instead of a full newly spawned msys2 shell
-    [switch]$InBash,
-    # Overwrite (or rather backup) a previous install
-    [switch]$Overwrite,
-    # Skip adjusting cabal.config with mingw paths
-    [switch]$NoAdjustCabalConfig,
-    # Whether to install stack as well
-    [switch]$InstallStack,
-    # Whether to install hls as well
-    [switch]$InstallHLS,
-    # Specify the bootstrap url (default: 'https://www.haskell.org/ghcup/sh/bootstrap-haskell')
-    [string]$InstallDir,
-    # Instead of installing a new MSys2, use an existing installation
-    [string]$BootstrapUrl,
-    # Specify the install root (default: 'C:\')
-    [string]$ExistingMsys2Dir,
-    # Specify the cabal root directory (default: '$InstallDir\cabal')
-    [string]$CabalDir
-)
-
-$Silent = !$Interactive
-
-function Print-Msg {
-  param ( [Parameter(Mandatory=$true, HelpMessage='String to output')][string]$msg, [string]$color = "Green" )
-  Write-Host ('{0}' -f $msg) -ForegroundColor $color
-}
-
-function Create-Shortcut {
-    param ( [Parameter(Mandatory=$true,HelpMessage='Target path')][string]$SourceExe, [Parameter(Mandatory=$true,HelpMessage='Arguments to the path/exe')][AllowEmptyString()]$ArgumentsToSourceExe, [Parameter(Mandatory=$true,HelpMessage='The destination of the desktop link')][string]$DestinationPath )
-    $WshShell = New-Object -comObject WScript.Shell
-    $Shortcut = $WshShell.CreateShortcut($DestinationPath)
-    $Shortcut.TargetPath = $SourceExe
-    if($ArgumentsToSourceExe) {
-      $Shortcut.Arguments = $ArgumentsToSourceExe
-    }
-    $Shortcut.Save()
-}
-
-function Add-EnvPath {
-  param(
-      [Parameter(Mandatory=$true,HelpMessage='The Path to add to Users environment')]
-      [string] $Path,
-
-      [ValidateSet('Machine', 'User', 'Session')]
-      [string] $Container = 'Session'
-  )
-
-  if ($Container -eq 'Session') {
-      $envPaths = [Collections.Generic.List[String]]($env:Path -split ([IO.Path]::PathSeparator))
-      if ($envPaths -notcontains $Path) {
-          $envPaths.Add($Path)
-          $env:PATH = $envPaths -join ([IO.Path]::PathSeparator)
-      }
-  }
-  else {
-      [Microsoft.Win32.RegistryHive]$hive, $keyPath = switch ($Container) {
-          'Machine' { 'LocalMachine', 'SYSTEM\CurrentControlSet\Control\Session Manager\Environment' }
-          'User' { 'CurrentUser', 'Environment' }
-      }
-
-      $hiveKey = $envKey = $null
-      try {
-          $hiveKey = [Microsoft.Win32.RegistryKey]::OpenRemoteBaseKey($hive, '')
-          $envKey = $hiveKey.OpenSubKey($keyPath, $true)
-          $rawPath = $envKey.GetValue('PATH', '', 'DoNotExpandEnvironmentNames')
-
-          $envPaths = [Collections.Generic.List[String]]($rawPath -split ([IO.Path]::PathSeparator))
-          if ($envPaths -notcontains $Path) {
-              $envPaths.Add($Path)
-              $envKey.SetValue('PATH', ($envPaths -join ([IO.Path]::PathSeparator)), 'ExpandString')
-          }
-      }
-      finally {
-          if ($envKey) { $envKey.Close() }
-          if ($hiveKey) { $hiveKey.Close() }
-      }
-  }
-}
-
-
-
-filter Get-FileSize {
-	'{0:N2} {1}' -f $(
-	if ($_ -lt 1kb) { $_, 'Bytes' }
-	elseif ($_ -lt 1mb) { ($_/1kb), 'KB' }
-	elseif ($_ -lt 1gb) { ($_/1mb), 'MB' }
-	elseif ($_ -lt 1tb) { ($_/1gb), 'GB' }
-	elseif ($_ -lt 1pb) { ($_/1tb), 'TB' }
-	else { ($_/1pb), 'PB' }
-	)
-}
-
-function Get-FileWCSynchronous{
-    param(
-        [Parameter(Mandatory=$true)]
-        [string]$url, 
-        [string]$destinationFolder="$env:USERPROFILE\Downloads",
-        [switch]$includeStats
-    )
-    $wc = New-Object -TypeName Net.WebClient
-    $wc.UseDefaultCredentials = $true
-    $destination = Join-Path -Path $destinationFolder -ChildPath ($url | Split-Path -Leaf)
-    $start = Get-Date
-    $wc.DownloadFile($url, $destination)
-    $elapsed = ((Get-Date) - $start).ToString('hh\:mm\:ss')
-    $totalSize = (Get-Item -Path $destination).Length | Get-FileSize
-    if ($includeStats.IsPresent){
-        [PSCustomObject]@{Name=$MyInvocation.MyCommand;TotalSize=$totalSize;Time=$elapsed}
-    }
-    Get-Item -Path $destination | Unblock-File
-}
-
-function Test-AbsolutePath {
-  Param (
-      [Parameter(Mandatory=$True)]
-      [ValidateScript({[System.IO.Path]::IsPathRooted($_)})]
-      [String]$Path
-  )
-}
-
-function Exec
-{
-    [CmdletBinding()]
-    param(
-        [Parameter(Position = 0, Mandatory = 1)][string]$cmd,
-        [Parameter()][string]$errorMessage,
-        [parameter(ValueFromRemainingArguments = $true)]
-        [string[]]$Passthrough
-    )
-    & $cmd @Passthrough
-    if ($lastexitcode -ne 0) {
-        if (!($errorMessage)) {
-          throw ('Exec: Error executing command {0} with arguments ''{1}''' -f $cmd, "$Passthrough")
-        } else {
-          throw ('Exec: ' + $errorMessage)
-        }
-    }
-}
-
-$ErrorActionPreference = 'Stop'
-
-$GhcupBasePrefixEnv = [System.Environment]::GetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', 'user')
-
-if (Get-Command -Name 'chocolatey.exe' -ErrorAction SilentlyContinue) {
-  if (!($Silent)) {
-    Print-Msg -color Magenta -msg (@'
-Chocolatey was detected on your system. It is capable of installing the Haskell toolchain as well.
-If you want to rather use that instead of ghcup, abort the installation and run the following at an
-elevated command prompt:
-    choco install haskell-dev
-    refreshenv
-
-'@)
-    $decision = $Host.UI.PromptForChoice(''
-    , 'Continue with GHCup installation?'
-    , [System.Management.Automation.Host.ChoiceDescription[]] @('&Continue'
-        '&Abort'), 0)
-    if ($decision -eq 1) {
-      Exit 0
-    }
-  }
-}
-
-if ($GhcupBasePrefixEnv) {
-  $defaultGhcupBasePrefix = $GhcupBasePrefixEnv
-} elseif (!($InstallDir)) {
-  $partitions = Get-CimInstance win32_logicaldisk
-  $defaultGhcupBasePrefix = $null
-  foreach ($p in $partitions){
-    try {
-      if ($p."FreeSpace" -lt 5368709120) { # at least 5 GB are needed
-        throw ("Not enough free space on {0}" -f $p."DeviceId")
-      }
-      $null = New-Item -Path ('{0}\' -f $p."DeviceId") -Name "ghcup.test" -ItemType "directory" -Force
-      $defaultGhcupBasePrefix = ('{0}\' -f $p."DeviceId")
-      Remove-Item -LiteralPath ('{0}\ghcup.test' -f $p."DeviceId")
-      break
-    } catch {
-      Print-Msg -color Yellow -msg ("{0} not writable or not enough disk space, trying next device" -f $p."DeviceId")
-    }
-  }
-  if ($defaultGhcupBasePrefix) {
-    Print-Msg -color Green -msg ("Picked {0} as default Install prefix!" -f $defaultGhcupBasePrefix)
-  } else {
-    Print-Msg -color Red -msg "Couldn't find a writable partition with at least 5GB free disk space!"
-    Exit 1    
-  }
-}
-
-# ask for base install prefix
-if ($Silent -and !($InstallDir)) {
-  $GhcupBasePrefix = $defaultGhcupBasePrefix
-} elseif ($InstallDir) {
-  if (!(Test-Path -LiteralPath ('{0}' -f $InstallDir) -IsValid)) {
-    Print-Msg -color Red -msg "Not a valid directory! (InstallDir)"
-    Exit 1
-  } elseif (!(Split-Path -IsAbsolute -Path "$InstallDir")) {
-    Print-Msg -color Red -msg "Non-absolute Path specified! (InstallDir)"
-    Exit 1
-  } else {
-    $GhcupBasePrefix = $InstallDir
-  }
-} else {
-  while ($true) {
-    Print-Msg -color Magenta -msg ('Where to install to (this should be a short Path, preferably a Drive like ''C:\''){1}Press enter to accept the default [{0}]:' -f $defaultGhcupBasePrefix, "`n")
-    $basePrefixPrompt = Read-Host
-    $GhcupBasePrefix = ($defaultGhcupBasePrefix,$basePrefixPrompt)[[bool]$basePrefixPrompt]
-    if (!($GhcupBasePrefix.EndsWith('\'))) {
-      $GhcupBasePrefix = ('{0}\' -f $GhcupBasePrefix)
-    }
-  
-    if (!($GhcupBasePrefix)) {
-      Print-Msg -color Red -msg "No directory specified!"
-    } elseif (!(Test-Path -LiteralPath ('{0}' -f $GhcupBasePrefix))) {
-      Print-Msg -color Red -msg "Directory does not exist, need to specify an existing Drive/Directory"
-    } elseif (!(Split-Path -IsAbsolute -Path "$GhcupBasePrefix")) {
-      Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
-    } else {
-      Break
-    }
-  }
-}
-
-Print-Msg -msg ('Setting env variable GHCUP_INSTALL_BASE_PREFIX to ''{0}''' -f $GhcupBasePrefix)
-$null = [Environment]::SetEnvironmentVariable("GHCUP_INSTALL_BASE_PREFIX", $GhcupBasePrefix, [System.EnvironmentVariableTarget]::User)
-
-
-$GhcupDir = ('{0}\ghcup' -f $GhcupBasePrefix)
-if ($ExistingMsys2Dir) {
-  if (!(Test-Path -LiteralPath ('{0}' -f $ExistingMsys2Dir) -IsValid)) {
-    Print-Msg -color Red -msg "Not a valid directory! (ExistingMsys2Dir)"
-    Exit 1
-  } elseif (!(Split-Path -IsAbsolute -Path "$ExistingMsys2Dir")) {
-    Print-Msg -color Red -msg "Non-absolute Path specified! (ExistingMsys2Dir)"
-    Exit 1
-  } else {
-	$MsysDir = $ExistingMsys2Dir
-  }
-} else {
-	$MsysDir = ('{0}\msys64' -f $GhcupDir)
-}
-
-$Bash = ('{0}\usr\bin\bash' -f $MsysDir)
-if (!($BootstrapUrl)) {
-  $BootstrapUrl = 'https://www.haskell.org/ghcup/sh/bootstrap-haskell'
-}
-$GhcupMsys2 = [System.Environment]::GetEnvironmentVariable('GHCUP_MSYS2', 'user')
-
-Print-Msg -msg 'Preparing for GHCup installation...'
-
-# ask what to do in case ghcup is already installed
-if (Test-Path -LiteralPath ('{0}' -f $GhcupDir)) {
-  Print-Msg -msg ('GHCup already installed at ''{0}''...' -f $GhcupDir)
-  if ($Overwrite) {
-    $decision = 0
-  } elseif (!($Silent)) {
-    $decision = $Host.UI.PromptForChoice('Install GHCup'
-                                        , 'GHCup is already installed, what do you want to do?'
-                                        , [System.Management.Automation.Host.ChoiceDescription[]] @('&Reinstall'
-                                            '&Continue'
-                                            '&Abort'), 1)
-  } else {
-    $decision = 1
-  }
-
-  if ($decision -eq 0) {
-    $suffix = [IO.Path]::GetRandomFileName()
-    Print-Msg -msg ('Backing up {0} to {0}-{1} ...' -f $GhcupDir, $suffix)
-    Rename-Item -Path ('{0}' -f $GhcupDir) -NewName ('{0}-{1}' -f $GhcupDir, $suffix)
-  } elseif ($decision -eq 1) {
-    Print-Msg -msg 'Continuing installation...'
-  } elseif ($decision -eq 2) {
-    Exit 0
-  }
-}
-
-
-$null = New-Item -Path ('{0}' -f $GhcupDir) -ItemType 'directory' -ErrorAction SilentlyContinue
-$null = New-Item -Path ('{0}' -f $GhcupDir) -Name 'bin' -ItemType 'directory' -ErrorAction SilentlyContinue
-
-# ask for cabal dir destination
-if ($CabalDir) {
-  $CabDirEnv = $CabalDir
-  if (!($CabDirEnv)) {
-    Print-Msg -color Red -msg "No directory specified!"
-    Exit 1        
-  } elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) {
-    Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
-    Exit 1
-  }
-} elseif (!($Silent)) {
-  while ($true) {
-
-    $defaultCabalDir = ('{0}\cabal' -f $GhcupBasePrefix)
-    Print-Msg -color Magenta -msg ('Specify Cabal directory (this is where haskell packages end up){1}Press enter to accept the default [{0}]:' -f $defaultCabalDir, "`n")
-    $CabalDirPrompt = Read-Host
-    $CabDirEnv = ($defaultCabalDir,$CabalDirPrompt)[[bool]$CabalDirPrompt]
-
-    if (!($CabDirEnv)) {
-      Print-Msg -color Red -msg "No directory specified!"         
-    } elseif (!(Split-Path -IsAbsolute -Path "$CabDirEnv")) {
-      Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
-    } else {
-      Break
-    }
-  }
-} else {
-  $CabDirEnv = ('{0}\cabal' -f $GhcupBasePrefix)
-}
-
-# ask whether to install HLS
-if (!($InstallHLS)) {
-  if (!($Silent)) {
-    $HLSdecision = $Host.UI.PromptForChoice('Install HLS'
-      , 'Do you want to install the haskell-language-server (HLS) for development purposes as well?'
-      , [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
-          '&No'
-          '&Abort'), 1)
-
-    if ($HLSdecision -eq 0) {
-      $InstallHLS = $true
-    } elseif ($HLSdecision -eq 2) {
-      Exit 0
-    }
-  }
-}
-
-# ask whether to install stack
-if (!($InstallStack)) {
-  if (!($Silent)) {
-    $StackDecision = $Host.UI.PromptForChoice('Install stack'
-      , 'Do you want to install stack as well?'
-      , [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
-          '&No'
-          '&Abort'), 1)
-
-    if ($StackDecision -eq 0) {
-      $InstallStack = $true
-    } elseif ($StackDecision -eq 2) {
-      Exit 0
-    }
-  }
-}
-
-
-# mingw foo
-Print-Msg -msg 'First checking for Msys2...'
-if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
-  if ($Silent) {
-    $msys2Decision = 0
-  } else {
-    $msys2Decision = $Host.UI.PromptForChoice('Install MSys2'
-        , 'Do you want GHCup to install a default MSys2 toolchain (recommended)?'
-        , [System.Management.Automation.Host.ChoiceDescription[]] @('&Yes'
-            '&No'), 0)
-  }
-
-  if ($msys2Decision -eq 0) {
-    Print-Msg -msg ('...Msys2 doesn''t exist, installing into {0}' -f $MsysDir)
-
-	Print-Msg -msg 'Starting installation in 5 seconds, this may take a while...'
-	Start-Sleep -s 5
-
-    # Download the archive
-    Print-Msg -msg 'Downloading Msys2 archive...'
-    $archive = 'msys2-x86_64-latest.sfx.exe'
-    
-    if (Get-Command -Name 'curl.exe' -ErrorAction SilentlyContinue) {
-      Exec "curl.exe" '-o' ('{0}\{1}' -f $env:TEMP, $archive) ('https://repo.msys2.org/distrib/{0}' -f $archive)
-    } else {
-      Get-FileWCSynchronous -url ('https://repo.msys2.org/distrib/{0}' -f $archive) -destinationFolder "$env:TEMP" -includeStats
-    }
-
-    Print-Msg -msg 'Extracting Msys2 archive...'
-    $null = & "$env:TEMP\$archive" '-y' ('-o{0}' -f $GhcupDir)  # Extract
-    Remove-Item -Path ('{0}/{1}' -f $env:TEMP, $archive)
-
-    Print-Msg -msg 'Processing MSYS2 bash for first time use...'
-    Exec "$Bash" '-lc' 'exit'
-
-    Exec "$env:windir\system32\taskkill.exe" /F /FI `"MODULES eq msys-2.0.dll`"
-
-    Print-Msg -msg 'Upgrading full system...'
-    Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'
-
-    Print-Msg -msg 'Upgrading full system twice...'
-    Exec "$Bash" '-lc' 'pacman --noconfirm -Syuu'
-
-    Print-Msg -msg 'Installing Dependencies...'
-    Exec "$Bash" '-lc' 'pacman --noconfirm -S --needed curl autoconf mingw-w64-x86_64-pkgconf'
-
-    Print-Msg -msg 'Updating SSL root certificate authorities...'
-    Exec "$Bash" '-lc' 'pacman --noconfirm -S ca-certificates'
-
-    Print-Msg -msg 'Setting default home directory...'
-    Exec "$Bash" '-lc' "sed -i -e 's/db_home:.*$/db_home: windows/' /etc/nsswitch.conf"
-
-  } elseif ($msys2Decision -eq 1) {
-    Print-Msg -color Yellow -msg 'Skipping MSys2 installation.'
-    while ($true) {
-      if ($GhcupMsys2) {
-        $defaultMsys2Dir = $GhcupMsys2
-        Print-Msg -color Magenta -msg ('Input existing MSys2 toolchain directory.{1}Press enter to accept the default [{0}]:' -f $defaultMsys2Dir, "`n")
-        $MsysDirPrompt = Read-Host
-        $MsysDir = ($defaultMsys2Dir,$MsysDirPrompt)[[bool]$MsysDirPrompt]
-      } else {
-        Print-Msg -color Magenta -msg 'Input existing MSys2 toolchain directory:' 
-        $MsysDir = Read-Host
-      }
-      if (!($MsysDir)) {
-        Print-Msg -color Red -msg "No directory specified!"         
-      } elseif (!(Test-Path -LiteralPath ('{0}' -f $MsysDir))) {
-        Print-Msg -color Red -msg ('MSys2 installation at ''{0}'' could not be found!' -f $MsysDir)
-      } elseif (!(Split-Path -IsAbsolute -Path "$MsysDir")) {
-        Print-Msg -color Red -msg "Invalid/Non-absolute Path specified"
-      } else {
-        Break
-      }
-    }
-    Print-Msg -msg ('Setting GHCUP_MSYS2 env var to ''{0}''' -f $MsysDir)
-    $null = [Environment]::SetEnvironmentVariable("GHCUP_MSYS2", $MsysDir, [System.EnvironmentVariableTarget]::User)
-    $Bash = ('{0}\usr\bin\bash' -f $MsysDir)
-  }
-} else {
-    Print-Msg -msg ('...Msys2 found in {0} ...skipping Msys2 installation.' -f $MsysDir)
-
-	Print-Msg -msg 'Starting installation in 5 seconds, this may take a while...'
-	Start-Sleep -s 5
-}
-
-Print-Msg -msg 'Creating shortcuts...'
-$uninstallShortCut = @'
-$decision = $Host.UI.PromptForChoice('Uninstall Haskell'
-, 'Do you want to uninstall all of the haskell toolchain, including GHC, Cabal, Stack and GHCup itself?'
-, [System.Management.Automation.Host.ChoiceDescription[]] @('&Uninstall'
-    '&Abort'), 0)
-
-if ($decision -eq 1) {
-  Exit 0
-}
-
-Write-Host 'Removing ghcup toolchain' -ForegroundColor Green
-ghcup nuke
-
-Write-Host 'Unsetting GHCUP_INSTALL_BASE_PREFIX' -ForegroundColor Green
-[Environment]::SetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', $null, [System.EnvironmentVariableTarget]::User)
-
-$ghcupMsys2 = [System.Environment]::GetEnvironmentVariable('GHCUP_MSYS2', 'user')
-$GhcupBasePrefixEnv = [System.Environment]::GetEnvironmentVariable('GHCUP_INSTALL_BASE_PREFIX', 'user')
-
-if ($ghcupMsys2) {
-  $msys2Dir = [IO.Path]::GetFullPath($ghcupMsys2)
-  $baseDir = [IO.Path]::GetFullPath('{0}\ghcup' -f $GhcupBasePrefixEnv)
-
-  if ($msys2Dir.StartsWith($baseDir)) {
-    Write-Host 'Unsetting GHCUP_MSYS2' -ForegroundColor Green
-    [Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)
-  } else {
-    Write-Host ('GHCUP_MSYS2 env variable is set to a non-standard location {0}. Environment variable not unset. Uninstall manually.' -f $msys2Dir) -ForegroundColor Magenta
-  }
-} else {
-  Write-Host 'Unsetting GHCUP_MSYS2' -ForegroundColor Green
-  [Environment]::SetEnvironmentVariable('GHCUP_MSYS2', $null, [System.EnvironmentVariableTarget]::User)
-}
-
-Write-Host 'Removing ghcup from PATH env var' -ForegroundColor Green
-$path = [System.Environment]::GetEnvironmentVariable(
-    'PATH',
-    'user'
-)
-$path = ($path.Split(';') | Where-Object { $_ -ne ('{0}\bin' -f $baseDir) }) -join ';'
-[System.Environment]::SetEnvironmentVariable(
-    'PATH',
-    $path,
-    'user'
-)
-
-Write-Host 'Removing desktop files' -ForegroundColor Green
-$DesktopDir = [Environment]::GetFolderPath("Desktop")
-Remove-Item -LiteralPath ('{0}\Install GHC dev dependencies.lnk' -f $DesktopDir) -Force
-Remove-Item -LiteralPath ('{0}\Mingw haskell shell.lnk' -f $DesktopDir) -Force
-Remove-Item -LiteralPath ('{0}\Mingw package management docs.url' -f $DesktopDir) -Force
-
-Write-Host ('CABAL_DIR env variable is still set to {0} and will be used by cabal regardless of ghcup. You may want to uninstall this manually.' -f [System.Environment]::GetEnvironmentVariable('CABAL_DIR', 'user')) -ForegroundColor Magenta
-Write-Host 'You may remove this script now.' -ForegroundColor Magenta
-
-if ($Host.Name -eq "ConsoleHost")
-{
-    Write-Host "Press any key to continue..."
-    $Host.UI.RawUI.ReadKey("NoEcho,IncludeKeyUp") > $null
-}
-'@
-
-$DesktopDir = [Environment]::GetFolderPath("Desktop")
-$GhcInstArgs = '-mingw64 -mintty -c "pacman --noconfirm -S --needed base-devel gettext autoconf make libtool automake python p7zip patch unzip"'
-Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe $GhcInstArgs -DestinationPath ('{0}\Install GHC dev dependencies.lnk' -f $DesktopDir)
-Create-Shortcut -SourceExe ('{0}\msys2_shell.cmd' -f $MsysDir) -ArgumentsToSourceExe '-mingw64' -DestinationPath ('{0}\Mingw haskell shell.lnk' -f $DesktopDir)
-Create-Shortcut -SourceExe 'https://www.msys2.org/docs/package-management' -ArgumentsToSourceExe '' -DestinationPath ('{0}\Mingw package management docs.url' -f $DesktopDir)
-$null = New-Item -Path $DesktopDir -Name "Uninstall Haskell.ps1" -ItemType "file" -Force -Value $uninstallShortCut
-
-Print-Msg -msg ('Adding {0}\bin to Users Path...' -f $GhcupDir)
-Add-EnvPath -Path ('{0}\bin' -f ([System.IO.Path]::GetFullPath("$GhcupDir"))) -Container 'User'
-
-
-
-$CabalDirFull = [System.IO.Path]::GetFullPath("$CabDirEnv")
-Print-Msg -msg ('Setting CABAL_DIR to ''{0}''' -f $CabalDirFull)
-$null = [Environment]::SetEnvironmentVariable("CABAL_DIR", $CabalDirFull, [System.EnvironmentVariableTarget]::User)
-
-Print-Msg -msg 'Starting GHCup installer...'
-
-$Msys2Shell = ('{0}\msys2_shell.cmd' -f $MsysDir)
-
-# The bootstrap script is always silent, since we ask relevant questions here
-$SilentExport = 'export BOOTSTRAP_HASKELL_NONINTERACTIVE=1 ;'
-
-if ($InstallStack) {
-  $StackInstallExport = 'export BOOTSTRAP_HASKELL_INSTALL_STACK=1 ;'
-}
-
-if ($InstallHLS) {
-  $HLSInstallExport = 'export BOOTSTRAP_HASKELL_INSTALL_HLS=1 ;'
-}
-
-if (!($NoAdjustCabalConfig)) {
-  $AdjustCabalConfigExport = 'export BOOTSTRAP_HASKELL_ADJUST_CABAL_CONFIG=1 ;'
-}
-
-if ($Minimal) {
-  $MinimalExport = 'export BOOTSTRAP_HASKELL_MINIMAL=1 ;'
-}
-
-if ((Get-Process -ID $PID).ProcessName.StartsWith("bootstrap-haskell") -Or $InBash) {
-  Exec "$Bash" '-lc' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; [[ ''{0}'' = https* ]]  && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
-} else {
-  Exec "$Msys2Shell" '-mingw64' '-mintty' '-c' ('{4} {6} {7} {8} {9} [ -n ''{1}'' ] && export GHCUP_MSYS2=$(cygpath -m ''{1}'') ; [ -n ''{2}'' ] && export GHCUP_INSTALL_BASE_PREFIX=$(cygpath -m ''{2}/'') ; export PATH=$(cygpath -u ''{3}/bin''):$PATH ; export CABAL_DIR=''{5}'' ; trap ''echo Press any key to exit && read -n 1 && exit'' 2 ; [[ ''{0}'' = https* ]]  && curl --proto ''=https'' --tlsv1.2 -sSf {0} | bash || cat $(cygpath -m ''{0}'') | bash ; echo ''Press any key to exit'' && read -n 1' -f $BootstrapUrl, $MsysDir, $GhcupBasePrefix, $GhcupDir, $SilentExport, $CabalDirFull, $StackInstallExport, $HLSInstallExport, $AdjustCabalConfigExport, $MinimalExport)
-}
-
-
-# SIG # Begin signature block
-  # MIID4QYJKoZIhvcNAQcCoIID0jCCA84CAQExCzAJBgUrDgMCGgUAMGkGCisGAQQB
-  # gjcCAQSgWzBZMDQGCisGAQQBgjcCAR4wJgIDAQAABBAfzDtgWUsITrck0sYpfvNR
-  # AgEAAgEAAgEAAgEAAgEAMCEwCQYFKw4DAhoFAAQUVqKek181kF/Jx/P7z176herc
-  # ZyCgggH/MIIB+zCCAWSgAwIBAgIQGOezhGS1A5tHh9VubW0liDANBgkqhkiG9w0B
-  # AQUFADAYMRYwFAYDVQQDDA1KdWxpYW4gT3NwYWxkMB4XDTIxMDUzMDE4Mzk1OVoX
-  # DTI1MDUzMDAwMDAwMFowGDEWMBQGA1UEAwwNSnVsaWFuIE9zcGFsZDCBnzANBgkq
-  # hkiG9w0BAQEFAAOBjQAwgYkCgYEAs76XCXYPM14buR1RkVKhOB8pyM4Df6kPaz75
-  # nkbA0nq1VmMhBfCYFWyYHd7jniqTH0LoAKGGquN1bniREaCP9j2pFWpMIgLpQH3H
-  # +jpsfmxV2BTG8q+Jok88gTXS1FlAk72E85zO/Jhr6Fja1aFYAdibBRsRxcVMTVh7
-  # 4AGLNGUCAwEAAaNGMEQwEwYDVR0lBAwwCgYIKwYBBQUHAwMwHQYDVR0OBBYEFC+R
-  # hdhPo0Ty5HnzHyo1pN35IfZQMA4GA1UdDwEB/wQEAwIHgDANBgkqhkiG9w0BAQUF
-  # AAOBgQAl3IdBVIwbJJDp7BksMYPeM4ivB3UyNvlw8aVxGwAzNgdSaezYIdMFtKXV
-  # CSv5bd4VnFRAPDJW9dhW0h3SkeJUoklUxMjKXhR3qygQhSxPDjIatAuOCffGACba
-  # ZZ7Om40b+pKXc6i/HnlApk9DGbXJ59bFcLGGcZ9QjoUae6Ex1DGCAUwwggFIAgEB
-  # MCwwGDEWMBQGA1UEAwwNSnVsaWFuIE9zcGFsZAIQGOezhGS1A5tHh9VubW0liDAJ
-  # BgUrDgMCGgUAoHgwGAYKKwYBBAGCNwIBDDEKMAigAoAAoQKAADAZBgkqhkiG9w0B
-  # CQMxDAYKKwYBBAGCNwIBBDAcBgorBgEEAYI3AgELMQ4wDAYKKwYBBAGCNwIBFTAj
-  # BgkqhkiG9w0BCQQxFgQUosm9nN1JgajqSBa1cUwxxhLrAsYwDQYJKoZIhvcNAQEB
-  # BQAEgYCnKzfsH1aDjS6xkC/uymjaBowHSnh6nFu2AkjcKu8RgcBZzP5SLBXgU9wm
-  # aED5Ujwyq3Qre+TGVRUqwkEauDhQiX2A008G00fRO6+di6yJRCRn5eaRAbdU3Xww
-  # E5VhEwLBnwzWrvLKtdEclhgUCo5Tq87QMXVdgX4aRmunl4ZE+Q==
-# SIG # End signature block
-
-
-
-
-
-
-

scripts/dev/refreeze.sh

@@ -1,27 +0,0 @@
-#!/bin/sh
-
-set -xue
-
-rm -f cabal.*.project
-rm -f cabal.*.project.freeze
-
-for ghc_ver in "$@" ; do
-	# shellcheck disable=SC3060
-	project_file=cabal.ghc${ghc_ver//./}.project
-
-	cp cabal.project "${project_file}"
-	case "$(uname -s)" in
-        MSYS*|MINGW*)
-			cabal freeze --project-file="${project_file}" -w "ghc-${ghc_ver}"
-			;;
-		*)
-			cabal freeze --project-file="${project_file}" -w "ghc-${ghc_ver}" -ftui -finternal-downloader
-			;;
-	esac
-
-
-	echo "" >> "${project_file}"
-	echo "with-compiler: ghc-${ghc_ver}" >> "${project_file}"
-
-	sed -i -e '/ghcup/d' "${project_file}".freeze
-done

scripts/shell-completions/bash

@@ -1,14 +0,0 @@
-_ghcup()
-{
-    local CMDLINE
-    local IFS=$'\n'
-    CMDLINE=(--bash-completion-index $COMP_CWORD)
-
-    for arg in ${COMP_WORDS[@]}; do
-        CMDLINE=(${CMDLINE[@]} --bash-completion-word $arg)
-    done
-
-    COMPREPLY=( $(ghcup "${CMDLINE[@]}") )
-}
-
-complete -o filenames -F _ghcup ghcup

scripts/shell-completions/fish

@@ -1,19 +0,0 @@
- function _ghcup
-    set -l cl (commandline --tokenize --current-process)
-    # Hack around fish issue #3934
-    set -l cn (commandline --tokenize --cut-at-cursor --current-process)
-    set -l cn (count $cn)
-    set -l tmpline --bash-completion-enriched --bash-completion-index $cn
-    for arg in $cl
-      set tmpline $tmpline --bash-completion-word $arg
-    end
-    for opt in (ghcup $tmpline)
-      if test -d $opt
-        echo -E "$opt/"
-      else
-        echo -E "$opt"
-      end
-    end
-end
-
-complete --no-files --command ghcup --arguments '(_ghcup)'