Re-add travis

This change is to support screen readers which use the cursor location
to indicate the focus to the user.

Brick.putCursor is unreleased, so grab the latest version from git via extra-deps.

.gitlab-ci.yml

@@ -104,6 +104,7 @@ variables:
     expire_in: 2 week
     paths:
       - golden
+      - dist-newstyle/cache/
     when: on_failure
 
 # .test_ghcup_scoop:
@@ -202,6 +203,7 @@ variables:
     expire_in: 2 week
     paths:
       - out
+      - dist-newstyle/cache/
   only:
     - tags
   variables:
@@ -281,11 +283,31 @@ test:linux:cross-armv7:
     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.5"
+    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 ########
 

.gitlab/script/ghcup_git.sh

@@ -0,0 +1,52 @@
+#!/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/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_version.sh

@@ -12,6 +12,10 @@ ecabal() {
 	cabal "$@"
 }
 
+raw_eghcup() {
+	ghcup -v -c "$@"
+}
+
 eghcup() {
 	if [ "${OS}" = "WINDOWS" ] ; then
 		ghcup -v -c -s file:/$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
@@ -20,6 +24,12 @@ eghcup() {
 	fi
 }
 
+if [ "${OS}" = "WINDOWS" ] ; then
+	GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
+else
+	GHCUP_DIR="${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
+fi
+
 git describe --always
 
 ### build
@@ -65,11 +75,7 @@ fi
 
 ### cleanup
 
-if [ "${OS}" = "WINDOWS" ] ; then
+rm -rf "${GHCUP_DIR}"
-	rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/ghcup
-else
-	rm -rf "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup
-fi
 
 ### manual cli based testing
 
@@ -88,6 +94,7 @@ cabal --version
 
 eghcup debug-info
 
+# also test etags
 eghcup list
 eghcup list -t ghc
 eghcup list -t cabal
@@ -155,6 +162,40 @@ if [ "${OS}" = "LINUX" ] ; then
 	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}" ]
+
 
 eghcup upgrade
 eghcup upgrade -f
@@ -162,8 +203,4 @@ eghcup upgrade -f
 
 # nuke
 eghcup nuke
-if [ "${OS}" = "WINDOWS" ] ; then
+[ ! -e "${GHCUP_DIR}" ]
-	[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/ghcup" ]
-else
-	[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
-fi

.travis.yml

@@ -0,0 +1,25 @@
+jobs:
+  include:
+    - os: osx
+      osx_image: xcode10.1
+      language: generic
+      env: ARTIFACT=x86_64-apple-darwin-10.13-ghcup
+
+    - os: osx
+      osx_image: xcode11.3
+      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="
+  file: $ARTIFACT
+  on:
+    repo: hasufell/ghcup-hs
+    tags: true
+  skip_cleanup: true
+  draft: true

.travis/build.sh

@@ -0,0 +1,28 @@
+#!/bin/sh
+
+set -ex
+
+mkdir -p ~/.ghcup/bin
+curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-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
+
+
+## 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}"

CHANGELOG.md

@@ -1,8 +1,23 @@
 # Revision history for ghcup
 
-## 0.1.16 -- ????-??-??
+## 0.1.16 -- 2021-07-28
 
 * 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
 

README.md

@@ -230,6 +230,29 @@ 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
 
 1. Why reimplement stack?
@@ -242,4 +265,10 @@ We do.
 
 3. 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.

app/ghcup-gen/Validate.hs

@@ -126,7 +126,7 @@ validate dls _ = do
         _ -> lift $ $(logWarn) [i|Linux Alpine missing for #{t} #{v'} #{arch'}|]
 
   checkUniqueTags tool = do
-    let allTags = join $ M.elems $ availableToolVersions dls tool
+    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
     let nonUnique =
           fmap fst
             .   filter (\(_, b) -> not b)
@@ -164,7 +164,7 @@ validate dls _ = do
 
   -- a tool must have at least one of each mandatory tags
   checkMandatoryTags tool = do
-    let allTags = join $ M.elems $ availableToolVersions dls tool
+    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
     forM_ [Latest, Recommended] $ \t -> case elem t allTags of
       False -> do
         lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
@@ -174,7 +174,7 @@ validate dls _ = do
   -- all GHC versions must have a base tag
   checkGHCHasBaseVersion = do
     let allTags = M.toList $ availableToolVersions dls GHC
-    forM allTags $ \(ver, tags) -> case any isBase tags of
+    forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
       False -> do
         lift $ $(logError) [i|Base tag missing from GHC ver #{ver}|]
         addError
@@ -256,7 +256,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
         case etool of
           Right (Just GHCup) -> do
             tmpUnpack <- lift mkGhcupTmpDir
-            _ <- liftE $ download dli tmpUnpack Nothing
+            _ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
             pure Nothing
           Right _ -> do
             p <- liftE $ downloadCached dli Nothing
@@ -266,7 +266,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
               $ p
           Left ShimGen -> do
             tmpUnpack <- lift mkGhcupTmpDir
-            _ <- liftE $ download dli tmpUnpack Nothing
+            _ <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmpUnpack Nothing False
             pure Nothing
     case r of
       VRight (Just basePath) -> do

app/ghcup/BrickMain.hs

@@ -59,7 +59,7 @@ import qualified Data.Vector                   as V
 
 
 hiddenTools :: [Tool]
-hiddenTools = [Stack]
+hiddenTools = []
 
 
 data BrickData = BrickData
@@ -169,7 +169,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
           | elem Latest lTag && not lInstalled =
               withAttr "hooray"
           | otherwise = id
-        active = if b then forceAttr "active" else id
+        active = if b then putCursor "GHCup" (Location (0,0)) . forceAttr "active" else id
     in  hooray $ active $ dim
           (   marks
           <+> padLeft (Pad 2)
@@ -257,7 +257,7 @@ app attrs dimAttrs =
   , appHandleEvent  = eventHandler
   , appStartEvent   = return
   , appAttrMap      = const attrs
-  , appChooseCursor = neverShowCursor
+  , appChooseCursor = showFirstCursor
   }
 
 defaultAttributes :: Bool -> AttrMap

app/ghcup/Main.hs

@@ -34,6 +34,7 @@ import           GHCup.Version
 import           Codec.Archive
 #endif
 import           Control.Concurrent
+import           Control.Concurrent.Async
 import           Control.DeepSeq                ( force )
 import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
@@ -182,6 +183,8 @@ data GHCCompileOptions = GHCCompileOptions
   , addConfArgs  :: [Text]
   , setCompile   :: Bool
   , ovewrwiteVer :: Maybe Version
+  , buildFlavour :: Maybe String
+  , hadrian      :: Bool
   }
 
 data UpgradeOpts = UpgradeInplace
@@ -987,6 +990,16 @@ ghcCompileOpts =
               "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
             )
           )
+    <*> optional
+          (option
+            str
+            (short 'f' <> long "flavour" <> metavar "BUILD_FLAVOUR" <> help
+              "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
+            )
+          )
+    <*> switch
+          (long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
+          )
 
 
 toolVersionParser :: Parser ToolVersion
@@ -1048,6 +1061,7 @@ tagCompleter tool add = listIOCompleter $ do
     VRight ghcupInfo -> do
       let allTags = filter (\t -> t /= Old)
             $ join
+            $ fmap _viTags
             $ M.elems
             $ availableToolVersions (_ghcupDownloads ghcupInfo) tool
       pure $ nub $ (add ++) $ fmap tagToString allTags
@@ -1330,7 +1344,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           (settings, keybindings) <- toSettings opt
 
           -- logger interpreter
-          logfile <- initGHCupFileLogging logsDir
+          logfile <- flip runReaderT dirs $ initGHCupFileLogging
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , colorOutter  = B.hPut stderr
@@ -1374,9 +1388,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             exitWith (ExitFailure 2)
                 let s' = AppState settings dirs keybindings ghcupInfo pfreq
 
-                lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
+                race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
-                  Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
+                      (threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{recycleDir} manually|]))
-                  Just _ -> pure ()
+
+                case optCommand of
+                  Nuke -> pure ()
+                  Whereis _ _ -> pure ()
+                  DInfo -> pure ()
+                  ToolRequirements -> pure ()
+                  ChangeLog _ -> pure ()
+#if defined(BRICK)
+                  Interactive -> pure ()
+#endif
+                  _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
+                         Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
+                         Just _ -> pure ()
 
                 -- TODO: always run for windows
                 (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
@@ -1406,6 +1432,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           -- Effect interpreters --
           -------------------------
 
+
           let runInstTool' appstate' mInstPlatform =
                 runLogger
                   . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
@@ -1503,6 +1530,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let runRm =
                 runLogger . runAppState . runE @'[NotInstalled]
 
+          let runNuke s' =
+                runLogger . flip runReaderT s' . runE @'[NotInstalled]
+
           let runDebugInfo =
                 runLogger
                   . runAppState
@@ -1906,6 +1936,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                         runLogger $ $(logError) $ T.pack $ prettyShow e
                         pure $ ExitFailure 8
 
+            Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
+              runLogger $ $(logError) "Hadrian cross compile support is not yet implemented!"
+              pure $ ExitFailure 9
             Compile (CompileGHC GHCCompileOptions {..}) ->
               runCompileGHC (do
                 case targetGhc of
@@ -1926,18 +1959,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             buildConfig
                             patchDir
                             addConfArgs
+                            buildFlavour
+                            hadrian
                 GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                 let vi = getVersionInfo (_tvVersion targetVer) GHC dls
                 when setCompile $ void $ liftE $
                   setGHC targetVer SetGHCOnly
-                pure vi
+                pure (vi, targetVer)
                 )
                 >>= \case
-                      VRight vi -> do
+                      VRight (vi, tv) -> do
                         runLogger $ $(logInfo)
                           "GHC successfully compiled and installed"
                         forM_ (_viPostInstall =<< vi) $ \msg ->
                           runLogger $ $(logInfo) msg
+                        putStr (T.unpack $ tVerToText tv)
                         pure ExitSuccess
                       VLeft (V (AlreadyInstalled _ v)) -> do
                         runLogger $ $(logWarn)
@@ -1991,22 +2027,25 @@ Make sure to clean up #{tmpdir} afterwards.|])
                 (UpgradeAt p)   -> pure $ Just p
                 UpgradeGHCupDir -> pure (Just (binDir </> "ghcup" <> exeExt))
 
-              runUpgrade (liftE $ upgradeGHCup target force') >>= \case
+              runUpgrade (do
-                VRight v' -> do
+                v' <- liftE $ upgradeGHCup target force'
-                  GHCupInfo { _ghcupDownloads = dls } <- runAppState getGHCupInfo
+                GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-                  let pretty_v = prettyVer v'
+                pure (v', dls)
-                  let vi = fromJust $ snd <$> getLatest dls GHCup
+                ) >>= \case
-                  runLogger $ $(logInfo)
+                  VRight (v', dls) -> do
-                    [i|Successfully upgraded GHCup to version #{pretty_v}|]
+                    let pretty_v = prettyVer v'
-                  forM_ (_viPostInstall vi) $ \msg ->
+                    let vi = fromJust $ snd <$> getLatest dls GHCup
-                    runLogger $ $(logInfo) msg
+                    runLogger $ $(logInfo)
-                  pure ExitSuccess
+                      [i|Successfully upgraded GHCup to version #{pretty_v}|]
-                VLeft (V NoUpdate) -> do
+                    forM_ (_viPostInstall vi) $ \msg ->
-                  runLogger $ $(logWarn) [i|No GHCup update available|]
+                      runLogger $ $(logInfo) msg
-                  pure ExitSuccess
+                    pure ExitSuccess
-                VLeft e -> do
+                  VLeft (V NoUpdate) -> do
-                  runLogger $ $(logError) $ T.pack $ prettyShow e
+                    runLogger $ $(logWarn) [i|No GHCup update available|]
-                  pure $ ExitFailure 11
+                    pure ExitSuccess
+                  VLeft e -> do
+                    runLogger $ $(logError) $ T.pack $ prettyShow e
+                    pure $ ExitFailure 11
 
             ToolRequirements -> do
               s' <- appState
@@ -2045,7 +2084,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
                     )
                   pure ExitSuccess
                 Just uri -> do
-                  pfreq <- runAppState getPlatformReq
+                  s' <- appState
+                  pfreq <- flip runReaderT s' getPlatformReq
                   let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
                       cmd = case _rPlatform pfreq of
                               Darwin  -> "open"
@@ -2055,7 +2095,6 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
                   if clOpen
                     then do
-                      s' <- appState
                       flip runReaderT s' $
                         exec cmd
                              [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
@@ -2067,10 +2106,10 @@ Make sure to clean up #{tmpdir} afterwards.|])
                                   >> pure (ExitFailure 13)
                     else putStrLn uri' >> pure ExitSuccess
 
-            Nuke ->
+            Nuke -> do
-              runRm (do
+              s' <- liftIO appState
-                   s' <- liftIO appState
+              void $ liftIO $ evaluate $ force s'
-                   void $ liftIO $ evaluate $ force s'
+              runNuke s' (do
                    lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
                    lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
                    liftIO $ threadDelay 10000000  -- wait 10s
@@ -2090,7 +2129,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
                                   runLogger $ $logInfo "Nuclear Annihilation complete!"
                                   pure ExitSuccess
                               | otherwise -> do
-                                  runLogger $ $logWarn "These Files have survived Nuclear Annihilation, you may remove them manually."
+                                  runLogger $ $logError "These Files have survived Nuclear Annihilation, you may remove them manually."
                                   forM_ leftOverFiles putStrLn
                                   pure ExitSuccess
 

bootstrap-haskell

@@ -290,7 +290,16 @@ ask_bashrc() {
 
 			read -r bashrc_answer </dev/tty
 		else
-			return 1
+			# On windows .bashrc isn't an important user config, so we adjust it
+			# always. On other platforms, let's be a bit more conservative.
+			case "${plat}" in
+					MSYS*|MINGW*)
+						return 1
+						;;
+					*)
+						return 0
+						;;
+			esac
 		fi
 		case $bashrc_answer in
 			[Pp]* | "")
@@ -326,7 +335,7 @@ adjust_bashrc() {
 			;;
 		2)
 			cat <<-EOF > "${GHCUP_DIR}"/env || die "Failed to create env file"
-				export PATH="\$HOME/.cabal/bin:\$PATH:${GHCUP_BIN}"
+				export PATH="\$PATH:\$HOME/.cabal/bin:${GHCUP_BIN}"
 				EOF
 			;;
 		*) ;;
@@ -335,7 +344,10 @@ adjust_bashrc() {
 	case $1 in
 		1 | 2)
 			case $MY_SHELL in
-				"") break ;;
+				"")
+					warn_path "Couldn't figure out login shell!"
+					return
+					;;
 				fish)
 					mkdir -p "${GHCUP_PROFILE_FILE%/*}"
 					sed -i -e '/# ghcup-env$/ s/^#*/#/' "${GHCUP_PROFILE_FILE}"
@@ -365,15 +377,30 @@ adjust_bashrc() {
 					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 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
 }
@@ -615,36 +642,8 @@ case $ask_stack_answer in
 esac
 
 
+adjust_bashrc $ask_bashrc_answer
 
-# short-circuit script based on platform
-case "${plat}" in
-        MSYS*|MINGW*)
-			# For windows we always adjust bashrc, since it's inside msys2
-			adjust_bashrc $adjust_bashrc_answer
-			;;
-		*)
-        	if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
-				case $ask_bashrc_answer in
-					1 | 2)
-						echo
-						echo "==============================================================================="
-						echo
-						yellow "In order to run ghc and cabal, start a new shell or"
-						yellow "run 'source $GHCUP_DIR/env' in your current shell session."
-						adjust_bashrc $adjust_bashrc_answer
-						;;
-					*)
-						echo
-						echo "==============================================================================="
-						echo
-						yellow "In order to run ghc and cabal, you need to adjust your PATH variable."
-						yellow "You may want to source '$GHCUP_DIR/env' in your shell"
-						yellow "configuration to do so (e.g. ~/.bashrc)."
-						;;
-				esac
-			fi
-			;;
-esac
 
 _done
 

