Redo file handling wrt #165 and #187

Fixes #183

.gitlab-ci.yml

@@ -21,6 +21,7 @@ variables:
     OS: "LINUX"
     ARCH: "64"
     CABAL_DIR: "$CI_PROJECT_DIR/cabal"
+    CROSS: ""
 
 .alpine:64bit:
   image: "alpine:3.12"
@@ -268,6 +269,44 @@ test:linux:latest:
     CABAL_VERSION: "3.4.0.0"
   needs: []
 
+test:linux:cross-armv7:
+  stage: test
+  extends:
+    - .test_ghcup_version
+    - .debian
+  variables:
+    GHC_VERSION: "8.10.4"
+    GHC_TARGET_VERSION: "8.10.5"
+    CABAL_VERSION: "3.4.0.0"
+    CROSS: "arm-linux-gnueabihf"
+  needs: []
+  when: manual
+  allow_failure: true
+  before_script:
+    - ./.gitlab/before_script/linux/install_deps.sh
+  script:
+    - ./.gitlab/script/ghcup_cross.sh
+
+test:linux:git:hadrian:
+  stage: test
+  extends:
+    - .test_ghcup_version
+    - .debian
+  variables:
+    GHC_VERSION: "8.10.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 ########
 
 test:linux:recommended:32bit:
@@ -286,6 +325,7 @@ test:linux:recommended:armv7:
   variables:
     GHC_VERSION: "8.10.4"
     CABAL_VERSION: "3.4.0.0"
+    CROSS: ""
   when: manual
   needs: []
 
@@ -295,6 +335,7 @@ test:linux:recommended:aarch64:
   variables:
     GHC_VERSION: "8.10.4"
     CABAL_VERSION: "3.4.0.0"
+    CROSS: ""
   when: manual
   needs: []
 
@@ -394,6 +435,7 @@ release:linux:armv7:
     ARTIFACT: "armv7-linux-ghcup"
     GHC_VERSION: "8.10.4"
     CABAL_VERSION: "3.4.0.0"
+    CROSS: ""
 
 release:linux:aarch64:
   stage: release
@@ -407,6 +449,7 @@ release:linux:aarch64:
     ARTIFACT: "aarch64-linux-ghcup"
     GHC_VERSION: "8.10.4"
     CABAL_VERSION: "3.4.0.0"
+    CROSS: ""
 
 ######## darwin release ########
 

.gitlab/before_script/linux/install_deps.sh

@@ -9,6 +9,13 @@ mkdir -p "${TMPDIR}"
 sudo apt-get update -y
 sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget lsb-release software-properties-common gnupg2 apt-transport-https
 
+if [ "${CROSS}" = "arm-linux-gnueabihf" ] ; then
+	sudo apt-get install -y autoconf build-essential gcc-arm-linux-gnueabihf
+	sudo dpkg --add-architecture armhf
+	sudo apt-get update -y
+	sudo apt-get install -y libncurses-dev:armhf
+fi
+
 case "${ARCH}" in
 	ARM*)
 		case "${ARCH}" in
@@ -57,9 +64,9 @@ case "${ARCH}" in
 		chmod +x ghcup-bin
 
 		./ghcup-bin upgrade -i -f
-		./ghcup-bin install ${GHC_VERSION}
+		./ghcup-bin install ghc ${GHC_VERSION}
-		./ghcup-bin set ${GHC_VERSION}
+		./ghcup-bin set ghc ${GHC_VERSION}
-		./ghcup-bin install-cabal ${CABAL_VERSION}
+		./ghcup-bin install cabal ${CABAL_VERSION}
 
 		;;
 esac

.gitlab/script/ghcup_cross.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) -v ${GHC_TARGET_VERSION} -b ${GHC_VERSION} -x ${CROSS} -- --enable-unregisterised
+eghcup set ghc ${CROSS}-${GHC_TARGET_VERSION}
+
+[ `$(eghcup whereis ghc ${CROSS}-${GHC_TARGET_VERSION}) --numeric-version` = "${GHC_TARGET_VERSION}" ]
+
+# nuke
+eghcup nuke
+[ ! -e "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup" ]
+

.gitlab/script/ghcup_git.sh

@@ -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_release.sh

@@ -15,10 +15,6 @@ git describe
 # build
 ecabal update
 
-(
-	cd /tmp
-	ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
-)
 
 if [ "${OS}" = "LINUX" ] ; then
 	if [ "${ARCH}" = "32" ] ; then

.gitlab/script/ghcup_version.sh

@@ -26,11 +26,6 @@ git describe --always
 
 ecabal update
 
-(
-	cd /tmp
-	ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hspec-discover
-)
-
 if [ "${OS}" = "DARWIN" ] ; then
 	ecabal build -w ghc-${GHC_VERSION} -ftui
 	ecabal test -w ghc-${GHC_VERSION} -ftui ghcup-test
@@ -83,10 +78,10 @@ ghcup-gen check -f ghcup-${JSON_VERSION}.yaml
 
 eghcup --numeric-version
 
-eghcup install ${GHC_VERSION}
+eghcup install ghc ${GHC_VERSION}
 [ `$(eghcup whereis ghc ${GHC_VERSION}) --numeric-version` = "${GHC_VERSION}" ]
-eghcup set ${GHC_VERSION}
+eghcup set ghc ${GHC_VERSION}
-eghcup install-cabal ${CABAL_VERSION}
+eghcup install cabal ${CABAL_VERSION}
 [ `$(eghcup whereis cabal ${CABAL_VERSION}) --numeric-version` = "${CABAL_VERSION}" ]
 
 cabal --version
@@ -112,17 +107,19 @@ else
 	# test installing new ghc doesn't mess with currently set GHC
 	# https://gitlab.haskell.org/haskell/ghcup-hs/issues/7
 	if [ "${OS}" = "LINUX" ] ; then
-		eghcup --downloader=wget install 8.10.3
+		eghcup --downloader=wget prefetch ghc 8.10.3
+		eghcup --offline install ghc 8.10.3
 	else # test wget a bit
-		eghcup install 8.10.3
+		eghcup prefetch ghc 8.10.3
+		eghcup --offline install ghc 8.10.3
 	fi
 	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
-	eghcup set 8.10.3
+	eghcup --offline set 8.10.3
 	eghcup set 8.10.3
 	[ "$(ghc --numeric-version)" = "8.10.3" ]
 	eghcup set ${GHC_VERSION}
 	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
-	eghcup rm 8.10.3
+	eghcup --offline rm 8.10.3
 	[ "$(ghc --numeric-version)" = "${ghc_ver}" ]
 
 	if [ "${OS}" = "DARWIN" ] ; then

app/ghcup-gen/Validate.hs

@@ -12,7 +12,7 @@ import           GHCup
 import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Platform
-import           GHCup.Types
+import           GHCup.Types                  hiding ( LeanAppState (..) )
 import           GHCup.Types.Optics
 import           GHCup.Utils
 import           GHCup.Utils.Logger
@@ -226,7 +226,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
                                      , rawOutter    = \_ -> pure ()
                                      }
   downloadAll dli = do
-    dirs <- liftIO getDirs
+    dirs <- liftIO getAllDirs
 
     pfreq <- (
       runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
@@ -237,7 +237,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
                   ($(logError) $ T.pack $ prettyShow e)
                 liftIO $ exitWith (ExitFailure 2)
 
-    let appstate = AppState (Settings True False Never Curl False GHCupURL) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
+    let appstate = AppState (Settings True False Never Curl False GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
 
     r <-
       runLogger
@@ -256,17 +256,17 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
         case etool of
           Right (Just GHCup) -> do
             tmpUnpack <- lift mkGhcupTmpDir
-            _ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
+            _ <- liftE $ download dli tmpUnpack Nothing
             pure Nothing
           Right _ -> do
-            p <- liftE $ downloadCached (settings appstate) dirs dli Nothing
+            p <- liftE $ downloadCached dli Nothing
             fmap (Just . head . splitDirectories . head)
               . liftE
               . getArchiveFiles
               $ p
           Left ShimGen -> do
             tmpUnpack <- lift mkGhcupTmpDir
-            _ <- liftE $ download (settings appstate) dli tmpUnpack Nothing
+            _ <- liftE $ download dli tmpUnpack Nothing
             pure Nothing
     case r of
       VRight (Just basePath) -> do

app/ghcup/BrickMain.hs

@@ -13,7 +13,7 @@ module BrickMain where
 import           GHCup
 import           GHCup.Download
 import           GHCup.Errors
-import           GHCup.Types
+import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
 import           GHCup.Utils.Prelude ( decUTF8Safe )
 import           GHCup.Utils.File
@@ -53,8 +53,6 @@ import           System.IO.Unsafe
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           URI.ByteString
 
-import qualified GHCup.Types                   as GT
-
 import qualified Data.Text                     as T
 import qualified Graphics.Vty                  as Vty
 import qualified Data.Vector                   as V
@@ -550,13 +548,14 @@ changelog' _ (_, ListResult {..}) = do
 settings' :: IORef AppState
 {-# NOINLINE settings' #-}
 settings' = unsafePerformIO $ do
-  dirs <- getDirs
+  dirs <- getAllDirs
   newIORef $ AppState (Settings { cache      = True
                                 , noVerify   = False
                                 , keepDirs   = Never
                                 , downloader = Curl
                                 , verbose    = False
                                 , urlSource  = GHCupURL
+                                , noNetwork  = False
                                 , ..
                                 })
                       dirs
@@ -578,9 +577,8 @@ logger' = unsafePerformIO
 
 brickMain :: AppState
           -> LoggerConfig
-          -> GHCupInfo
           -> IO ()
-brickMain s l gi = do
+brickMain s l = do
   writeIORef settings' s
   -- logger interpreter
   writeIORef logger'   l
@@ -588,7 +586,7 @@ brickMain s l gi = do
 
   no_color <- isJust <$> lookupEnv "NO_COLOR"
 
-  eAppData <- getAppData (Just gi)
+  eAppData <- getAppData (Just $ ghcupInfo s)
   case eAppData of
     Right ad ->
       defaultMain
@@ -596,7 +594,7 @@ brickMain s l gi = do
           (BrickState ad
                     defaultAppSettings
                     (constructList ad defaultAppSettings Nothing)
-                    (keyBindings s)
+                    (keyBindings (s :: AppState))
 
           )
         $> ()
@@ -620,7 +618,7 @@ getGHCupInfo = do
     . flip runReaderT settings
     . runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
     $ liftE
-    $ getDownloadsF (GT.settings settings) (GT.dirs settings)
+    $ getDownloadsF
 
   case r of
     VRight a -> pure $ Right a

ghcup-0.0.5.yaml

@@ -2155,14 +2155,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 +2179,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

@@ -116,7 +116,7 @@ library
     , megaparsec            >=8.0.0      && <9.1
     , monad-logger          ^>=0.3.31
     , mtl                   ^>=2.2
-    , optics                >=0.2        && <0.5
+    , optics                ^>=0.4
     , optics-vl             ^>=0.2
     , os-release            ^>=1.0.0
     , parsec                ^>=3.1
@@ -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
@@ -279,7 +280,7 @@ executable ghcup-gen
     , haskus-utils-variant  >=3.0      && <3.2
     , monad-logger          ^>=0.3.31
     , mtl                   ^>=2.2
-    , optics                >=0.2      && <0.5
+    , optics                ^>=0.4
     , optparse-applicative  >=0.15.1.0 && <0.17
     , pretty                ^>=1.1.3.1
     , pretty-terminal       ^>=0.1.0.0

lib/GHCup/Download.hs

@@ -107,32 +107,32 @@ import qualified Data.Yaml                     as Y
 getDownloadsF :: ( FromJSONKey Tool
                  , FromJSONKey Version
                  , FromJSON VersionInfo
+                 , MonadReader env m
+                 , HasSettings env
+                 , HasDirs env
                  , MonadIO m
                  , MonadCatch m
                  , MonadLogger m
                  , MonadThrow m
                  , MonadFail m
+                 , MonadMask m
                  )
-              => Settings
+              => Excepts
-              -> Dirs
-              -> Excepts
                    '[JSONError , DownloadFailed , FileDoesNotExistError]
                    m
                    GHCupInfo
-getDownloadsF settings@Settings{ urlSource } dirs = do
+getDownloadsF = do
+  Settings { urlSource } <- lift getSettings
   case urlSource of
-    GHCupURL -> liftE $ getBase dirs settings
+    GHCupURL -> liftE $ getBase ghcupURL
-    (OwnSource url) -> do
+    (OwnSource url) -> liftE $ getBase url
-      bs <- reThrowAll DownloadFailed $ downloadBS (downloader settings) url
-      lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
     (OwnSpec av) -> pure av
     (AddSource (Left ext)) -> do
-      base <- liftE $ getBase dirs settings
+      base <- liftE $ getBase ghcupURL
       pure (mergeGhcupInfo base ext)
     (AddSource (Right uri)) -> do
-      base <- liftE $ getBase dirs settings
+      base <- liftE $ getBase ghcupURL
-      bsExt <- reThrowAll DownloadFailed $ downloadBS (downloader settings) uri
+      ext  <- liftE $ getBase uri
-      ext <- lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bsExt)
       pure (mergeGhcupInfo base ext)
 
     where
@@ -149,33 +149,50 @@ getDownloadsF settings@Settings{ urlSource } dirs = do
     in GHCupInfo tr newDownloads newGlobalTools
 
 
-readFromCache :: (MonadIO m, MonadCatch m, MonadLogger m)
+readFromCache :: ( MonadReader env m
-              => Dirs
+                 , HasDirs env
-              -> Excepts '[JSONError, FileDoesNotExistError] m GHCupInfo
+                 , MonadIO m
-readFromCache Dirs {..} = do
+                 , MonadCatch m)
-  lift $ $(logWarn)
+              => URI
-    [i|Could not get download info, trying cached version (this may not be recent!)|]
+              -> Excepts '[JSONError, FileDoesNotExistError] m L.ByteString
-  let path = view pathL' ghcupURL
+readFromCache uri = do
-  let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
+  Dirs{..} <- lift getDirs
-  bs        <-
+  let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName . view pathL' $ uri)
-    handleIO' NoSuchThing
+  handleIO' NoSuchThing (\_ -> throwE $ FileDoesNotExistError yaml_file)
-              (\_ -> throwE $ FileDoesNotExistError yaml_file)
+    . liftIO
-    $ liftIO
+    . L.readFile
-    $ L.readFile yaml_file
+    $ yaml_file
-  lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
 
 
-getBase :: (MonadFail m, MonadIO m, MonadCatch m, MonadLogger m)
+getBase :: ( MonadReader env m
-        => Dirs
+           , HasDirs env
-        -> Settings
+           , HasSettings env
+           , MonadFail m
+           , MonadIO m
+           , MonadCatch m
+           , MonadLogger m
+           , MonadMask m
+           )
+        => URI
         -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
-getBase dirs@Dirs{..} Settings{ downloader }  =
+getBase uri = do
-  handleIO (\_ -> readFromCache dirs)
+  Settings { noNetwork } <- lift getSettings
-  $ catchE @_ @'[JSONError, FileDoesNotExistError]
+  bs <- if noNetwork
-      (\(DownloadFailed _) -> readFromCache dirs)
+        then readFromCache uri
-  (reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed (smartDl ghcupURL)
+        else handleIO (\_ -> warnCache >> readFromCache uri)
-    >>= (liftE . lE' @_ @_ @'[JSONError] JSONDecodeError . first show . Y.decodeEither' . L.toStrict))
+               . catchE @_ @'[JSONError, FileDoesNotExistError] (\(DownloadFailed _) -> warnCache >> readFromCache uri)
-    where
+               . reThrowAll @_ @_ @'[JSONError, DownloadFailed] DownloadFailed
+               $ smartDl uri
+  liftE
+    . lE' @_ @_ @'[JSONError] JSONDecodeError
+    . first show
+    . Y.decodeEither'
+    . L.toStrict
+    $ bs
+ where
+  warnCache = lift $ $(logWarn)
+      [i|Could not get download info, trying cached version (this may not be recent!)|]
+
   -- 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.
@@ -185,11 +202,15 @@ getBase dirs@Dirs{..} Settings{ downloader }  =
   -- than the local file.
   --
   -- Always save the local file with the mod time of the remote file.
-  smartDl :: forall m1
+  smartDl :: forall m1 env1
-           . ( MonadCatch m1
+           . ( MonadReader env1 m1
+             , HasDirs env1
+             , HasSettings env1
+             , MonadCatch m1
              , MonadIO m1
              , MonadFail m1
              , MonadLogger m1
+             , MonadMask m1
              )
           => URI
           -> Excepts
@@ -200,13 +221,15 @@ getBase dirs@Dirs{..} Settings{ downloader }  =
                 , NoLocationHeader
                 , TooManyRedirs
                 , ProcessError
+                , NoNetwork
                 ]
                m1
                L.ByteString
   smartDl uri' = do
+    Dirs{..} <- lift getDirs
     let path = view pathL' uri'
     let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
-    e         <- liftIO $ doesFileExist json_file
+    e <- liftIO $ doesFileExist json_file
     if e
       then do
         accessTime <- liftIO $ getAccessTime json_file
@@ -237,12 +260,12 @@ getBase dirs@Dirs{..} Settings{ downloader }  =
 
    where
     dlWithMod modTime json_file = do
-      bs <- liftE $ downloadBS downloader uri'
+      bs <- liftE $ downloadBS uri'
       liftIO $ writeFileWithModTime modTime json_file bs
       pure bs
     dlWithoutMod json_file = do
-      bs <- liftE $ downloadBS downloader uri'
+      bs <- liftE $ downloadBS uri'
-      liftIO $ hideError doesNotExistErrorType $ rmFile json_file
+      lift $ hideError doesNotExistErrorType $ recycleFile json_file
       liftIO $ L.writeFile json_file bs
       liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
       pure bs
@@ -279,39 +302,46 @@ getBase dirs@Dirs{..} Settings{ downloader }  =
     setModificationTime path utctime
 
 
-getDownloadInfo :: Tool
+getDownloadInfo :: ( MonadReader env m
+                   , HasPlatformReq env
+                   , HasGHCupInfo env
+                   )
+                => Tool
                 -> Version
                 -- ^ tool version
-                -> PlatformRequest
+                -> Excepts
-                -> GHCupDownloads
+                     '[NoDownload]
-                -> Either NoDownload DownloadInfo
+                     m
-getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
+                     DownloadInfo
-  (Left NoDownload)
+getDownloadInfo t v = do
-  Right
+  (PlatformRequest a p mv) <- lift getPlatformReq
-  (case p of
+  GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-    -- non-musl won't work on alpine
-    Linux Alpine -> with_distro <|> without_distro_ver
-    _            -> with_distro <|> without_distro_ver <|> without_distro
-  )
 
- where
+  let distro_preview f g =
-  with_distro        = distro_preview id id
+        let platformVersionSpec =
-  without_distro_ver = distro_preview id (const Nothing)
+              preview (ix t % ix v % viArch % ix a % ix (f p)) dls
-  without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)
+            mv' = g mv
+        in  fmap snd
+              .   find
+                    (\(mverRange, _) -> maybe
+                      (isNothing mv')
+                      (\range -> maybe False (`versionRange` range) mv')
+                      mverRange
+                    )
+              .   M.toList
+              =<< platformVersionSpec
+      with_distro        = distro_preview id id
+      without_distro_ver = distro_preview id (const Nothing)
+      without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)
 
-  distro_preview f g =
+  maybe
-    let platformVersionSpec =
+    (throwE NoDownload)
-          preview (ix t % ix v % viArch % ix a % ix (f p)) dls
+    pure
-        mv' = g mv
+    (case p of
-    in  fmap snd
+      -- non-musl won't work on alpine
-          .   find
+      Linux Alpine -> with_distro <|> without_distro_ver
-                (\(mverRange, _) -> maybe
+      _            -> with_distro <|> without_distro_ver <|> without_distro
-                  (isNothing mv')
+    )
-                  (\range -> maybe False (`versionRange` range) mv')
-                  mverRange
-                )
-          .   M.toList
-          =<< platformVersionSpec
 
 
 -- | Tries to download from the given http or https url
@@ -321,17 +351,19 @@ getDownloadInfo t v (PlatformRequest a p mv) dls = maybe
 --   2. otherwise create a random file
 --
 -- The file must not exist.
-download :: ( MonadMask m
+download :: ( MonadReader env m
+            , HasSettings env
+            , HasDirs env
+            , MonadMask m
             , MonadThrow m
             , MonadLogger m
             , MonadIO m
             )
-         => Settings
+         => DownloadInfo
-         -> DownloadInfo
          -> FilePath          -- ^ destination dir
          -> Maybe FilePath    -- ^ optional filename
          -> Excepts '[DigestError , DownloadFailed] m FilePath
-download settings@Settings{ downloader } dli dest mfn
+download dli dest mfn
   | scheme == "https" = dl
   | scheme == "http"  = dl
   | scheme == "file"  = cp
@@ -356,12 +388,14 @@ download settings@Settings{ downloader } dli dest mfn
 
     -- 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
+              when noNetwork $ throwE (DownloadFailed (V NoNetwork :: V '[NoNetwork]))
               case downloader of
                 Curl -> do
                   o' <- liftIO getCurlOpts
@@ -377,58 +411,66 @@ download settings@Settings{ downloader } dli dest mfn
                   liftE $ downloadToFile https host fullPath port destFile
 #endif
 
-    liftE $ checkDigest settings dli destFile
+    liftE $ checkDigest dli destFile
     pure destFile
 
   -- Manage to find a file we can write the body into.
   getDestFile :: FilePath
-  getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn
+  getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path)))
+                  (dest </>)
+                  mfn
 
-  path        = view (dlUri % pathL') dli
+  path = view (dlUri % pathL') dli
 
 
 -- | Download into tmpdir or use cached version, if it exists. If filename
 -- is omitted, infers the filename from the url.
-downloadCached :: ( MonadMask m
+downloadCached :: ( MonadReader env m
+                  , HasDirs env
+                  , HasSettings env
+                  , MonadMask m
                   , MonadResource m
                   , MonadThrow m
                   , MonadLogger m
                   , MonadIO m
                   , MonadUnliftIO m
                   )
-               => Settings
+               => DownloadInfo
-               -> Dirs
-               -> DownloadInfo
                -> Maybe FilePath  -- ^ optional filename
                -> Excepts '[DigestError , DownloadFailed] m FilePath
-downloadCached settings@Settings{ cache } dirs dli mfn = do
+downloadCached dli mfn = do
+  Settings{ cache } <- lift getSettings
   case cache of
-    True -> downloadCached' settings dirs dli mfn
+    True -> downloadCached' dli mfn Nothing
     False -> do
       tmp <- lift withGHCupTmpDir
-      liftE $ download settings dli tmp mfn
+      liftE $ download dli tmp mfn
 
 
-downloadCached' :: ( MonadMask m
+downloadCached' :: ( MonadReader env m
+                   , HasDirs env
+                   , HasSettings env
+                   , MonadMask m
                    , MonadThrow m
                    , MonadLogger m
                    , MonadIO m
                    , MonadUnliftIO m
                    )
-                => Settings
+                => DownloadInfo
-                -> Dirs
-                -> DownloadInfo
                 -> Maybe FilePath  -- ^ optional filename
+                -> Maybe FilePath  -- ^ optional destination dir (default: cacheDir)
                 -> Excepts '[DigestError , DownloadFailed] m FilePath
-downloadCached' settings Dirs{..} dli mfn = do
+downloadCached' dli mfn mDestDir = do
+  Dirs { cacheDir } <- lift getDirs
+  let destDir = fromMaybe cacheDir mDestDir
   let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
-  let cachfile = cacheDir </> fn
+  let cachfile = destDir </> fn
   fileExists <- liftIO $ doesFileExist cachfile
   if
     | fileExists -> do
-      liftE $ checkDigest settings dli cachfile
+      liftE $ checkDigest dli cachfile
       pure cachfile
-    | otherwise -> liftE $ download settings dli cacheDir mfn
+    | otherwise -> liftE $ download dli destDir mfn
 
 
 
@@ -441,9 +483,13 @@ downloadCached' settings Dirs{..} dli mfn = do
 
 
 -- | This is used for downloading the JSON.
-downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
+downloadBS :: ( MonadReader env m
-           => Downloader
+              , HasSettings env
-           -> URI
+              , MonadCatch m
+              , MonadIO m
+              , MonadLogger m
+              )
+           => URI
            -> Excepts
                 '[ FileDoesNotExistError
                  , HTTPStatusError
@@ -452,10 +498,11 @@ downloadBS :: (MonadCatch m, MonadIO m, MonadLogger m)
                  , NoLocationHeader
                  , TooManyRedirs
                  , ProcessError
+                 , NoNetwork
                  ]
                 m
                 L.ByteString
-downloadBS downloader uri'
+downloadBS uri'
   | scheme == "https"
   = dl True
   | scheme == "http"
@@ -475,6 +522,8 @@ downloadBS downloader uri'
   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
@@ -499,12 +548,18 @@ downloadBS downloader uri'
 #endif
 
 
-checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m)
+checkDigest :: ( MonadReader env m
-            => Settings
+               , HasDirs env
-            -> DownloadInfo
+               , HasSettings env
+               , MonadIO m
+               , MonadThrow m
+               , MonadLogger m
+               )
+            => DownloadInfo
             -> FilePath
             -> Excepts '[DigestError] m ()
-checkDigest Settings{ noVerify } dli file = do
+checkDigest dli file = do
+  Settings{ noVerify } <- lift getSettings
   let verify = not noVerify
   when verify $ do
     let p' = takeFileName file

lib/GHCup/Errors.hs

@@ -31,8 +31,8 @@ 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
 
 
@@ -233,6 +233,20 @@ instance Pretty NoToolVersionSet where
   pPrint (NoToolVersionSet tool) =
     text [i|No version is set for tool "#{tool}".|]
 
+data NoNetwork = NoNetwork
+  deriving Show
+
+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 ]--
@@ -249,11 +263,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

@@ -1,9 +1,12 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE BangPatterns      #-}
+{-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 
 {-|
 Module      : GHCup.Types
@@ -294,11 +297,12 @@ data UserSettings = UserSettings
   , uDownloader  :: Maybe Downloader
   , uKeyBindings :: Maybe UserKeyBindings
   , uUrlSource   :: Maybe URLSource
+  , uNoNetwork   :: Maybe Bool
   }
   deriving (Show, GHC.Generic)
 
 defaultUserSettings :: UserSettings
-defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
+defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 
 data UserKeyBindings = UserKeyBindings
   { kUp        :: Maybe Key
@@ -346,12 +350,21 @@ data AppState = AppState
   { settings :: Settings
   , dirs :: Dirs
   , keyBindings :: KeyBindings
-  , ghcupInfo :: ~GHCupInfo
+  , ghcupInfo :: GHCupInfo
-  , pfreq :: ~PlatformRequest
+  , pfreq :: PlatformRequest
   } deriving (Show, GHC.Generic)
 
 instance NFData AppState
 
+data LeanAppState = LeanAppState
+  { settings :: Settings
+  , dirs :: Dirs
+  , keyBindings :: KeyBindings
+  } deriving (Show, GHC.Generic)
+
+instance NFData LeanAppState
+
+
 data Settings = Settings
   { cache      :: Bool
   , noVerify   :: Bool
@@ -359,6 +372,7 @@ data Settings = Settings
   , downloader :: Downloader
   , verbose    :: Bool
   , urlSource  :: URLSource
+  , noNetwork  :: Bool
   }
   deriving (Show, GHC.Generic)
 
@@ -370,6 +384,7 @@ data Dirs = Dirs
   , cacheDir :: FilePath
   , logsDir  :: FilePath
   , confDir  :: FilePath
+  , recycleDir :: FilePath -- mainly used on windows
   }
   deriving (Show, GHC.Generic)
 
@@ -507,4 +522,3 @@ instance (Monad m, Alternative m) => Alternative (LoggingT m) where
 instance MonadLogger m => MonadLogger (Excepts e m) where
   monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d
 
-

lib/GHCup/Types/Optics.hs

@@ -1,4 +1,11 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE ConstraintKinds       #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE MultiParamTypeClasses   #-}
 
 {-|
 Module      : GHCup.Types.Optics
@@ -13,6 +20,7 @@ module GHCup.Types.Optics where
 
 import           GHCup.Types
 
+import           Control.Monad.Reader
 import           Data.ByteString                ( ByteString )
 import           Optics
 import           URI.ByteString
@@ -58,3 +66,85 @@ pathL' = lensVL pathL
 
 queryL' :: Lens' (URIRef a) Query
 queryL' = lensVL queryL
+
+
+
+    ----------------------
+    --[ Lens utilities ]--
+    ----------------------
+
+
+gets :: forall f a env m . (MonadReader env m, LabelOptic' f A_Lens env a)
+     => m a
+gets = asks (^. labelOptic @f)
+
+
+getAppState :: MonadReader AppState m => m AppState
+getAppState = ask
+
+
+getLeanAppState :: ( MonadReader env m
+                   , LabelOptic' "settings"    A_Lens env Settings
+                   , LabelOptic' "dirs"        A_Lens env Dirs
+                   , LabelOptic' "keyBindings" A_Lens env KeyBindings
+                   )
+                => m LeanAppState
+getLeanAppState = do
+  s <- gets @"settings"
+  d <- gets @"dirs"
+  k <- gets @"keyBindings"
+  pure (LeanAppState s d k)
+
+
+getSettings :: ( MonadReader env m
+               , LabelOptic' "settings" A_Lens env Settings
+               )
+            => m Settings
+getSettings = gets @"settings"
+
+
+getDirs :: ( MonadReader env m
+           , LabelOptic' "dirs" A_Lens env Dirs
+           )
+        => m Dirs
+getDirs = gets @"dirs"
+
+
+getKeyBindings :: ( MonadReader env m
+                  , LabelOptic' "keyBindings" A_Lens env KeyBindings
+                  )
+               => m KeyBindings
+getKeyBindings = gets @"keyBindings"
+
+
+getGHCupInfo :: ( MonadReader env m
+                , LabelOptic' "ghcupInfo" A_Lens env GHCupInfo
+                )
+             => m GHCupInfo
+getGHCupInfo = gets @"ghcupInfo"
+
+
+getPlatformReq :: ( MonadReader env m
+                  , LabelOptic' "pfreq" A_Lens env PlatformRequest
+                  )
+               => m PlatformRequest
+getPlatformReq = gets @"pfreq"
+
+
+type HasSettings env = (LabelOptic' "settings" A_Lens env Settings)
+type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
+type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
+type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
+type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
+
+
+getCache :: (MonadReader env m, HasSettings env) => m Bool
+getCache = getSettings <&> cache
+
+
+getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
+getDownloader = getSettings <&> downloader
+
+
+instance LabelOptic "dirs" A_Lens Dirs Dirs Dirs Dirs where
+  labelOptic = lens id (\_ d -> d)

lib/GHCup/Utils.hs

@@ -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
 
@@ -103,73 +105,79 @@ import qualified Text.Megaparsec               as MP
 
 
 -- | The symlink destination of a ghc tool.
-ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
+ghcLinkDestination :: ( MonadReader env m
+                      , HasDirs env
+                      , MonadThrow m, MonadIO m)
                    => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
                    -> GHCTargetVersion
                    -> m FilePath
 ghcLinkDestination tool ver = do
-  AppState { dirs = Dirs {..} } <- ask
+  Dirs {..}  <- getDirs
   ghcd <- ghcupGHCDir ver
   pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
 
 
 -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
-rmMinorSymlinks :: ( MonadReader AppState m
+rmMinorSymlinks :: ( MonadReader env m
+                   , HasDirs env
                    , MonadIO m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
-                   , MonadReader AppState m
+                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
 rmMinorSymlinks tv@GHCTargetVersion{..} = do
-  AppState { dirs = Dirs {..} } <- lift ask
+  Dirs {..}  <- lift getDirs
 
   files                         <- liftE $ ghcToolFiles tv
   forM_ files $ \f -> do
     let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
     let fullF = binDir </> f_xyz
     lift $ $(logDebug) [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.
-rmPlain :: ( MonadReader AppState m
+rmPlain :: ( MonadReader env m
+           , HasDirs env
            , MonadLogger m
            , MonadThrow m
            , MonadFail m
            , MonadIO m
+           , MonadMask m
            )
         => Maybe Text -- ^ target
         -> Excepts '[NotInstalled] m ()
 rmPlain target = do
-  AppState { dirs = Dirs {..} } <- lift ask
+  Dirs {..}  <- lift getDirs
   mtv                           <- lift $ ghcSet target
   forM_ mtv $ \tv -> do
     files <- liftE $ ghcToolFiles tv
     forM_ files $ \f -> do
       let fullF = binDir </> f <> exeExt
       lift $ $(logDebug) [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.
-rmMajorSymlinks :: ( MonadReader AppState m
+rmMajorSymlinks :: ( MonadReader env m
+                   , HasDirs env
                    , MonadIO m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
-                   , MonadReader AppState m
+                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
 rmMajorSymlinks tv@GHCTargetVersion{..} = do
-  AppState { dirs = Dirs {..} } <- lift ask
+  Dirs {..}  <- lift getDirs
   (mj, mi) <- getMajorMinorV _tvVersion
   let v' = intToText mj <> "." <> intToText mi
 
@@ -178,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
 
 
 
@@ -189,26 +197,26 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
 
 
 -- | Whether the given GHC versin is installed.
-ghcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
+ghcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
 ghcInstalled ver = do
   ghcdir <- ghcupGHCDir ver
   liftIO $ doesDirectoryExist ghcdir
 
 
 -- | Whether the given GHC version is installed from source.
-ghcSrcInstalled :: (MonadIO m, MonadReader AppState m, MonadThrow m) => GHCTargetVersion -> m Bool
+ghcSrcInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadThrow m) => GHCTargetVersion -> m Bool
 ghcSrcInstalled ver = do
   ghcdir <- ghcupGHCDir ver
   liftIO $ doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
 
 
 -- | Whether the given GHC version is set as the current.
-ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
+ghcSet :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
        => Maybe Text   -- ^ the target of the GHC version, if any
                        --  (e.g. armv7-unknown-linux-gnueabihf)
        -> m (Maybe GHCTargetVersion)
 ghcSet mtarget = do
-  AppState {dirs = Dirs {..}} <- ask
+  Dirs {..}  <- getDirs
   let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
   let ghcBin = binDir </> ghc <> exeExt
 
@@ -239,7 +247,7 @@ ghcSet mtarget = do
 
 -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
 -- If a dir cannot be parsed, returns left.
-getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
+getInstalledGHCs :: (MonadReader env m, HasDirs env, MonadIO m) => m [Either FilePath GHCTargetVersion]
 getInstalledGHCs = do
   ghcdir <- ghcupGHCBaseDir
   fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
@@ -249,10 +257,15 @@ getInstalledGHCs = do
 
 
 -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
-getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
+getInstalledCabals :: ( MonadLogger m
+                      , MonadReader env m
+                      , HasDirs env
+                      , MonadIO m
+                      , MonadCatch m
+                      )
                    => m [Either FilePath Version]
 getInstalledCabals = do
-  AppState {dirs = Dirs {..}} <- ask
+  Dirs {..} <- getDirs
   bins   <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
@@ -264,16 +277,16 @@ getInstalledCabals = do
 
 
 -- | Whether the given cabal version is installed.
-cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
+cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
 cabalInstalled ver = do
   vers <- fmap rights getInstalledCabals
   pure $ elem ver vers
 
 
 -- Return the currently set cabal version, if any.
-cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
+cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
 cabalSet = do
-  AppState {dirs = Dirs {..}} <- ask
+  Dirs {..}  <- getDirs
   let cabalbin = binDir </> "cabal" <> exeExt
 
   handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@@ -317,10 +330,10 @@ cabalSet = do
 
 -- | Get all installed hls, by matching on
 -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
-getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
+getInstalledHLSs :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
                  => m [Either FilePath Version]
 getInstalledHLSs = do
-  AppState { dirs = Dirs {..} } <- ask
+  Dirs {..}  <- getDirs
   bins                          <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts compExtended
@@ -337,10 +350,10 @@ getInstalledHLSs = do
 
 -- | Get all installed stacks, by matching on
 -- @~\/.ghcup\/bin/stack-<\stackver\>@.
-getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
+getInstalledStacks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m)
                    => m [Either FilePath Version]
 getInstalledStacks = do
-  AppState { dirs = Dirs {..} } <- ask
+  Dirs {..}  <- getDirs
   bins                          <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts compExtended
@@ -355,9 +368,9 @@ getInstalledStacks = do
 
 -- Return the currently set stack version, if any.
 -- TODO: there's a lot of code duplication here :>
-stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
+stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version)
 stackSet = do
-  AppState {dirs = Dirs {..}} <- ask
+  Dirs {..}  <- getDirs
   let stackBin = binDir </> "stack" <> exeExt
 
   handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@@ -395,13 +408,13 @@ stackSet = do
     stripRelativePath = MP.many (MP.try stripPathComponet)
 
 -- | Whether the given Stack version is installed.
-stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
+stackInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
 stackInstalled ver = do
   vers <- fmap rights getInstalledStacks
   pure $ elem ver vers
 
 -- | Whether the given HLS version is installed.
-hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
+hlsInstalled :: (MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
 hlsInstalled ver = do
   vers <- fmap rights getInstalledHLSs
   pure $ elem ver vers
@@ -409,9 +422,9 @@ hlsInstalled ver = do
 
 
 -- Return the currently set hls version, if any.
-hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
+hlsSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
 hlsSet = do
-  AppState {dirs = Dirs {..}} <- ask
+  Dirs {..}  <- getDirs
   let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
 
   liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
@@ -443,7 +456,8 @@ hlsSet = do
 
 
 -- | Return the GHC versions the currently selected HLS supports.
-hlsGHCVersions :: ( MonadReader AppState m
+hlsGHCVersions :: ( MonadReader env m
+                  , HasDirs env
                   , MonadIO m
                   , MonadThrow m
                   , MonadCatch m
@@ -466,11 +480,11 @@ hlsGHCVersions = do
 
 
 -- | Get all server binaries for an hls version, if any.
-hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
+hlsServerBinaries :: (MonadReader env m, HasDirs env, MonadIO m)
                   => Version
                   -> m [FilePath]
 hlsServerBinaries ver = do
-  AppState { dirs = Dirs {..} } <- ask
+  Dirs {..}  <- getDirs
   liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts
@@ -482,12 +496,12 @@ hlsServerBinaries ver = do
 
 
 -- | Get the wrapper binary for an hls version, if any.
-hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
+hlsWrapperBinary :: (MonadReader env m, HasDirs env, MonadThrow m, MonadIO m)
                  => Version
                  -> m (Maybe FilePath)
 hlsWrapperBinary ver = do
-  AppState { dirs = Dirs {..} } <- ask
+  Dirs {..}  <- getDirs
-  wrapper                       <- liftIO $ handleIO (\_ -> pure []) $ findFiles
+  wrapper <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts
       compExtended
@@ -503,7 +517,7 @@ hlsWrapperBinary ver = do
 
 
 -- | Get all binaries for an hls version, if any.
-hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
+hlsAllBinaries :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m) => Version -> m [FilePath]
 hlsAllBinaries ver = do
   hls     <- hlsServerBinaries ver
   wrapper <- hlsWrapperBinary ver
@@ -511,9 +525,9 @@ hlsAllBinaries ver = do
 
 
 -- | Get the active symlinks for hls.
-hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
+hlsSymlinks :: (MonadReader env m, HasDirs env, MonadIO m, MonadCatch m) => m [FilePath]
 hlsSymlinks = do
-  AppState { dirs = Dirs {..} } <- ask
+  Dirs {..}  <- getDirs
   oldSyms                       <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts compExtended
@@ -549,7 +563,7 @@ matchMajor v' major' minor' = case getMajorMinorV v' of
 
 -- | Get the latest installed full GHC version that satisfies X.Y.
 -- This reads `ghcupGHCBaseDir`.
-getGHCForMajor :: (MonadReader AppState m, MonadIO m, MonadThrow m)
+getGHCForMajor :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m)
                => Int        -- ^ major version component
                -> Int        -- ^ minor version component
                -> Maybe Text -- ^ the target triple
@@ -729,19 +743,6 @@ getLatestBaseVersion av pvpVer =
 
 
 
-    -----------------------
-    --[ AppState Getter ]--
-    -----------------------
-
-
-getCache :: MonadReader AppState m => m Bool
-getCache = ask <&> cache . settings
-
-
-getDownloader :: MonadReader AppState m => m Downloader
-getDownloader = ask <&> downloader . settings
-
-
 
     -------------
     --[ Other ]--
@@ -754,7 +755,7 @@ getDownloader = ask <&> downloader . settings
 -- Returns unversioned relative files without extension, e.g.:
 --
 --   - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
-ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
+ghcToolFiles :: (MonadReader env m, HasDirs env, MonadThrow m, MonadFail m, MonadIO m)
              => GHCTargetVersion
              -> Excepts '[NotInstalled] m [FilePath]
 ghcToolFiles ver = do
@@ -817,7 +818,12 @@ ghcUpSrcBuiltFile = ".ghcup_src_built"
 
 
 -- | Calls gmake if it exists in PATH, otherwise make.
-make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
+make :: ( MonadThrow m
+        , MonadIO m
+        , MonadReader env m
+        , HasDirs env
+        , HasSettings env
+        )
      => [String]
      -> Maybe FilePath
      -> m (Either ProcessError ())
@@ -827,7 +833,7 @@ make args workdir = do
   let mymake = if has_gmake then "gmake" else "make"
   execLogged mymake args workdir "ghc-make" Nothing
 
-makeOut :: (MonadReader AppState m, MonadIO m)
+makeOut :: (MonadReader env m, HasDirs env, MonadIO m)
         => [String]
         -> Maybe FilePath
         -> m CapturedProcess
@@ -840,7 +846,7 @@ makeOut args workdir = do
 
 -- | Try to apply patches in order. Fails with 'PatchFailed'
 -- on first failure.
-applyPatches :: (MonadReader AppState m, MonadLogger m, MonadIO m)
+applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m)
              => FilePath   -- ^ dir containing patches
              -> FilePath   -- ^ dir to apply patches in
              -> Excepts '[PatchFailed] m ()
@@ -858,7 +864,7 @@ applyPatches pdir ddir = do
 
 
 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
-darwinNotarization :: (MonadReader AppState m, MonadIO m)
+darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m)
                    => Platform
                    -> FilePath
                    -> m (Either ProcessError ())
@@ -881,20 +887,27 @@ 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 AppState m, 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
 runBuildAction bdir instdir action = do
-  AppState { settings = Settings {..} } <- lift ask
+  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
@@ -903,10 +916,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
@@ -993,13 +1016,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
 
 
@@ -1016,7 +1039,8 @@ createLink :: ( MonadMask m
               , MonadThrow m
               , MonadLogger m
               , MonadIO m
-              , MonadReader AppState m
+              , MonadReader env m
+              , HasDirs env
               , MonadUnliftIO m
               , MonadFail m
               )
@@ -1025,7 +1049,7 @@ createLink :: ( MonadMask m
            -> m ()
 createLink link exe = do
 #if defined(IS_WINDOWS)
-  AppState { dirs } <- ask
+  dirs <- getDirs
   let shimGen = cacheDir dirs </> "gs.exe"
 
   let shim = dropExtension exe <.> "shim"
@@ -1036,14 +1060,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
@@ -1054,21 +1078,25 @@ ensureGlobalTools :: ( MonadMask m
                      , MonadThrow m
                      , MonadLogger m
                      , MonadIO m
-                     , MonadReader AppState m
+                     , MonadReader env m
+                     , HasDirs env
+                     , HasSettings env
+                     , HasGHCupInfo env
                      , MonadUnliftIO m
                      , MonadFail m
                      )
                   => Excepts '[DigestError , DownloadFailed, NoDownload] m ()
 ensureGlobalTools = do
 #if defined(IS_WINDOWS)
-  AppState { ghcupInfo = GHCupInfo _ _ gTools, settings, dirs } <- lift ask
+  (GHCupInfo _ _ gTools) <- lift getGHCupInfo
+  dirs <- lift getDirs
   shimDownload <- liftE $ lE @_ @'[NoDownload]
     $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
-  let dl = downloadCached' settings dirs shimDownload (Just "gs.exe")
+  let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
   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 ()
@@ -1079,17 +1107,24 @@ 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 ()
+
+
+-- | For ghc without arch triple, this is:
+--
+--    - ghc-<ver> (e.g. ghc-8.10.4)
+--
+-- For ghc with arch triple:
+--
+--    - <triple>-ghc-<ver> (e.g. arm-linux-gnueabihf-ghc-8.10.4)
+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

@@ -16,7 +16,7 @@ Stability   : experimental
 Portability : portable
 -}
 module GHCup.Utils.Dirs
-  ( getDirs
+  ( getAllDirs
   , ghcupBaseDir
   , ghcupConfigFile
   , ghcupCacheDir
@@ -30,6 +30,7 @@ module GHCup.Utils.Dirs
 #if !defined(IS_WINDOWS)
   , useXDG
 #endif
+  , cleanupTrash
   )
 where
 
@@ -37,6 +38,7 @@ where
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.JSON               ( )
+import           GHCup.Types.Optics
 import           GHCup.Utils.MegaParsec
 import           GHCup.Utils.Prelude
 
@@ -52,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
@@ -190,13 +190,21 @@ ghcupLogsDir = do
 #endif
 
 
-getDirs :: IO Dirs
+-- | '~/.ghcup/trash'.
-getDirs = do
+-- Mainly used on windows to improve file removal operations
-  baseDir  <- ghcupBaseDir
+ghcupRecycleDir :: IO FilePath
-  binDir   <- ghcupBinDir
+ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
-  cacheDir <- ghcupCacheDir
+
-  logsDir  <- ghcupLogsDir
+
-  confDir  <- ghcupConfigDir
+
+getAllDirs :: IO Dirs
+getAllDirs = do
+  baseDir    <- ghcupBaseDir
+  binDir     <- ghcupBinDir
+  cacheDir   <- ghcupCacheDir
+  logsDir    <- ghcupLogsDir
+  confDir    <- ghcupConfigDir
+  recycleDir <- ghcupRecycleDir
   pure Dirs { .. }
 
 
@@ -226,9 +234,9 @@ ghcupConfigFile = do
 
 
 -- | ~/.ghcup/ghc by default.
-ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
+ghcupGHCBaseDir :: (MonadReader env m, HasDirs env) => m FilePath
 ghcupGHCBaseDir = do
-  AppState { dirs = Dirs {..} } <- ask
+  Dirs {..}  <- getDirs
   pure (baseDir </> "ghc")
 
 
@@ -236,7 +244,7 @@ ghcupGHCBaseDir = do
 -- The dir may be of the form
 --   * armv7-unknown-linux-gnueabihf-8.8.3
 --   * 8.8.4
-ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
+ghcupGHCDir :: (MonadReader env m, HasDirs env, MonadThrow m)
             => GHCTargetVersion
             -> m FilePath
 ghcupGHCDir ver = do
@@ -251,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
 
@@ -272,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))
 
 
 
@@ -301,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/Posix.hs

@@ -21,6 +21,7 @@ module GHCup.Utils.File.Posix where
 import           GHCup.Utils.File.Common
 import           GHCup.Utils.Prelude
 import           GHCup.Types
+import           GHCup.Types.Optics
 
 import           Control.Concurrent
 import           Control.Concurrent.Async
@@ -74,7 +75,11 @@ executeOut path args chdir = liftIO $ captureOutStreams $ do
   SPP.executeFile path True args Nothing
 
 
-execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
+execLogged :: ( MonadReader env m
+              , HasSettings env
+              , HasDirs env
+              , MonadIO m
+              , MonadThrow m)
            => FilePath         -- ^ thing to execute
            -> [String]         -- ^ args for the thing
            -> Maybe FilePath   -- ^ optionally chdir into this
@@ -82,7 +87,8 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
            -> Maybe [(String, String)] -- ^ optional environment
            -> m (Either ProcessError ())
 execLogged exe args chdir lfile env = do
-  AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
+  Settings {..} <- getSettings
+  Dirs {..} <- getDirs
   let logfile = logsDir </> lfile <> ".log"
   liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
                    closeFd

lib/GHCup/Utils/File/Windows.hs

@@ -19,6 +19,7 @@ import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
 import           GHCup.Utils.Dirs
 import           GHCup.Utils.File.Common
 import           GHCup.Types
+import           GHCup.Types.Optics
 
 import           Control.Concurrent
 import           Control.DeepSeq
@@ -146,7 +147,11 @@ executeOut path args chdir = do
   pure $ CapturedProcess exit out err
 
 
-execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
+execLogged :: ( MonadReader env m
+              , HasDirs env
+              , HasSettings env
+              , MonadIO m
+              , MonadThrow m)
            => FilePath         -- ^ thing to execute
            -> [String]         -- ^ args for the thing
            -> Maybe FilePath   -- ^ optionally chdir into this
@@ -154,7 +159,7 @@ execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
            -> Maybe [(String, String)] -- ^ optional environment
            -> m (Either ProcessError ())
 execLogged exe args chdir lfile env = do
-  AppState { dirs = Dirs {..} } <- ask
+  Dirs {..} <- getDirs
   let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
       stderrLogfile = logsDir </> lfile <> ".stderr.log"
   cp <- createProcessWithMingwPath ((proc exe args)

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,11 +19,16 @@ 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 )
@@ -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
@@ -54,6 +62,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 +323,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,34 +377,101 @@ 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)
+  Dirs { recycleDir } <- getDirs
+  tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
+  let dest = tmp </> takeFileName fp
+  liftIO (Win32.moveFileEx fp (Just dest) 0)
+      `catch`
+      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+      `finally`
+        (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+#else
+  liftIO $ removePathForcibly fp
+#endif
+
+
+rmPathForcibly :: ( MonadIO m
+                  , MonadMask m
+                  )
+               => FilePath
+               -> m ()
+rmPathForcibly fp =
+#if defined(IS_WINDOWS)
+  recovering (fullJitterBackoff 25000 <> limitRetries 10)
+    [\_ -> Handler (\e -> pure $ isPermissionError e)
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+    ]
+    (\_ -> liftIO $ removePathForcibly fp)
+#else
+  liftIO $ removePathForcibly fp
+#endif
+
+
+rmDirectory :: (MonadIO m, MonadMask m)
+            => FilePath
+            -> m ()
+rmDirectory fp =
 #if defined(IS_WINDOWS)
   recovering (fullJitterBackoff 25000 <> limitRetries 10)
     [\_ -> Handler (\e -> pure $ isPermissionError e)
     ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
     ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
     ]
-    (\_ -> liftIO $ removePathForcibly fp)
+    (\_ -> liftIO $ removeDirectory fp)
 #else
-  liftIO $ removeDirectoryRecursive fp
+  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)
     [\_ -> Handler (\e -> pure $ isPermissionError e)
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
     ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
     ]
     (\_ -> liftIO $ removeFile fp)
@@ -403,6 +480,34 @@ rmFile fp =
 #endif
 
 
+rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
+                => FilePath
+                -> m ()
+rmDirectoryLink fp = 
+#if defined(IS_WINDOWS)
+  recovering (fullJitterBackoff 25000 <> limitRetries 10)
+    [\_ -> Handler (\e -> pure $ isPermissionError e)
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
+    ]
+    (\_ -> 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)

stack.yaml

@@ -31,6 +31,10 @@ extra-deps:
   - libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
   - lzma-static-5.2.5.3@sha256:2758ee58c35992fcf7db78e98684c357a16a82fa2a4e7c352a6c210c08c555d8,7308
   - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
+  - optics-0.4@sha256:9fb69bf0195b8d8f1f8cd0098000946868b8a3c3ffb51e5b64f79fc600c3eb4c,6568
+  - optics-core-0.4@sha256:59e04aebca536bd011ae50c781937f45af4c1456af1eb9fb578f9a69eee293cd,4995
+  - optics-extra-0.4@sha256:b9914f38aa7d5c92f231060d9168447f9f5a367c07df9bf47a003e3e786d5e05,3432
+  - optics-th-0.4@sha256:7c838b5b1d6998133bf8f0641c36197ed6cb468dc69515e1952f33f0bbe8e11d,2009
   - primitive-0.7.1.0@sha256:29de6bfd0cf8ba023ceb806203dfbec0e51e3524e75ffe41056f70b4229c6f0f,2728
   - regex-posix-clib-2.7
   - streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421

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.