bootstrap-haskell.ps1

@@ -276,7 +276,7 @@ if ($CabalDir) {
   while ($true) {
 
     $defaultCabalDir = ('{0}\cabal' -f $GhcupBasePrefix)
-    Print-Msg -color Magenta -msg ('Specify Cabal directory (this is where haskell packages end up). Press enter to accept the default [{0}]:' -f $defaultCabalDir)
+    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]
 
@@ -383,7 +383,7 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
     while ($true) {
       if ($GhcupMsys2) {
         $defaultMsys2Dir = $GhcupMsys2
-        Print-Msg -color Magenta -msg ('Input existing MSys2 toolchain directory. Press enter to accept the default [{0}]:' -f $defaultMsys2Dir)
+        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 {
@@ -412,11 +412,74 @@ if (!(Test-Path -Path ('{0}' -f $MsysDir))) {
 }
 
 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'

cabal.project

@@ -8,6 +8,11 @@ package ghcup
     tests: True
     flags: +tui
 
+source-repository-package
+    type: git
+    location: https://github.com/jtdaugherty/brick.git
+    tag: b3b96cfe66dfd398d338e3feb2b6855e66a35190
+
 source-repository-package
     type: git
     location: https://github.com/Bodigrim/tar

ghcup-0.0.5.yaml

@@ -96,6 +96,7 @@ toolRequirements:
       Linux_Alpine:
         unknown_versioning:
           distroPKGs:
+          - binutils-gold
           - curl
           - gcc
           - g++
@@ -2075,7 +2076,10 @@ ghcupDownloads:
     1.1.0:
       viTags: []
       viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#110
-      viPostInstall: "This is just the server part of your LSP configuration. Consult the README on how to configure HLS, your project and your LSP client in your editor: https://github.com/haskell/haskell-language-server/blob/master/README.md"
+      viPostInstall: &hls-post-install |
+        This is just the server part of your LSP configuration. Consult the README on how to
+        configure HLS, your project and your LSP client in your editor:
+          https://github.com/haskell/haskell-language-server/blob/master/README.md
       viArch:
         A_64:
           Linux_UnknownLinux:
@@ -2097,7 +2101,7 @@ ghcupDownloads:
         - Recommended
         - Latest
       viChangeLog: https://github.com/haskell/haskell-language-server/blob/master/ChangeLog.md#120
-      viPostInstall: "This is just the server part of your LSP configuration. Consult the README on how to configure HLS, your project and your LSP client in your editor: https://github.com/haskell/haskell-language-server/blob/master/README.md"
+      viPostInstall: *hls-post-install
       viArch:
         A_64:
           Linux_UnknownLinux:
@@ -2155,14 +2159,13 @@ ghcupDownloads:
             unknown_versioning: *stack-251-64
     2.7.1:
       viTags:
-        - Recommended
+        - old
-        - Latest
       viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v271
       viPostInstall: *stack-post
       viArch:
         A_64:
           Linux_UnknownLinux:
-            unknown_versioning: &stack-64
+            unknown_versioning: &stack-271-64
               dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-linux-x86_64.tar.gz
               dlHash: 2bc47749ee4be5eccb52a2d4a6a00b0f3b28b92517742b40c675836d7db2777d
               dlSubdir:
@@ -2180,5 +2183,33 @@ ghcupDownloads:
               dlSubdir:
                 RegexDir: "stack-.*"
           Linux_Alpine:
-            unknown_versioning: *stack-64
+            unknown_versioning: *stack-271-64
+    2.7.3:
+      viTags:
+        - Latest
+        - Recommended
+      viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v273
+      viPostInstall: *stack-post
+      viArch:
+        A_64:
+          Linux_UnknownLinux:
+            unknown_versioning: &stack-273-64
+              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.3/stack-2.7.3-linux-x86_64.tar.gz
+              dlHash: a6c090555fa1c64aa61c29aa4449765a51d79e870cf759cde192937cd614e72b
+              dlSubdir:
+                RegexDir: "stack-.*"
+          Darwin:
+            unknown_versioning:
+              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.3/stack-2.7.3-osx-x86_64.tar.gz
+              dlHash: 42e5000a00af44a7b26852421ac63ce75f510ad1a97742cb131107088ee9fe30
+              dlSubdir:
+                RegexDir: "stack-.*"
+          Windows:
+            unknown_versioning:
+              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.3/stack-2.7.3-windows-x86_64.tar.gz
+              dlHash: e6ba12e0ecabf0df2567d88a0d247da238bc114bcccfca4195f5e86472c9330c
+              dlSubdir:
+                RegexDir: "stack-.*"
+          Linux_Alpine:
+            unknown_versioning: *stack-273-64
 

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            ghcup
-version:         0.1.15.2
+version:         0.1.16
 license:         LGPL-3.0-only
 license-file:    LICENSE
 copyright:       Julian Ospald 2020
@@ -202,6 +202,7 @@ executable ghcup
     -fwarn-incomplete-record-updates -threaded
 
   build-depends:
+    , async                 ^>=2.2.3
     , base                  >=4.13     && <5
     , bytestring            ^>=0.10
     , containers            ^>=0.6
@@ -232,7 +233,7 @@ executable ghcup
     cpp-options:   -DBRICK
     other-modules: BrickMain
     build-depends:
-      , brick         >=0.5    && <0.62
+      , brick         >=0.5    && <0.64
       , transformers  ^>=0.5
       , vector        ^>=0.12
       , vty           >=5.28.2 && <5.34

lib/GHCup.hs

@@ -54,6 +54,9 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
+#if defined(IS_WINDOWS)
+import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
+#endif
 import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.List
@@ -77,6 +80,9 @@ import           System.Directory        hiding ( findFiles )
 import           System.Environment
 import           System.FilePath
 import           System.IO.Error
+#if defined(IS_WINDOWS)
+import           System.IO.Temp
+#endif
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix
 
@@ -275,20 +281,29 @@ installUnpackedGHC :: ( MonadReader env m
                       , MonadThrow m
                       , MonadLogger m
                       , MonadIO m
+                      , MonadUnliftIO m
+                      , MonadMask m
                       )
                    => FilePath      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
                    -> FilePath      -- ^ Path to install to
                    -> Version       -- ^ The GHC version
                    -> Excepts '[ProcessError] m ()
-#if defined(IS_WINDOWS)
-installUnpackedGHC path inst _ = do
-  lift $ $(logInfo) "Installing GHC (this may take a while)"
-  -- windows bindists are relocatable and don't need
-  -- to run configure
-  liftIO $ copyDirectoryRecursive path inst
-#else
 installUnpackedGHC path inst ver = do
+#if defined(IS_WINDOWS)
+  lift $ $(logInfo) "Installing GHC (this may take a while)"
+  -- Windows bindists are relocatable and don't need
+  -- to run configure.
+  -- We also must make sure to preserve mtime to not confuse ghc-pkg.
+  lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
+    mtime <- getModificationTime source
+    Win32.moveFile source dest
+    setModificationTime dest mtime
+#else
   PlatformRequest {..} <- lift getPlatformReq
+  liftIO $ copyDirectoryRecursive path inst $ \source dest -> do
+    mtime <- getModificationTime source
+    copyFile source dest
+    setModificationTime dest mtime
 
   let alpineArgs
        | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
@@ -299,9 +314,6 @@ installUnpackedGHC path inst ver = do
   lift $ $(logInfo) "Installing GHC (this may take a while)"
   lEM $ execLogged "sh"
                    ("./configure" : ("--prefix=" <> inst) 
-#if defined(IS_WINDOWS)
-                    : "--enable-tarballs-autodownload"
-#endif
                     : alpineArgs
                    )
                    (Just path)
@@ -789,7 +801,10 @@ setGHC ver sghc = do
   symlinkShareDir :: ( MonadReader env m
                      , HasDirs env
                      , MonadIO m
-                     , MonadLogger m)
+                     , MonadLogger m
+                     , MonadCatch m
+                     , MonadMask m
+                     )
                   => FilePath
                   -> String
                   -> m ()
@@ -804,7 +819,7 @@ setGHC ver sghc = do
           let fullF   = destdir </> sharedir
           let targetF = "." </> "ghc" </> ver' </> sharedir
           $(logDebug) [i|rm -f #{fullF}|]
-          liftIO $ hideError doesNotExistErrorType $ removeDirectoryLink fullF
+          hideError doesNotExistErrorType $ rmDirectoryLink fullF
           $(logDebug) [i|ln -s #{targetF} #{fullF}|]
           liftIO
 #if defined(IS_WINDOWS)
@@ -872,7 +887,7 @@ setHLS ver = do
   oldSyms <- lift hlsSymlinks
   forM_ oldSyms $ \f -> do
     lift $ $(logDebug) [i|rm #{binDir </> f}|]
-    liftIO $ rmLink (binDir </> f)
+    lift $ rmLink (binDir </> f)
 
   -- set haskell-language-server-<ghcver> symlinks
   bins <- lift $ hlsServerBinaries ver
@@ -950,9 +965,9 @@ data ListResult = ListResult
 
 
 -- | Extract all available tool versions and their tags.
-availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version [Tag]
+availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo
 availableToolVersions av tool = view
-  (at tool % non Map.empty % to (fmap _viTags))
+  (at tool % non Map.empty)
   av
 
 
@@ -998,12 +1013,14 @@ listVersions lt' criteria = do
             slr <- strayCabals avTools cSet cabals
             pure (sort (slr ++ lr))
           HLS -> do
-            slr <- strayHLS avTools
+            slr <- strayHLS avTools hlsSet' hlses
             pure (sort (slr ++ lr))
           Stack -> do
-            slr <- strayStacks avTools
+            slr <- strayStacks avTools sSet stacks
             pure (sort (slr ++ lr))
-          GHCup -> pure lr
+          GHCup -> do
+            let cg = currentGHCup avTools
+            pure (sort (cg : lr))
       Nothing -> do
         ghcvers   <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
         cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
@@ -1018,7 +1035,7 @@ listVersions lt' criteria = do
                , MonadLogger m
                , MonadIO m
                )
-            => Map.Map Version [Tag]
+            => Map.Map Version VersionInfo
             -> m [ListResult]
   strayGHCs avTools = do
     ghcs <- getInstalledGHCs
@@ -1066,7 +1083,7 @@ listVersions lt' criteria = do
                  , MonadLogger m
                  , MonadIO m
                  )
-            => Map.Map Version [Tag]
+            => Map.Map Version VersionInfo
             -> Maybe Version
             -> [Either FilePath Version]
             -> m [ListResult]
@@ -1100,16 +1117,17 @@ listVersions lt' criteria = do
               , MonadThrow m
               , MonadLogger m
               , MonadIO m)
-           => Map.Map Version [Tag]
+           => Map.Map Version VersionInfo
+           -> Maybe Version
+           -> [Either FilePath Version]
            -> m [ListResult]
-  strayHLS avTools = do
+  strayHLS avTools hlsSet' hlss = do
-    hlss <- getInstalledHLSs
     fmap catMaybes $ forM hlss $ \case
       Right ver ->
         case Map.lookup ver avTools of
           Just _  -> pure Nothing
           Nothing -> do
-            lSet    <- fmap (== Just ver) hlsSet
+            let lSet = hlsSet' == Just ver
             pure $ Just $ ListResult
               { lTool      = HLS
               , lVer       = ver
@@ -1134,16 +1152,17 @@ listVersions lt' criteria = do
                  , MonadLogger m
                  , MonadIO m
                  )
-              => Map.Map Version [Tag]
+              => Map.Map Version VersionInfo
+              -> Maybe Version
+              -> [Either FilePath Version]
               -> m [ListResult]
-  strayStacks avTools = do
+  strayStacks avTools stackSet' stacks = do
-    stacks <- getInstalledStacks
     fmap catMaybes $ forM stacks $ \case
       Right ver ->
         case Map.lookup ver avTools of
           Just _  -> pure Nothing
           Nothing -> do
-            lSet    <- fmap (== Just ver) hlsSet
+            let lSet = stackSet' == Just ver
             pure $ Just $ ListResult
               { lTool      = Stack
               , lVer       = ver
@@ -1161,6 +1180,25 @@ listVersions lt' criteria = do
           [i|Could not parse version of stray directory #{e}|]
         pure Nothing
 
+  currentGHCup :: Map.Map Version VersionInfo -> ListResult
+  currentGHCup av =
+    let currentVer = pvpToVersion ghcUpVer
+        listVer    = Map.lookup currentVer av
+        latestVer  = fst <$> headOf (getTagged Latest) av
+        recommendedVer = fst <$> headOf (getTagged Latest) av
+        isOld  = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer
+    in ListResult { lVer    = currentVer
+                  , lTag    = maybe (if isOld then [Old] else []) _viTags listVer
+                  , lCross  = Nothing
+                  , lTool   = GHCup
+                  , fromSrc = False
+                  , lStray  = isNothing listVer
+                  , lSet    = True
+                  , lInstalled = True
+                  , lNoBindist = False
+                  , hlsPowered = False
+                  }
+
   -- NOTE: this are not cross ones, because no bindists
   toListResult :: ( MonadLogger m
                   , MonadReader env m
@@ -1177,9 +1215,9 @@ listVersions lt' criteria = do
                -> [Either FilePath Version]
                -> Maybe Version
                -> [Either FilePath Version]
-               -> (Version, [Tag])
+               -> (Version, VersionInfo)
                -> m ListResult
-  toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = do
+  toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do
     case t of
       GHC -> do
         lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v
@@ -1293,7 +1331,7 @@ rmGHCVer ver = do
   -- then fix them (e.g. with an earlier version)
 
   lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
-  liftIO $ rmPath dir
+  lift $ recyclePathForcibly dir
 
   v' <-
     handle
@@ -1305,9 +1343,7 @@ rmGHCVer ver = do
 
   Dirs {..} <- lift getDirs
 
-  liftIO
+  lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
-    $ hideError doesNotExistErrorType
-    $ rmFile (baseDir </> "share")
 
 
 -- | Delete a cabal version. Will try to fix the @cabal@ symlink
@@ -1332,13 +1368,13 @@ rmCabalVer ver = do
   Dirs {..} <- lift getDirs
 
   let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-  liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
+  lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)
 
   when (Just ver == cSet) $ do
     cVers <- lift $ fmap rights getInstalledCabals
     case headMay . reverse . sort $ cVers of
       Just latestver -> setCabal latestver
-      Nothing        -> liftIO $ rmLink (binDir </> "cabal" <> exeExt)
+      Nothing        -> lift $ rmLink (binDir </> "cabal" <> exeExt)
 
 
 -- | Delete a hls version. Will try to fix the hls symlinks
@@ -1363,7 +1399,7 @@ rmHLSVer ver = do
   Dirs {..} <- lift getDirs
 
   bins <- lift $ hlsAllBinaries ver
-  forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
+  forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
 
   when (Just ver == isHlsSet) $ do
     -- delete all set symlinks
@@ -1371,7 +1407,7 @@ rmHLSVer ver = do
     forM_ oldSyms $ \f -> do
       let fullF = binDir </> f
       lift $ $(logDebug) [i|rm #{fullF}|]
-      liftIO $ rmLink fullF
+      lift $ rmLink fullF
     -- set latest hls
     hlsVers <- lift $ fmap rights getInstalledHLSs
     case headMay . reverse . sort $ hlsVers of
@@ -1401,13 +1437,13 @@ rmStackVer ver = do
   Dirs {..} <- lift getDirs
 
   let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-  liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
+  lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)
 
   when (Just ver == sSet) $ do
     sVers <- lift $ fmap rights getInstalledStacks
     case headMay . reverse . sort $ sVers of
       Just latestver -> setStack latestver
-      Nothing        -> liftIO $ rmLink (binDir </> "stack" <> exeExt)
+      Nothing        -> lift $ rmLink (binDir </> "stack" <> exeExt)
 
 
 -- assuming the current scheme of having just 1 ghcup bin, no version info is required.
@@ -1416,10 +1452,12 @@ rmGhcup :: ( MonadReader env m
            , MonadIO m
            , MonadCatch m
            , MonadLogger m
+           , MonadMask m
+           , MonadUnliftIO m
            )
         => m ()
 rmGhcup = do
-  Dirs {binDir} <- getDirs
+  Dirs { .. } <- getDirs
   let ghcupFilename = "ghcup" <> exeExt
   let ghcupFilepath = binDir </> ghcupFilename
 
@@ -1441,16 +1479,15 @@ rmGhcup = do
   unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
 
 #if defined(IS_WINDOWS)
-  -- since it doesn't seem possible to delete a running exec in windows
+  -- since it doesn't seem possible to delete a running exe on windows
   -- we move it to temp dir, to be deleted at next reboot
-  tempDir <- liftIO $ getTemporaryDirectory
+  tempFilepath <- mkGhcupTmpDir
-  let tempFilepath = tempDir </> ghcupFilename
   hideError UnsupportedOperation $
             liftIO $ hideError NoSuchThing $
-            Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
+            Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
 #else
   -- delete it.
-  hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
+  hideError doesNotExistErrorType $ rmFile ghcupFilepath
 #endif
 
   where
@@ -1495,40 +1532,46 @@ rmGhcupDirs = do
     , binDir
     , logsDir
     , cacheDir
+    , recycleDir
     } <- getDirs
 
   let envFilePath = baseDir </> "env"
 
   confFilePath <- getConfigFilePath
 
-  rmEnvFile  envFilePath
+  handleRm $ rmEnvFile  envFilePath
-  rmConfFile confFilePath
+  handleRm $ rmConfFile confFilePath
-  rmDir cacheDir
+  handleRm $ rmDir cacheDir
-  rmDir logsDir
+  handleRm $ rmDir logsDir
-  rmBinDir   binDir
+  handleRm $ rmBinDir binDir
+  handleRm $ rmDir recycleDir
 #if defined(IS_WINDOWS)
-  rmDir (baseDir </> "msys64")
+  $logInfo [i|removing #{(baseDir </> "msys64")}|]
+  handleRm $ rmPathForcibly (baseDir </> "msys64")
 #endif
 
-  liftIO $ removeEmptyDirsRecursive baseDir
+  handleRm $ removeEmptyDirsRecursive baseDir
 
   -- report files in baseDir that are left-over after
   -- the standard location deletions above
   hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
 
   where
+    handleRm :: (MonadCatch m, MonadLogger m)  => m () -> m ()
+    handleRm = handleIO (\e -> $logDebug [i|Part of the cleanup action failed with error: #{displayException e}
+continuing regardless...|])
 
-    rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
+    rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     rmEnvFile enFilePath = do
       $logInfo "Removing Ghcup Environment File"
-      liftIO $ deleteFile enFilePath
+      hideErrorDef [permissionErrorType] () $ deleteFile enFilePath
 
-    rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
+    rmConfFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     rmConfFile confFilePath = do
       $logInfo "removing Ghcup Config File"
-      liftIO $ deleteFile confFilePath
+      hideErrorDef [permissionErrorType] () $ deleteFile confFilePath
 
-    rmDir :: (MonadLogger m, MonadIO m, MonadCatch m) => FilePath -> m ()
+    rmDir :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     rmDir dir =
       -- 'getDirectoryContentsRecursive' is lazy IO. In case
       -- an error leaks through, we catch it here as well,
@@ -1536,9 +1579,9 @@ rmGhcupDirs = do
       hideErrorDef [doesNotExistErrorType] () $ do
         $logInfo [i|removing #{dir}|]
         contents <- liftIO $ getDirectoryContentsRecursive dir
-        forM_ contents (liftIO . deleteFile . (dir </>))
+        forM_ contents (deleteFile . (dir </>))
 
-    rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
+    rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     rmBinDir binDir = do
 #if !defined(IS_WINDOWS)
       isXDGStyle <- liftIO useXDG
@@ -1567,9 +1610,9 @@ rmGhcupDirs = do
         compareFn :: FilePath -> FilePath -> Ordering
         compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
 
-    removeEmptyDirsRecursive :: FilePath -> IO ()
+    removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     removeEmptyDirsRecursive fp = do
-      cs <- listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
+      cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
       forM_ cs removeEmptyDirsRecursive
       hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
         
@@ -1578,22 +1621,22 @@ rmGhcupDirs = do
     -- we report remaining files/dirs later,
     -- hence the force/quiet mode in these delete functions below.
 
-    deleteFile :: FilePath -> IO ()
+    deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
     deleteFile filepath = do
       hideError doesNotExistErrorType
         $ hideError InappropriateType $ rmFile filepath
 
-    removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
+    removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     removeDirIfEmptyOrIsSymlink filepath =
       hideError UnsatisfiedConstraints $
       handleIO' InappropriateType
             (handleIfSym filepath)
-            (liftIO $ removeDirectory filepath)
+            (liftIO $ rmDirectory filepath)
       where
         handleIfSym fp e = do
           isSym <- liftIO $ pathIsSymbolicLink fp
           if isSym
-          then liftIO $ deleteFile fp
+          then deleteFile fp
           else liftIO $ ioError e
 
 
@@ -1651,10 +1694,12 @@ compileGHC :: ( MonadMask m
            => Either GHCTargetVersion GitBranch          -- ^ version to install
            -> Maybe Version            -- ^ overwrite version
            -> Either Version FilePath  -- ^ version to bootstrap with
-           -> Maybe Int                  -- ^ jobs
+           -> Maybe Int                -- ^ jobs
            -> Maybe FilePath           -- ^ build config
            -> Maybe FilePath           -- ^ patch directory
-           -> [Text]                     -- ^ additional args to ./configure
+           -> [Text]                   -- ^ additional args to ./configure
+           -> Maybe String             -- ^ build flavour
+           -> Bool
            -> Excepts
                 '[ AlreadyInstalled
                  , BuildFailed
@@ -1673,7 +1718,7 @@ compileGHC :: ( MonadMask m
                  ]
                 m
                 GHCTargetVersion
-compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
+compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian
   = do
     PlatformRequest { .. } <- lift getPlatformReq
     GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -1758,8 +1803,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
       tmpUnpack
       Nothing
       (do
-        b <- compileBindist bghc tver workdir ghcdir
+        b <- if hadrian
-        bmk <- liftIO $ B.readFile (build_mk workdir)
+             then compileHadrianBindist bghc tver workdir ghcdir
+             else compileMakeBindist bghc tver workdir ghcdir
+        bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)
         pure (b, bmk)
       )
 
@@ -1790,40 +1837,238 @@ BUILD_MAN = NO
 BUILD_SPHINX_HTML = NO
 BUILD_SPHINX_PDF = NO
 HADDOCK_DOCS = NO
+ifneq "$(BuildFlavour)" ""
+include mk/flavours/$(BuildFlavour).mk
+endif
 Stage1Only = YES|]
     _ -> [s|
 V=0
 BUILD_MAN = NO
 BUILD_SPHINX_HTML = NO
 BUILD_SPHINX_PDF = NO
-HADDOCK_DOCS = YES|]
+HADDOCK_DOCS = YES
+ifneq "$(BuildFlavour)" ""
+include mk/flavours/$(BuildFlavour).mk
+endif|]
 
-  compileBindist :: ( MonadReader env m
+  compileHadrianBindist :: ( MonadReader env m
-                    , HasDirs env
+                           , HasDirs env
-                    , HasSettings env
+                           , HasSettings env
-                    , HasPlatformReq env
+                           , HasPlatformReq env
-                    , MonadThrow m
+                           , MonadThrow m
-                    , MonadCatch m
+                           , MonadCatch m
-                    , MonadLogger m
+                           , MonadLogger m
-                    , MonadIO m
+                           , MonadIO m
-                    , MonadFail m
+                           , MonadFail m
-                    )
+                           )
-                 => Either FilePath FilePath
+                        => Either FilePath FilePath
-                 -> GHCTargetVersion
+                        -> GHCTargetVersion
-                 -> FilePath
+                        -> FilePath
-                 -> FilePath
+                        -> FilePath
-                 -> Excepts
+                        -> Excepts
-                      '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
+                             '[ FileDoesNotExistError
-                      m
+                              , HadrianNotFound
-                      (Maybe FilePath)  -- ^ output path of bindist, None for cross
+                              , InvalidBuildConfig
-  compileBindist bghc tver workdir ghcdir = do
+                              , PatchFailed
-    lift $ $(logInfo) [i|configuring build|]
+                              , ProcessError
-    liftE checkBuildConfig
+                              , NotFoundInPATH
+                              , CopyError]
+                             m
+                             (Maybe FilePath)  -- ^ output path of bindist, None for cross
+  compileHadrianBindist bghc tver workdir ghcdir = do
+    lEM $ execLogged "python3" ["./boot"] (Just workdir) "ghc-bootstrap" Nothing
 
+    liftE $ configureBindist bghc tver workdir ghcdir
+
+    lift $ $(logInfo) [i|Building (this may take a while)...|]
+    hadrian_build <- liftE $ findHadrianFile workdir
+    lEM $ execLogged hadrian_build
+                          ( maybe [] (\j  -> [[i|-j#{j}|]]         ) jobs
+                         ++ maybe [] (\bf -> [[i|--flavour=#{bf}|]]) buildFlavour
+                         ++ ["binary-dist"]
+                          )
+                          (Just workdir) "ghc-make" Nothing
+    [tar] <- liftIO $ findFiles
+      (workdir </> "_build" </> "bindist")
+      (makeRegexOpts compExtended
+                     execBlank
+                     ([s|^ghc-.*\.tar\..*$|] :: ByteString)
+      )
+    liftE $ fmap Just $ copyBindist tver tar (workdir </> "_build" </> "bindist")
+
+  findHadrianFile :: (MonadIO m)
+                  => FilePath
+                  -> Excepts
+                       '[HadrianNotFound]
+                       m
+                       FilePath
+  findHadrianFile workdir = do
+#if defined(IS_WINDOWS)
+    let possible_files = ((workdir </> "hadrian") </>) <$> ["build.bat"]
+#else   
+    let possible_files = ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
+#endif
+    exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))
+    case filter fst exsists of
+      [] -> throwE HadrianNotFound
+      ((_, x):_) -> pure x
+
+  compileMakeBindist :: ( MonadReader env m
+                        , HasDirs env
+                        , HasSettings env
+                        , HasPlatformReq env
+                        , MonadThrow m
+                        , MonadCatch m
+                        , MonadLogger m
+                        , MonadIO m
+                        , MonadFail m
+                        )
+                     => Either FilePath FilePath
+                     -> GHCTargetVersion
+                     -> FilePath
+                     -> FilePath
+                     -> Excepts
+                          '[ FileDoesNotExistError
+                           , HadrianNotFound
+                           , InvalidBuildConfig
+                           , PatchFailed
+                           , ProcessError
+                           , NotFoundInPATH
+                           , CopyError]
+                          m
+                       (Maybe FilePath)  -- ^ output path of bindist, None for cross
+  compileMakeBindist bghc tver workdir ghcdir = do
+    liftE $ configureBindist bghc tver workdir ghcdir
+
+    case mbuildConfig of
+      Just bc -> liftIOException
+        doesNotExistErrorType
+        (FileDoesNotExistError bc)
+        (liftIO $ copyFile bc (build_mk workdir))
+      Nothing ->
+        liftIO $ B.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
+
+    liftE $ checkBuildConfig (build_mk workdir)
+
+    lift $ $(logInfo) [i|Building (this may take a while)...|]
+    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
+
+    if | isCross tver -> do
+          lift $ $(logInfo) [i|Installing cross toolchain...|]
+          lEM $ make ["install"] (Just workdir)
+          pure Nothing
+       | otherwise -> do
+          lift $ $(logInfo) [i|Creating bindist...|]
+          lEM $ make ["binary-dist"] (Just workdir)
+          [tar] <- liftIO $ findFiles
+            workdir
+            (makeRegexOpts compExtended
+                           execBlank
+                           ([s|^ghc-.*\.tar\..*$|] :: ByteString)
+            )
+          liftE $ fmap Just $ copyBindist tver tar workdir
+
+  build_mk workdir = workdir </> "mk" </> "build.mk"
+
+  copyBindist :: ( MonadReader env m
+                 , HasDirs env
+                 , HasSettings env
+                 , HasPlatformReq env
+                 , MonadIO m
+                 , MonadThrow m
+                 , MonadCatch m
+                 , MonadLogger m
+                 )
+              => GHCTargetVersion
+              -> FilePath           -- ^ tar file
+              -> FilePath           -- ^ workdir
+              -> Excepts
+                   '[CopyError]
+                   m
+                   FilePath
+  copyBindist tver tar workdir = do
     Dirs {..} <- lift getDirs
     pfreq <- lift getPlatformReq
+    c       <- liftIO $ BL.readFile (workdir </> tar)
+    cDigest <-
+      fmap (T.take 8)
+      . lift
+      . throwEither
+      . E.decodeUtf8'
+      . B16.encode
+      . SHA256.hashlazy
+      $ c
+    cTime <- liftIO getCurrentTime
+    let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
+    let tarPath = cacheDir </> tarName
+    handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
+                                                             tarPath
+    lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
+    pure tarPath
 
-    forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
+  checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m)
+                   => FilePath
+                   -> Excepts
+                        '[FileDoesNotExistError, InvalidBuildConfig]
+                        m
+                        ()
+  checkBuildConfig bc = do
+    c <- liftIOException
+           doesNotExistErrorType
+           (FileDoesNotExistError bc)
+           (liftIO $ B.readFile bc)
+    let lines' = fmap T.strip . T.lines $ decUTF8Safe c
+
+   -- for cross, we need Stage1Only
+    case targetGhc of
+      Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
+        (InvalidBuildConfig
+          [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
+        )
+      _ -> pure ()
+
+    forM_ buildFlavour $ \bf ->
+      when ([i|BuildFlavour = #{bf}|] `notElem` lines') $ do
+        lift $ $(logWarn) [i|Customly specified build config overwrites --flavour=#{bf} switch! Waiting 5 seconds...|]
+        liftIO $ threadDelay 5000000
+
+  addBuildFlavourToConf bc = case buildFlavour of
+    Just bf -> [i|BuildFlavour = #{bf}|] <> [s|
+|] <> [i|#{bc}|]
+    Nothing -> bc
+
+  isCross :: GHCTargetVersion -> Bool
+  isCross = isJust . _tvTarget
+
+
+  configureBindist :: ( MonadReader env m
+                      , HasDirs env
+                      , HasSettings env
+                      , HasPlatformReq env
+                      , MonadThrow m
+                      , MonadCatch m
+                      , MonadLogger m
+                      , MonadIO m
+                      , MonadFail m
+                      )
+                   => Either FilePath FilePath
+                   -> GHCTargetVersion
+                   -> FilePath
+                   -> FilePath
+                   -> Excepts
+                        '[ FileDoesNotExistError
+                         , InvalidBuildConfig
+                         , PatchFailed
+                         , ProcessError
+                         , NotFoundInPATH
+                         , CopyError
+                         ]
+                        m
+                        ()
+  configureBindist bghc tver workdir ghcdir = do
+    lift $ $(logInfo) [s|configuring build|]
+    
+    forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
 
     cEnv <- liftIO getEnvironment
 
@@ -1864,75 +2109,9 @@ HADDOCK_DOCS = YES|]
           (Just workdir)
           "ghc-conf"
           (Just cEnv)
+    pure ()
 
-    case mbuildConfig of
-      Just bc -> liftIOException
-        doesNotExistErrorType
-        (FileDoesNotExistError bc)
-        (liftIO $ copyFile bc (build_mk workdir))
-      Nothing ->
-        liftIO $ B.writeFile (build_mk workdir) defaultConf
 
-    lift $ $(logInfo) [i|Building (this may take a while)...|]
-    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
-
-    if | isCross tver -> do
-          lift $ $(logInfo) [i|Installing cross toolchain...|]
-          lEM $ make ["install"] (Just workdir)
-          pure Nothing
-       | otherwise -> do
-          lift $ $(logInfo) [i|Creating bindist...|]
-          lEM $ make ["binary-dist"] (Just workdir)
-          [tar] <- liftIO $ findFiles
-            workdir
-            (makeRegexOpts compExtended
-                           execBlank
-                           ([s|^ghc-.*\.tar\..*$|] :: ByteString)
-            )
-          c       <- liftIO $ BL.readFile (workdir </> tar)
-          cDigest <-
-            fmap (T.take 8)
-            . lift
-            . throwEither
-            . E.decodeUtf8'
-            . B16.encode
-            . SHA256.hashlazy
-            $ c
-          cTime <- liftIO getCurrentTime
-          let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
-          let tarPath = cacheDir </> tarName
-          handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
-                                                                   tarPath
-          lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
-          pure $ Just tarPath
-
-  build_mk workdir = workdir </> "mk" </> "build.mk"
-
-  checkBuildConfig :: (MonadCatch m, MonadIO m)
-                   => Excepts
-                        '[FileDoesNotExistError, InvalidBuildConfig]
-                        m
-                        ()
-  checkBuildConfig = do
-    c <- case mbuildConfig of
-      Just bc -> do
-        liftIOException
-          doesNotExistErrorType
-          (FileDoesNotExistError bc)
-          (liftIO $ B.readFile bc)
-      Nothing -> pure defaultConf
-    let lines' = fmap T.strip . T.lines $ decUTF8Safe c
-
-   -- for cross, we need Stage1Only
-    case targetGhc of
-      Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
-        (InvalidBuildConfig
-          [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
-        )
-      _ -> pure ()
-
-  isCross :: GHCTargetVersion -> Bool
-  isCross = isJust . _tvTarget
 
 
 
@@ -1979,29 +2158,16 @@ upgradeGHCup mtarget force' = do
   dli   <- liftE $ getDownloadInfo GHCup latestVer
   tmp   <- lift withGHCupTmpDir
   let fn = "ghcup" <> exeExt
-  p <- liftE $ download dli tmp (Just fn)
+  p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
   let destDir = takeDirectory destFile
-      destFile = fromMaybe (binDir </> fn <> exeExt) mtarget
+      destFile = fromMaybe (binDir </> fn) mtarget
   lift $ $(logDebug) [i|mkdir -p #{destDir}|]
   liftIO $ createDirRecursive' destDir
-#if defined(IS_WINDOWS)
-  let tempGhcup = cacheDir </> "ghcup.old"
-  liftIO $ hideError NoSuchThing $ rmFile tempGhcup
-
-  lift $ $(logDebug) [i|mv #{destFile} #{tempGhcup}|]
-  -- NoSuchThing may be raised when we're updating ghcup from
-  -- a non-standard location
-  liftIO $ hideError NoSuchThing $ Win32.moveFileEx destFile (Just tempGhcup) 0
-  lift $ $(logDebug) [i|cp #{p} #{destFile}|]
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
-                                                           destFile
-#else
   lift $ $(logDebug) [i|rm -f #{destFile}|]
-  liftIO $ hideError NoSuchThing $ rmFile destFile
+  lift $ hideError NoSuchThing $ recycleFile destFile
   lift $ $(logDebug) [i|cp #{p} #{destFile}|]
   handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
                                                            destFile
-#endif
   lift $ chmod_755 destFile
 
   liftIO (isInPath destFile) >>= \b -> unless b $

lib/GHCup/Download.hs

@@ -55,20 +55,19 @@ import           Data.Aeson
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
 #if defined(INTERNAL_DOWNLOADER)
-import           Data.CaseInsensitive           ( CI )
+import           Data.CaseInsensitive           ( mk )
 #endif
 import           Data.List.Extra
 import           Data.Maybe
 import           Data.String.Interpolate
 import           Data.Time.Clock
 import           Data.Time.Clock.POSIX
-#if defined(INTERNAL_DOWNLOADER)
-import           Data.Time.Format
-#endif
 import           Data.Versions
-import           Data.Word8
+import           Data.Word8              hiding ( isSpace )
-import           GHC.IO.Exception
 import           Haskus.Utils.Variant.Excepts
+#if defined(INTERNAL_DOWNLOADER)
+import           Network.Http.Client     hiding ( URL )
+#endif
 import           Optics
 import           Prelude                 hiding ( abs
                                                 , readFile
@@ -76,8 +75,11 @@ import           Prelude                 hiding ( abs
                                                 )
 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
@@ -85,10 +87,8 @@ import qualified Data.ByteString               as B
 import qualified Data.ByteString.Base16        as B16
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map.Strict               as M
-#if defined(INTERNAL_DOWNLOADER)
-import qualified Data.CaseInsensitive          as CI
-#endif
 import qualified Data.Text                     as T
+import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Yaml                     as Y
 
@@ -115,6 +115,7 @@ getDownloadsF :: ( FromJSONKey Tool
                  , MonadLogger m
                  , MonadThrow m
                  , MonadFail m
+                 , MonadMask m
                  )
               => Excepts
                    '[JSONError , DownloadFailed , FileDoesNotExistError]
@@ -148,19 +149,14 @@ getDownloadsF = do
     in GHCupInfo tr newDownloads newGlobalTools
 
 
-readFromCache :: ( MonadReader env m
+yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
-                 , HasDirs env
+yamlFromCache uri = do
-                 , MonadIO m
+  Dirs{..} <- getDirs
-                 , MonadCatch m)
+  pure (cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri))
-              => URI
+
-              -> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
+
-readFromCache uri = do
+etagsFile :: FilePath -> FilePath
-  Dirs{..} <- lift getDirs
+etagsFile = (<.> "etags")
-  let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
-  handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
-    . liftIO
-    . L.readFile
-    $ yaml_file
 
 
 getBase :: ( MonadReader env m
@@ -170,35 +166,44 @@ getBase :: ( MonadReader env m
            , MonadIO m
            , MonadCatch m
            , MonadLogger m
+           , MonadMask m
            )
         => URI
-        -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
+        -> Excepts '[JSONError] m GHCupInfo
 getBase uri = do
   Settings { noNetwork } <- lift getSettings
-  bs <- if noNetwork
+  yaml <- lift $ yamlFromCache uri
-        then readFromCache uri
+  unless noNetwork $
-        else handleIO (\_ -> warnCache >> readFromCache uri)
+    handleIO (\e -> warnCache (displayException e))
-               . catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
+      . catchE @_ @_ @'[] (\e@(DownloadFailed _) -> warnCache (prettyShow e))
-               . reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed
+      . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed
-               $ smartDl uri
+      . smartDl
+      $ uri
   liftE
-    . lE' @_ @_ @'[JSONError] JSONDecodeError
+    . onE_ (onError yaml)
-    . first show
+    . lEM' @_ @_ @'[JSONError] JSONDecodeError
-    . Y.decodeEither'
+    . fmap (first (\e -> [i|#{displayException e}
-    . L.toStrict
+Consider removing "#{yaml}" manually.|]))
-    $ bs
+    . liftIO
+    . Y.decodeFileEither
+    $ yaml
  where
-  warnCache = lift $ $(logWarn)
+  -- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-      [i|Could not get download info, trying cached version (this may not be recent!)|]
+  -- may re-download and succeed.
+  onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
+  onError fp = do
+    let efp = etagsFile fp
+    handleIO (\e -> $(logWarn) [i|Couldn't remove file #{efp}, error was: #{displayException e}|])
+      (hideError doesNotExistErrorType $ rmFile efp)
+    liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
+  warnCache s = do
+    lift $ $(logWarn) [i|Could not get download info, trying cached version (this may not be recent!)|]
+    lift $ $(logDebug) [i|Error was: #{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
@@ -208,96 +213,37 @@ getBase uri = do
              , MonadIO m1
              , MonadFail m1
              , MonadLogger m1
+             , MonadMask m1
              )
           => URI
           -> Excepts
-               '[ FileDoesNotExistError
+               '[ DownloadFailed
-                , HTTPStatusError
+                , DigestError
-                , URIParseError
-                , UnsupportedScheme
-                , NoLocationHeader
-                , TooManyRedirs
-                , ProcessError
-                , NoNetwork
                 ]
                m1
-               L.ByteString
+               ()
   smartDl uri' = do
-    Dirs{..} <- lift getDirs
+    json_file <- lift $ yamlFromCache uri'
-    let path = view pathL' uri'
-    let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
     e <- liftIO $ doesFileExist json_file
+    currentTime <- liftIO getCurrentTime
     if e
       then do
         accessTime <- liftIO $ getAccessTime json_file
-        currentTime <- liftIO getCurrentTime
 
         -- access time won't work on most linuxes, but we can try regardless
-        if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
+        when ((utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300) $
-          then do -- no access in last 5 minutes, re-check upstream mod time
+          -- no access in last 5 minutes, re-check upstream mod time
-            getModTime >>= \case
+          dlWithMod currentTime json_file
-              Just modTime -> do
+      else
-                fileMod <- liftIO $ getModificationTime json_file
+        dlWithMod currentTime json_file
-                if modTime > fileMod
-                  then dlWithMod modTime json_file
-                  else liftIO $ L.readFile json_file
-              Nothing -> do
-                lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
-                dlWithoutMod json_file
-          else -- access in less than 5 minutes, re-use file
-               liftIO $ L.readFile json_file
-      else do
-        getModTime >>= \case
-          Just modTime -> dlWithMod modTime json_file
-          Nothing -> do
-            -- although we don't know last-modified, we still save
-            -- it to a file, so we might use it in offline mode
-            lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
-            dlWithoutMod json_file
-
    where
     dlWithMod modTime json_file = do
-      bs <- liftE $ downloadBS uri'
+      let (dir, fn) = splitFileName json_file
-      liftIO $ writeFileWithModTime modTime json_file bs
+      f <- liftE $ download uri' Nothing dir (Just fn) True
-      pure bs
+      liftIO $ setModificationTime f modTime
-    dlWithoutMod json_file = do
+      liftIO $ setAccessTime f modTime
-      bs <- liftE $ downloadBS uri'
-      liftIO $ hideError doesNotExistErrorType $ rmFile json_file
-      liftIO $ L.writeFile json_file bs
-      liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
-      pure bs
  
 
-    getModTime = do
-#if !defined(INTERNAL_DOWNLOADER)
-      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 -> FilePath -> L.ByteString -> IO ()
-  writeFileWithModTime utctime path content = do
-    L.writeFile path content
-    setModificationTime path utctime
-
 
 getDownloadInfo :: ( MonadReader env m
                    , HasPlatformReq env
@@ -356,39 +302,39 @@ download :: ( MonadReader env m
             , MonadLogger m
             , MonadIO m
             )
-         => DownloadInfo
+         => URI
+         -> Maybe T.Text      -- ^ expected hash
          -> FilePath          -- ^ destination dir
          -> Maybe FilePath    -- ^ optional filename
+         -> Bool              -- ^ whether to read an write etags
          -> Excepts '[DigestError , DownloadFailed] m FilePath
-download dli dest mfn
+download uri eDigest dest mfn etags
   | scheme == "https" = dl
   | scheme == "http"  = dl
   | scheme == "file"  = cp
   | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
 
  where
-  scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
+  scheme = view (uriSchemeL' % schemeBSL') uri
   cp     = do
     -- destination dir must exist
     liftIO $ createDirRecursive' dest
-    let destFile = getDestFile
     let fromFile = T.unpack . decUTF8Safe $ path
     liftIO $ copyFile fromFile destFile
     pure destFile
   dl = do
-    let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
+    let uri' = decUTF8Safe (serializeURIRef' uri)
     lift $ $(logInfo) [i|downloading: #{uri'}|]
 
     -- destination dir must exist
     liftIO $ createDirRecursive' dest
-    let destFile = getDestFile
 
     -- download
     flip onException
-         (liftIO $ hideError doesNotExistErrorType $ rmFile destFile)
+         (lift $ hideError doesNotExistErrorType $ recycleFile destFile)
      $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
           (\e ->
-            liftIO (hideError doesNotExistErrorType $ rmFile destFile)
+            lift (hideError doesNotExistErrorType $ recycleFile destFile)
               >> (throwE . DownloadFailed $ e)
           ) $ do
               Settings{ downloader, noNetwork } <- lift getSettings
@@ -396,28 +342,134 @@ download dli dest mfn
               case downloader of
                 Curl -> do
                   o' <- liftIO getCurlOpts
-                  liftE $ lEM @_ @'[ProcessError] $ exec "curl" 
+                  if etags
-                    (o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
+                    then do
+                      dh <- liftIO $ emptySystemTempFile "curl-header"
+                      flip finally (try @_ @SomeException $ rmFile dh) $
+                        flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
+                          metag <- readETag destFile
+                          liftE $ lEM @_ @'[ProcessError] $ exec "curl"
+                              (o' ++ (if etags then ["--dump-header", dh] else [])
+                                  ++ maybe [] (\t -> ["-H", [i|If-None-Match: #{t}|]]) metag
+                                  ++ ["-fL", "-o", destFile <.> "tmp", 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 $ headers of
+                            Just (http':sc:_)
+                              | sc == "304"
+                              , T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug [i|Status code was 304, not overwriting|]
+                              | T.pack "HTTP" `T.isPrefixOf` http' -> do
+                                  $logDebug [i|Status code was #{sc}, overwriting|]
+                                  liftIO $ copyFile (destFile <.> "tmp") destFile
+                            _ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
+                              :: V '[MalformedHeaders]))
+
+                          writeEtags (parseEtags headers)
+                    else
+                      liftE $ lEM @_ @'[ProcessError] $ exec "curl" 
+                        (o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
                 Wget -> do
-                  o' <- liftIO getWgetOpts
+                  destFileTemp <- liftIO $ emptySystemTempFile "wget-tmp"
-                  liftE $ lEM @_ @'[ProcessError] $ exec "wget" 
+                  flip finally (try @_ @SomeException $ rmFile destFileTemp) $ do
-                    (o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
+                    o' <- liftIO getWgetOpts
+                    if etags
+                      then do
+                        metag <- readETag destFile
+                        let opts = o' ++ maybe [] (\t -> ["--header", [i|If-None-Match: #{t}|]]) metag
+                                      ++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
+                        CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
+                        case _exitCode of
+                          ExitSuccess -> do
+                            liftIO $ copyFile destFileTemp destFile
+                            writeEtags (parseEtags (decUTF8Safe' _stdErr))
+                          ExitFailure i'
+                            | i' == 8
+                            , Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
+                                     -> do
+                                          $logDebug "Not modified, skipping download"
+                                          writeEtags (parseEtags (decUTF8Safe' _stdErr))
+                            | otherwise -> throwE (NonZeroExit i' "wget" opts)
+                      else do
+                        let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
+                        liftE $ lEM @_ @'[ProcessError] $ exec "wget" opts Nothing Nothing
+                        liftIO $ copyFile destFileTemp destFile
 #if defined(INTERNAL_DOWNLOADER)
                 Internal -> do
-                  (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
+                  (https, host, fullPath, port) <- liftE $ uriToQuadruple uri
-                  liftE $ downloadToFile https host fullPath port destFile
+                  if etags
+                    then do
+                      metag <- 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 (pure $ Just etag))
+                        $ do
+                          r <- downloadToFile https host fullPath port destFile addHeaders
+                          writeEtags (pure $ decUTF8Safe <$> getHeader r "etag")
+                    else void $ liftE $ catchE @HTTPNotModified
+                                        @'[DownloadFailed]
+                                   (\e@(HTTPNotModified _) ->
+                                     throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 e :: V '[HTTPNotModified])))
+                               $ downloadToFile https host fullPath port destFile mempty
 #endif
 
-    liftE $ checkDigest dli destFile
+    forM_ eDigest (liftE . flip checkDigest destFile)
     pure destFile
 
+
   -- Manage to find a file we can write the body into.
-  getDestFile :: FilePath
+  destFile :: FilePath
-  getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
+  destFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
                   (dest </>)
                   mfn
 
-  path = view (dlUri % pathL') dli
+  path = view pathL' uri
+
+  parseEtags :: (MonadLogger m, 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 $ stderr
+    case T.words <$> mEtag of
+      (Just []) -> do
+        $logDebug "Couldn't parse etags, no input: "
+        pure Nothing
+      (Just [_, etag']) -> do
+        $logDebug [i|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 :: (MonadLogger m, MonadIO m, MonadThrow m) => m (Maybe T.Text) -> m ()
+  writeEtags getTags = do
+    getTags >>= \case
+      Just t -> do
+        $logDebug [i|Writing etagsFile #{(etagsFile destFile)}|]
+        liftIO $ T.writeFile (etagsFile destFile) t
+      Nothing ->
+        $logDebug [i|No etags files written|]
+
+  readETag :: (MonadLogger m, 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 [i|Read etag: #{et}|]
+          pure (Just et)
+        (Left _) -> do
+          $logDebug [i|Etag file doesn't exist (yet)|]
+          pure Nothing
+    else do
+      $logDebug [i|Skipping and deleting etags file because destination file #{fp} doesn't exist|]
+      liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
+      pure Nothing
 
 
 -- | Download into tmpdir or use cached version, if it exists. If filename
@@ -441,7 +493,7 @@ downloadCached dli mfn = do
     True -> downloadCached' dli mfn Nothing
     False -> do
       tmp <- lift withGHCupTmpDir
-      liftE $ download dli tmp mfn
+      liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp mfn False
 
 
 downloadCached' :: ( MonadReader env m
@@ -465,9 +517,9 @@ downloadCached' dli mfn mDestDir = do
   fileExists <- liftIO $ doesFileExist cachfile
   if
     | fileExists -> do
-      liftE $ checkDigest dli cachfile
+      liftE $ checkDigest (view dlHash dli) cachfile
       pure cachfile
-    | otherwise -> liftE $ download dli destDir mfn
+    | otherwise -> liftE $ download (_dlUri dli) (Just (_dlHash dli)) destDir mfn False
 
 
 
@@ -478,73 +530,6 @@ downloadCached' dli mfn mDestDir = do
 
 
 
-
--- | This is used for downloading the JSON.
-downloadBS :: ( MonadReader env m
-              , HasSettings env
-              , MonadCatch m
-              , MonadIO m
-              , MonadLogger m
-              )
-           => URI
-           -> Excepts
-                '[ FileDoesNotExistError
-                 , HTTPStatusError
-                 , URIParseError
-                 , UnsupportedScheme
-                 , NoLocationHeader
-                 , TooManyRedirs
-                 , ProcessError
-                 , NoNetwork
-                 ]
-                m
-                L.ByteString
-downloadBS uri'
-  | scheme == "https"
-  = dl True
-  | scheme == "http"
-  = dl False
-  | scheme == "file"
-  = liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
-    (liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
-  | otherwise
-  = throwE UnsupportedScheme
-
- where
-  scheme = view (uriSchemeL' % schemeBSL') uri'
-  path   = view pathL' uri'
-#if defined(INTERNAL_DOWNLOADER)
-  dl https = do
-#else
-  dl _ = do
-#endif
-    lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
-    Settings{ downloader, noNetwork } <- lift getSettings
-    when noNetwork $ throwE NoNetwork
-    case downloader of
-      Curl -> do
-        o' <- liftIO getCurlOpts
-        let exe = "curl"
-            args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
-        lift (executeOut exe args Nothing) >>= \case
-          CapturedProcess ExitSuccess stdout _ -> do
-            pure stdout
-          CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
-      Wget -> do
-        o' <- liftIO getWgetOpts
-        let exe = "wget"
-            args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
-        lift (executeOut exe args Nothing) >>= \case
-          CapturedProcess ExitSuccess stdout _ -> do
-            pure stdout
-          CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
-#if defined(INTERNAL_DOWNLOADER)
-      Internal -> do
-        (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
-        liftE $ downloadBS' https host' fullPath' port'
-#endif
-
-
 checkDigest :: ( MonadReader env m
                , HasDirs env
                , HasSettings env
@@ -552,10 +537,10 @@ checkDigest :: ( MonadReader env m
                , MonadThrow m
                , MonadLogger m
                )
-            => DownloadInfo
+            => T.Text     -- ^ the hash
             -> FilePath
             -> Excepts '[DigestError] m ()
-checkDigest dli file = do
+checkDigest eDigest file = do
   Settings{ noVerify } <- lift getSettings
   let verify = not noVerify
   when verify $ do
@@ -563,7 +548,6 @@ checkDigest dli file = do
     lift $ $(logInfo) [i|verifying digest of: #{p'}|]
     c <- liftIO $ L.readFile file
     cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
-    let eDigest = view dlHash dli
     when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
 
 

lib/GHCup/Download/IOStreams.hs

@@ -9,9 +9,7 @@ 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
@@ -20,7 +18,7 @@ import           Control.Monad
 import           Control.Monad.Reader
 import           Data.ByteString                ( ByteString )
 import           Data.ByteString.Builder
-import           Data.CaseInsensitive           ( CI )
+import           Data.CaseInsensitive           ( CI, original, mk )
 import           Data.IORef
 import           Data.Maybe
 import           Data.Text.Read
@@ -32,7 +30,6 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           System.ProgressBar
-import           System.IO
 import           URI.ByteString
 
 import qualified Data.ByteString               as BS
@@ -67,7 +64,7 @@ downloadBS' :: MonadIO m
 downloadBS' https host path port = do
   bref <- liftIO $ newIORef (mempty :: Builder)
   let stepper bs = modifyIORef bref (<> byteString bs)
-  downloadInternal False https host path port stepper
+  void $ downloadInternal False https host path port stepper (pure ()) mempty
   liftIO (readIORef bref <&> toLazyByteString)
 
 
@@ -77,12 +74,17 @@ downloadToFile :: (MonadMask m, MonadIO m)
                -> ByteString       -- ^ path (e.g. "/my/file") including query
                -> Maybe Int        -- ^ optional port (e.g. 3000)
                -> FilePath         -- ^ destination file to create and write to
-               -> Excepts '[DownloadFailed] m ()
+               -> M.Map (CI ByteString) ByteString -- ^ additional headers
-downloadToFile https host fullPath port destFile = do
+               -> Excepts '[DownloadFailed, HTTPNotModified] m Response
-  fd <- liftIO $ openFile destFile WriteMode
+downloadToFile https host fullPath port destFile addHeaders = do
-  let stepper = BS.hPut fd
+  let stepper = BS.appendFile destFile
-  flip finally (liftIO $ hClose fd)
+      setup = BS.writeFile destFile mempty
-    $ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
+  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
 
 
 downloadInternal :: MonadIO m
@@ -92,6 +94,8 @@ 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
@@ -100,19 +104,21 @@ downloadInternal :: MonadIO m
                        , TooManyRedirs
                        ]
                       m
-                      ()
+                      Response
 downloadInternal = go (5 :: Int)
 
  where
-  go redirs progressBar https host path port consumer = do
+  go redirs progressBar https host path port consumer setup addHeaders = do
     r <- liftIO $ withConnection' https host port action
     veitherToExcepts r >>= \case
-      Just r' ->
+      Right r' ->
         if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
-      Nothing -> pure ()
+      Left res -> pure res
    where
     action c = do
-      let q = buildRequest1 $ http GET path
+      let q = buildRequest1 $ do
+                http GET path
+                flip M.traverseWithKey addHeaders $ \key val -> setHeader (original key) val
 
       sendRequest c q emptyBody
 
@@ -121,28 +127,30 @@ downloadInternal = go (5 :: Int)
         (\r i' -> runE $ do
           let scode = getStatusCode r
           if
-            | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
+            | scode >= 200 && scode < 300 -> liftIO $ downloadStream r i' >> pure (Left r)
+            | scode == 304 -> throwE $ HTTPStatusError scode (getHeaderMap r)
             | scode >= 300 && scode < 400 -> case getHeader r "Location" of
-              Just r' -> pure $ Just r'
+              Just r' -> pure $ Right r'
               Nothing -> throwE NoLocationHeader
-            | otherwise -> throwE $ HTTPStatusError scode
+            | otherwise -> throwE $ HTTPStatusError scode (getHeaderMap r)
         )
 
     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
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer setup addHeaders
       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 <- if progressBar
+      (mpb :: Maybe (ProgressBar ())) <- if progressBar
-        then Just <$> liftIO (newProgressBar defStyle 10 (Progress 0 size ()))
+        then Just <$> newProgressBar defStyle 10 (Progress 0 size ())
         else pure Nothing
 
       outStream <- liftIO $ Streams.makeOutputStream
@@ -155,79 +163,6 @@ 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

lib/GHCup/Errors.hs

@@ -27,14 +27,18 @@ import           Codec.Archive
 import qualified Codec.Archive.Tar             as Tar
 #endif
 import           Control.Exception.Safe
+import           Data.ByteString                ( ByteString )
+import           Data.CaseInsensitive           ( CI )
 import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           Haskus.Utils.Variant
-import           Text.PrettyPrint
+import           Text.PrettyPrint               hiding ( (<>) )
-import           Text.PrettyPrint.HughesPJClass
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           URI.ByteString
 
+import qualified Data.Map.Strict               as M
+
 
 
     ------------------------
@@ -180,13 +184,29 @@ instance Pretty DigestError where
     text [i|Digest error: expected "#{expectedDigest}", but got "#{currentDigest}"|]
 
 -- | Unexpected HTTP status.
-data HTTPStatusError = HTTPStatusError Int
+data HTTPStatusError = HTTPStatusError Int (M.Map (CI ByteString) ByteString)
   deriving Show
 
 instance Pretty HTTPStatusError where
-  pPrint (HTTPStatusError status) =
+  pPrint (HTTPStatusError status _) =
     text [i|Unexpected HTTP status: #{status}|]
 
+-- | Malformed headers.
+data MalformedHeaders = MalformedHeaders Text
+  deriving Show
+
+instance Pretty MalformedHeaders where
+  pPrint (MalformedHeaders h) =
+    text [i|Headers are malformed: #{h}|]
+
+-- | Unexpected HTTP status.
+data HTTPNotModified = HTTPNotModified Text
+  deriving Show
+
+instance Pretty HTTPNotModified where
+  pPrint (HTTPNotModified etag) =
+    text [i|Remote resource not modifed, etag was: #{etag}|]
+
 -- | The 'Location' header was expected during a 3xx redirect, but not found.
 data NoLocationHeader = NoLocationHeader
   deriving Show
@@ -240,6 +260,13 @@ instance Pretty NoNetwork where
   pPrint NoNetwork =
     text [i|A download was required or requested, but '--offline' was specified.|]
 
+data HadrianNotFound = HadrianNotFound
+  deriving Show
+
+instance Pretty HadrianNotFound where
+  pPrint HadrianNotFound =
+    text [i|Could not find Hadrian build files. Does this GHC version support Hadrian builds?|]
+
 
     -------------------------
     --[ High-level errors ]--
@@ -256,11 +283,11 @@ deriving instance Show DownloadFailed
 
 
 -- | A build failed.
-data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
+data BuildFailed = forall es . (Pretty (V es), Show (V es)) => BuildFailed FilePath (V es)
 
 instance Pretty BuildFailed where
   pPrint (BuildFailed path reason) =
-    text [i|BuildFailed failed in dir "#{path}": #{reason}|]
+    text [i|BuildFailed failed in dir "#{path}": |] <> pPrint reason
 
 deriving instance Show BuildFailed
 

lib/GHCup/Types.hs

@@ -384,6 +384,7 @@ data Dirs = Dirs
   , cacheDir :: FilePath
   , logsDir  :: FilePath
   , confDir  :: FilePath
+  , recycleDir :: FilePath -- mainly used on windows
   }
   deriving (Show, GHC.Generic)
 

lib/GHCup/Types/Optics.hs

@@ -1,9 +1,11 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE MultiParamTypeClasses   #-}
 
 {-|
 Module      : GHCup.Types.Optics
@@ -143,3 +145,6 @@ 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

@@ -53,6 +53,7 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
+import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
 #if defined(IS_WINDOWS)
 import           Data.Bits
 #endif
@@ -78,6 +79,7 @@ import           System.Win32.Console
 import           System.Win32.File     hiding ( copyFile )
 import           System.Win32.Types
 #endif
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
 import           URI.ByteString
 
@@ -122,6 +124,7 @@ rmMinorSymlinks :: ( MonadReader env m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
+                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
@@ -133,7 +136,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
     let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
     let fullF = binDir </> f_xyz
     lift $ $(logDebug) [i|rm -f #{fullF}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+    lift $ hideError doesNotExistErrorType $ rmLink fullF
 
 
 -- | Removes the set ghc version for the given target, if any.
@@ -143,6 +146,7 @@ rmPlain :: ( MonadReader env m
            , MonadThrow m
            , MonadFail m
            , MonadIO m
+           , MonadMask m
            )
         => Maybe Text -- ^ target
         -> Excepts '[NotInstalled] m ()
@@ -154,11 +158,11 @@ rmPlain target = do
     forM_ files $ \f -> do
       let fullF = binDir </> f <> exeExt
       lift $ $(logDebug) [i|rm -f #{fullF}|]
-      liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+      lift $ hideError doesNotExistErrorType $ rmLink fullF
     -- old ghcup
     let hdc_file = binDir </> "haddock-ghc" <> exeExt
     lift $ $(logDebug) [i|rm -f #{hdc_file}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink hdc_file
+    lift $ hideError doesNotExistErrorType $ rmLink hdc_file
 
 
 -- | Remove the major GHC symlink, e.g. ghc-8.6.
@@ -168,6 +172,7 @@ rmMajorSymlinks :: ( MonadReader env m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
+                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
@@ -181,7 +186,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
     let f_xy = f <> "-" <> T.unpack v' <> exeExt
     let fullF = binDir </> f_xy
     lift $ $(logDebug) [i|rm -f #{fullF}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+    lift $ hideError doesNotExistErrorType $ rmLink fullF
 
 
 
@@ -761,49 +766,22 @@ ghcToolFiles ver = do
   whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
         (throwE (NotInstalled GHC ver))
 
-  files    <- liftIO $ listDirectory bindir
+  files <- liftIO (listDirectory bindir >>= filterM (doesFileExist . (bindir </>)))
-  -- figure out the <ver> suffix, because this might not be `Version` for
+  pure (getUniqueTools . groupToolFiles . fmap (dropSuffix exeExt) $ files)
-  -- alpha/rc releases, but x.y.a.somedate.
 
-  ghcIsHadrian    <- liftIO $ isHadrian bindir
-  onlyUnversioned <- case ghcIsHadrian of
-    Right () -> pure id
-    Left (fmap (dropSuffix exeExt) -> [ghc, ghc_ver])
-      | (Just symver) <- stripPrefix (ghc <> "-") ghc_ver
-      , not (null symver) -> pure $ filter (\x -> not $ symver `isInfixOf` x)
-    _ -> fail "Fatal: Could not find internal GHC version"
-
-  pure $ onlyUnversioned $ fmap (dropSuffix exeExt) files
  where
-  isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
-    -- GHC is moving some builds to Hadrian for bindists,
-    -- which doesn't create versioned binaries.
-    -- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
-  isHadrian :: FilePath -- ^ ghcbin path
-            -> IO (Either [String] ()) -- ^ Right for Hadrian
-  isHadrian dir = do
-    -- Non-hadrian has e.g. ["ghc", "ghc-8.10.4"]
-    -- which also requires us to discover the internal version
-    -- to filter the correct tool files.
-    -- We can't use the symlink on windows, so we fall back to some
-    -- more complicated logic.
-    fs <- fmap
-         -- regex over-matches
-         (filter (isNotAnyInfix ["haddock", "ghc-pkg", "ghci"]))
-       $ liftIO $ findFiles
-      dir
-      (makeRegexOpts compExtended
-                     execBlank
-                     -- for cross, this won't be "ghc", but e.g.
-                     -- "armv7-unknown-linux-gnueabihf-ghc"
-                     ([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc.*$|] :: ByteString)
-      )
-    if | length fs == 1 -> pure $ Right ()        -- hadrian
-       | length fs == 2 -> pure $ Left
-                              (sortOn length fs)  -- legacy make, result should
-                                                  -- be ["ghc", "ghc-8.10.4"]
-       | otherwise      -> fail "isHadrian failed!"
 
+  groupToolFiles :: [FilePath] -> [[(FilePath, String)]]
+  groupToolFiles = groupBy (\(a, _) (b, _) -> a == b) . fmap (splitOnPVP "-")
+
+  getUniqueTools :: [[(FilePath, String)]] -> [String]
+  getUniqueTools = filter (isNotAnyInfix blackListedTools) . nub . fmap fst . filter ((== "") . snd) . concat
+
+  blackListedTools :: [String]
+  blackListedTools = ["haddock-ghc"]
+
+  isNotAnyInfix :: [String] -> String -> Bool
+  isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
 
 
 -- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
@@ -882,8 +860,17 @@ getChangeLog dls tool (Right tag) =
 --
 --   1. the build directory, depending on the KeepDirs setting
 --   2. the install destination, depending on whether the build failed
-runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
+runBuildAction :: ( Pretty (V e)
-               => FilePath          -- ^ build directory (cleaned up depending on Settings)
+                  , Show (V e)
+                  , MonadReader env m
+                  , HasDirs env
+                  , HasSettings env
+                  , MonadIO m
+                  , MonadMask m
+                  , MonadLogger m
+                  , MonadUnliftIO m
+                  )
+               => FilePath        -- ^ build directory (cleaned up depending on Settings)
                -> Maybe FilePath  -- ^ dir to *always* clean up on exception
                -> Excepts e m a
                -> Excepts '[BuildFailed] m a
@@ -891,11 +878,9 @@ runBuildAction bdir instdir action = do
   Settings {..} <- lift getSettings
   let exAction = do
         forM_ instdir $ \dir ->
-          liftIO $ hideError doesNotExistErrorType $ rmPath dir
+          lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
         when (keepDirs == Never)
-          $ liftIO
+          $ lift $ rmBDir bdir
-          $ hideError doesNotExistErrorType
-          $ rmPath bdir
   v <-
     flip onException exAction
     $ catchAllE
@@ -904,10 +889,20 @@ runBuildAction bdir instdir action = do
           throwE (BuildFailed bdir es)
         ) action
 
-  when (keepDirs == Never || keepDirs == Errors) $ liftIO $ rmPath bdir
+  when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
   pure v
 
 
+-- | Remove a build directory, ignoring if it doesn't exist and gracefully
+-- printing other errors without crashing.
+rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
+rmBDir dir = withRunInIO (\run -> run $
+           liftIO $ handleIO (\e -> run $ $(logWarn)
+               [i|Couldn't remove build dir #{dir}, error was: #{displayException e}|])
+           $ hideError doesNotExistErrorType
+           $ rmPathForcibly dir)
+
+
 getVersionInfo :: Version
                -> Tool
                -> GHCupDownloads
@@ -994,13 +989,13 @@ pathIsLink = pathIsSymbolicLink
 #endif
 
 
-rmLink :: FilePath -> IO ()
+rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
 #if defined(IS_WINDOWS)
 rmLink fp = do
-  hideError doesNotExistErrorType . liftIO . rmFile $ fp
+  hideError doesNotExistErrorType . recycleFile $ fp
-  hideError doesNotExistErrorType . liftIO . rmFile $ (dropExtension fp <.> "shim")
+  hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
 #else
-rmLink = hideError doesNotExistErrorType . liftIO . rmFile
+rmLink = hideError doesNotExistErrorType . recycleFile
 #endif
 
 
@@ -1038,14 +1033,14 @@ createLink link exe = do
       shimContents = "path = " <> fullLink
 
   $(logDebug) [i|rm -f #{exe}|]
-  liftIO $ rmLink exe
+  rmLink exe
 
   $(logDebug) [i|ln -s #{fullLink} #{exe}|]
   liftIO $ copyFile shimGen exe
   liftIO $ writeFile shim shimContents
 #else
   $(logDebug) [i|rm -f #{exe}|]
-  liftIO $ hideError doesNotExistErrorType $ rmFile exe
+  hideError doesNotExistErrorType $ recycleFile exe
 
   $(logDebug) [i|ln -s #{link} #{exe}|]
   liftIO $ createFileLink link exe
@@ -1067,7 +1062,6 @@ ensureGlobalTools :: ( MonadMask m
 ensureGlobalTools = do
 #if defined(IS_WINDOWS)
   (GHCupInfo _ _ gTools) <- lift getGHCupInfo
-  settings <- lift getSettings
   dirs <- lift getDirs
   shimDownload <- liftE $ lE @_ @'[NoDownload]
     $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
@@ -1075,7 +1069,7 @@ ensureGlobalTools = do
   void $ (\(DigestError _ _) -> do
       lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
       lift $ $(logDebug) [i|rm -f #{shimDownload}|]
-      liftIO $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
+      lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
       liftE @'[DigestError , DownloadFailed] $ dl
     ) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
   pure ()
@@ -1086,19 +1080,14 @@ ensureGlobalTools = do
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories dirs = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
-  let Dirs
-        { baseDir
-        , binDir
-        , cacheDir
-        , logsDir
-        , confDir
-        } = dirs
   createDirRecursive' baseDir
+  createDirRecursive' (baseDir </> "ghc")
   createDirRecursive' binDir
   createDirRecursive' cacheDir
   createDirRecursive' logsDir
   createDirRecursive' confDir
+  createDirRecursive' trashDir
   pure ()
 
 
@@ -1112,4 +1101,3 @@ ensureDirectories dirs = do
 ghcBinaryName :: GHCTargetVersion -> String
 ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
 ghcBinaryName (GHCTargetVersion Nothing  v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
-

lib/GHCup/Utils/Dirs.hs

@@ -30,6 +30,7 @@ module GHCup.Utils.Dirs
 #if !defined(IS_WINDOWS)
   , useXDG
 #endif
+  , cleanupTrash
   )
 where
 
@@ -53,9 +54,7 @@ import           Data.String.Interpolate
 import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
 import           Haskus.Utils.Variant.Excepts
 import           Optics
-#if !defined(IS_WINDOWS)
 import           System.Directory                                                
-#endif
 import           System.DiskSpace                                                
 import           System.Environment
 import           System.FilePath
@@ -191,13 +190,21 @@ ghcupLogsDir = do
 #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
+  baseDir    <- ghcupBaseDir
-  binDir   <- ghcupBinDir
+  binDir     <- ghcupBinDir
-  cacheDir <- ghcupCacheDir
+  cacheDir   <- ghcupCacheDir
-  logsDir  <- ghcupLogsDir
+  logsDir    <- ghcupLogsDir
-  confDir  <- ghcupConfigDir
+  confDir    <- ghcupConfigDir
+  recycleDir <- ghcupRecycleDir
   pure Dirs { .. }
 
 
@@ -252,7 +259,15 @@ parseGHCupGHCDir (T.pack -> fp) =
   throwEither $ MP.parse ghcTargetVerP "" fp
 
 
-mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
+mkGhcupTmpDir :: ( MonadReader env m
+                 , HasDirs env
+                 , MonadUnliftIO m
+                 , MonadLogger m
+                 , MonadCatch m
+                 , MonadThrow m
+                 , MonadMask m
+                 , MonadIO m)
+              => m FilePath
 mkGhcupTmpDir = do
   tmpdir <- liftIO getCanonicalTemporaryDirectory
 
@@ -273,8 +288,25 @@ mkGhcupTmpDir = do
       where t = 10^n
 
 
-withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
+withGHCupTmpDir :: ( MonadReader env m
-withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
+                   , HasDirs env
+                   , MonadUnliftIO m
+                   , MonadLogger 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) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|])
+            . rmPathForcibly
+            $ fp))
 
 
 
@@ -302,3 +334,21 @@ relativeSymlink p1 p2 =
         <> joinPath ([pathSeparator] : drop (length common) d2)
 
 
+cleanupTrash :: ( MonadIO m
+                , MonadMask m
+                , MonadLogger m
+                , MonadReader env m
+                , HasDirs env
+                )
+             => m ()
+cleanupTrash = do
+  Dirs { recycleDir } <- getDirs
+  contents <- liftIO $ listDirectory recycleDir
+  if null contents
+  then pure ()
+  else do
+    $(logWarn) [i|Removing leftover files in #{recycleDir}|]
+    forM_ contents (\fp -> handleIO (\e ->
+        $(logDebug) [i|Resource cleanup failed for "#{fp}", error was: #{displayException e}|]
+      ) $ liftIO $ removePathForcibly (recycleDir </> fp))
+

lib/GHCup/Utils/File/Windows.hs

@@ -209,6 +209,20 @@ exec exe args chdir env = do
   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

lib/GHCup/Utils/Logger.hs

@@ -14,12 +14,16 @@ Here we define our main logger.
 -}
 module GHCup.Utils.Logger where
 
+import           GHCup.Types
+import           GHCup.Types.Optics
 import           GHCup.Utils.File
 import           GHCup.Utils.String.QQ
 
+import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Logger
+import           Control.Monad.Reader
 import           Data.Char               ( ord )
 import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
@@ -79,17 +83,21 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
     rawOutter outr
 
 
-initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
+initGHCupFileLogging :: ( MonadReader env m
-initGHCupFileLogging logsDir = do
+                        , HasDirs env
+                        , MonadIO m
+                        , MonadMask m
+                        ) => m FilePath
+initGHCupFileLogging = do
+  Dirs { logsDir } <- getDirs
   let logfile = logsDir </> "ghcup.log"
-  liftIO $ do
+  logFiles <- liftIO $ findFiles
-    logFiles <- findFiles
+    logsDir
-      logsDir
+    (makeRegexOpts compExtended
-      (makeRegexOpts compExtended
+                   execBlank
-                     execBlank
+                   ([s|^.*\.log$|] :: B.ByteString)
-                     ([s|^.*\.log$|] :: B.ByteString)
+    )
-      )
+  forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
-    forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
 
-    writeFile logfile ""
+  liftIO $ writeFile logfile ""
-    pure logfile
+  pure logfile

lib/GHCup/Utils/Prelude.hs

@@ -19,14 +19,19 @@ GHCup specific prelude. Lots of Excepts functionality.
 -}
 module GHCup.Utils.Prelude where
 
+#if defined(IS_WINDOWS)
+import           GHCup.Types
+#endif
+import           GHCup.Types.Optics
+
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
-import           Control.Monad.Trans.Class      ( lift )
+import           Control.Monad.Reader
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( nub )
+import           Data.List                      ( nub, intercalate )
 import           Data.Foldable
 import           Data.String
 import           Data.Text                      ( Text )
@@ -35,6 +40,9 @@ import           Data.Word8
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           System.IO.Error
+#if defined(IS_WINDOWS)
+import           System.IO.Temp
+#endif
 import           System.IO.Unsafe
 import           System.Directory
 import           System.FilePath
@@ -47,6 +55,7 @@ import           GHC.IO.Exception
 import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
+import qualified Data.List.Split               as Split
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified Data.Text.Encoding.Error      as E
@@ -54,6 +63,9 @@ 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
 
 
 
@@ -312,17 +324,16 @@ createDirRecursive' p =
 -- | Recursively copy the contents of one directory to another path.
 --
 -- This is a rip-off of Cabal library.
-copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
+copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
-copyDirectoryRecursive srcDir destDir = do
+copyDirectoryRecursive srcDir destDir doCopy = do
   srcFiles <- getDirectoryContentsRecursive srcDir
-  copyFilesWith copyFile destDir [ (srcDir, f)
+  copyFilesWith destDir [ (srcDir, f)
-                                   | f <- srcFiles ]
+                          | f <- srcFiles ]
   where
     -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
     -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
-    copyFilesWith :: (FilePath -> FilePath -> IO ())
+    copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
-                  -> FilePath -> [(FilePath, FilePath)] -> IO ()
+    copyFilesWith targetDir srcFiles = do
-    copyFilesWith doCopy targetDir srcFiles = do
 
       -- Create parent directories for everything
       let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
@@ -367,42 +378,117 @@ getDirectoryContentsRecursive topdir = recurseDirectories [""]
         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
-rmPath :: (MonadIO m, MonadMask m)
+recyclePathForcibly :: ( MonadIO m
-      => FilePath
+                       , MonadReader env m
-      -> m ()
+                       , HasDirs env
-rmPath fp =
+                       , MonadMask m
+                       )
+                    => FilePath
+                    -> m ()
+recyclePathForcibly fp = do
 #if defined(IS_WINDOWS)
-  recovering (fullJitterBackoff 25000 <> limitRetries 10)
+  Dirs { recycleDir } <- getDirs
-    [\_ -> Handler (\e -> pure $ isPermissionError e)
+  tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
-    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+  let dest = tmp </> takeFileName fp
-    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+  liftIO (Win32.moveFileEx fp (Just dest) 0)
-    ]
+      `catch`
-    (\_ -> liftIO $ removePathForcibly fp)
+      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+      `finally`
+        (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
 #else
-  liftIO $ removeDirectoryRecursive fp
+  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
-rmFile :: (MonadIO m, MonadMask m)
+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)
-  recovering (fullJitterBackoff 25000 <> limitRetries 10)
+  recover (liftIO $ removeFile fp)
-    [\_ -> Handler (\e -> pure $ isPermissionError e)
-    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
-    ]
-    (\_ -> 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
+
+
 -- Gathering monoidal values
 traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
 traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
@@ -420,8 +506,32 @@ stripNewline s
   | otherwise            = head s : stripNewline (tail s)
 
 
+-- | Strip @\\r@ and @\\n@ from 'ByteString's
+stripNewline' :: T.Text -> T.Text
+stripNewline' s
+  | T.null s               = mempty
+  | T.head s `elem` "\n\r" = stripNewline' (T.tail s)
+  | otherwise              = T.singleton (T.head s) <> stripNewline' (T.tail s)
+
+
 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, "")

stack.yaml

@@ -10,6 +10,9 @@ extra-deps:
   - git: https://github.com/Bodigrim/tar
     commit: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
 
+  - git: https://github.com/jtdaugherty/brick.git
+    commit: b3b96cfe66dfd398d338e3feb2b6855e66a35190
+
   - IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
   - ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
   - base16-bytestring-0.1.1.7@sha256:0021256a9628971c08da95cb8f4d0d72192f3bb8a7b30b55c080562d17c43dd3,2231

www/index.html

@@ -67,7 +67,7 @@
 			<div>
 			<div class="command-button"><pre><span class='ghcup-command'>Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button>
 			</div>
-				<p class="other-help">If you want to run an interactive installation, change <span class='code'>$true</span> to <span class='code'>$false</span> at the end of the script.</p>
+				<p class="other-help">If you want to run an non-interactive installation, change <span class='code'>$true</span> to <span class='code'>$false</span> at the end of the script.</p>
 			</div>
         </p>
 		<p>If you're a Windows Subsystem 2 for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
@@ -128,7 +128,10 @@
         <div>
           <p>
             If you are running Windows,<br/>run the following in a powershell session (as a non-admin user).
-			<div class="command-button"><pre><span class='ghcup-command'>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</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
+			<div class="command-button"><pre><span class='ghcup-command'>Set-ExecutionPolicy Bypass -Scope Process -Force;[System.Net.ServicePointManager]::SecurityProtocol = [System.Net.ServicePointManager]::SecurityProtocol -bor 3072;Invoke-Command -ScriptBlock ([ScriptBlock]::Create((Invoke-WebRequest https://www.haskell.org/ghcup/sh/bootstrap-haskell.ps1 -UseBasicParsing))) -ArgumentList $true</span></span></pre><button class="tooltip" onclick="copyToClipboardPowershell()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button>
+			</div>
+				<p class="other-help">If you want to run a non-interactive installation, change <span class='code'>$true</span> to <span class='code'>$false</span> at the end of the script.</p>
+			</div>
           </p>
         </div>