Fix bootstrap haskell bashrc stuff

app/ghcup/Main.hs

@@ -34,7 +34,6 @@ 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
@@ -1343,7 +1342,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           (settings, keybindings) <- toSettings opt
 
           -- logger interpreter
-          logfile <- flip runReaderT dirs $ initGHCupFileLogging
+          logfile <- initGHCupFileLogging logsDir
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , colorOutter  = B.hPut stderr
@@ -1387,9 +1386,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             exitWith (ExitFailure 2)
                 let s' = AppState settings dirs keybindings ghcupInfo pfreq
 
-                race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
-                      (threadDelay 5000000 >> runLogger ($(logWarn) [i|Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in #{recycleDir} manually|]))
-
                 lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
                   Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
                   Just _ -> pure ()
@@ -1422,7 +1418,6 @@ 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)
@@ -1520,9 +1515,6 @@ 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
@@ -2071,8 +2063,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
                     )
                   pure ExitSuccess
                 Just uri -> do
-                  s' <- appState
+                  pfreq <- runAppState getPlatformReq
-                  pfreq <- flip runReaderT s' getPlatformReq
                   let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
                       cmd = case _rPlatform pfreq of
                               Darwin  -> "open"
@@ -2082,6 +2073,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
                   if clOpen
                     then do
+                      s' <- appState
                       flip runReaderT s' $
                         exec cmd
                              [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
@@ -2093,10 +2085,10 @@ Make sure to clean up #{tmpdir} afterwards.|])
                                   >> pure (ExitFailure 13)
                     else putStrLn uri' >> pure ExitSuccess
 
-            Nuke -> do
+            Nuke ->
-              s' <- liftIO appState
+              runRm (do
-              void $ liftIO $ evaluate $ force s'
+                   s' <- liftIO appState
-              runNuke s' (do
+                   void $ liftIO $ evaluate $ force s'
                    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

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
 

ghcup.cabal

@@ -202,7 +202,6 @@ executable ghcup
     -fwarn-incomplete-record-updates -threaded
 
   build-depends:
-    , async                 ^>=2.2.3
     , base                  >=4.13     && <5
     , bytestring            ^>=0.10
     , containers            ^>=0.6

lib/GHCup.hs

@@ -54,9 +54,6 @@ 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
@@ -255,6 +252,22 @@ installPackedGHC :: ( MonadMask m
 #endif
                        ] m ()
 installPackedGHC dl msubdir inst ver = do
+#if defined(IS_WINDOWS)
+  lift $ $(logInfo) "Installing GHC (this may take a while)"
+
+  Dirs { tmpDir } <- lift getDirs
+  unpackDir <- liftIO $ emptyTempFile tmpDir "ghc"
+  liftIO $ rmFile unpackDir
+
+  liftE $ unpackToDir unpackDir dl
+
+  d <- case msubdir of
+    Just td -> liftE $ intoSubdir unpackDir td
+    Nothing -> pure unpackDir
+
+  liftIO $ Win32.moveFileEx d (Just inst) 0
+  liftIO $ rmPath unpackDir
+#else
   PlatformRequest {..} <- lift getPlatformReq
 
   -- unpack
@@ -270,6 +283,7 @@ installPackedGHC dl msubdir inst ver = do
   liftE $ runBuildAction tmpUnpack
                          (Just inst)
                          (installUnpackedGHC workdir inst ver)
+#endif
 
 
 -- | Install an unpacked GHC distribution. This only deals with the GHC
@@ -281,29 +295,13 @@ 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 ()
 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
@@ -314,6 +312,9 @@ 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)
@@ -321,7 +322,6 @@ installUnpackedGHC path inst ver = do
                    Nothing
   lEM $ make ["install"] (Just path)
   pure ()
-#endif
 
 
 -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@@ -801,10 +801,7 @@ setGHC ver sghc = do
   symlinkShareDir :: ( MonadReader env m
                      , HasDirs env
                      , MonadIO m
-                     , MonadLogger m
+                     , MonadLogger m)
-                     , MonadCatch m
-                     , MonadMask m
-                     )
                   => FilePath
                   -> String
                   -> m ()
@@ -819,7 +816,7 @@ setGHC ver sghc = do
           let fullF   = destdir </> sharedir
           let targetF = "." </> "ghc" </> ver' </> sharedir
           $(logDebug) [i|rm -f #{fullF}|]
-          hideError doesNotExistErrorType $ rmDirectoryLink fullF
+          liftIO $ hideError doesNotExistErrorType $ removeDirectoryLink fullF
           $(logDebug) [i|ln -s #{targetF} #{fullF}|]
           liftIO
 #if defined(IS_WINDOWS)
@@ -887,7 +884,7 @@ setHLS ver = do
   oldSyms <- lift hlsSymlinks
   forM_ oldSyms $ \f -> do
     lift $ $(logDebug) [i|rm #{binDir </> f}|]
-    lift $ rmLink (binDir </> f)
+    liftIO $ rmLink (binDir </> f)
 
   -- set haskell-language-server-<ghcver> symlinks
   bins <- lift $ hlsServerBinaries ver
@@ -1310,7 +1307,7 @@ rmGHCVer ver = do
   -- then fix them (e.g. with an earlier version)
 
   lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
-  lift $ recyclePathForcibly dir
+  liftIO $ rmPath dir
 
   v' <-
     handle
@@ -1322,7 +1319,9 @@ rmGHCVer ver = do
 
   Dirs {..} <- lift getDirs
 
-  lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
+  liftIO
+    $ hideError doesNotExistErrorType
+    $ rmFile (baseDir </> "share")
 
 
 -- | Delete a cabal version. Will try to fix the @cabal@ symlink
@@ -1347,13 +1346,13 @@ rmCabalVer ver = do
   Dirs {..} <- lift getDirs
 
   let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-  lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)
+  liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
 
   when (Just ver == cSet) $ do
     cVers <- lift $ fmap rights getInstalledCabals
     case headMay . reverse . sort $ cVers of
       Just latestver -> setCabal latestver
-      Nothing        -> lift $ rmLink (binDir </> "cabal" <> exeExt)
+      Nothing        -> liftIO $ rmLink (binDir </> "cabal" <> exeExt)
 
 
 -- | Delete a hls version. Will try to fix the hls symlinks
@@ -1378,7 +1377,7 @@ rmHLSVer ver = do
   Dirs {..} <- lift getDirs
 
   bins <- lift $ hlsAllBinaries ver
-  forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
+  forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
 
   when (Just ver == isHlsSet) $ do
     -- delete all set symlinks
@@ -1386,7 +1385,7 @@ rmHLSVer ver = do
     forM_ oldSyms $ \f -> do
       let fullF = binDir </> f
       lift $ $(logDebug) [i|rm #{fullF}|]
-      lift $ rmLink fullF
+      liftIO $ rmLink fullF
     -- set latest hls
     hlsVers <- lift $ fmap rights getInstalledHLSs
     case headMay . reverse . sort $ hlsVers of
@@ -1416,13 +1415,13 @@ rmStackVer ver = do
   Dirs {..} <- lift getDirs
 
   let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-  lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)
+  liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
 
   when (Just ver == sSet) $ do
     sVers <- lift $ fmap rights getInstalledStacks
     case headMay . reverse . sort $ sVers of
       Just latestver -> setStack latestver
-      Nothing        -> lift $ rmLink (binDir </> "stack" <> exeExt)
+      Nothing        -> liftIO $ rmLink (binDir </> "stack" <> exeExt)
 
 
 -- assuming the current scheme of having just 1 ghcup bin, no version info is required.
@@ -1431,12 +1430,10 @@ rmGhcup :: ( MonadReader env m
            , MonadIO m
            , MonadCatch m
            , MonadLogger m
-           , MonadMask m
-           , MonadUnliftIO m
            )
         => m ()
 rmGhcup = do
-  Dirs { .. } <- getDirs
+  Dirs {binDir} <- getDirs
   let ghcupFilename = "ghcup" <> exeExt
   let ghcupFilepath = binDir </> ghcupFilename
 
@@ -1458,15 +1455,16 @@ rmGhcup = do
   unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
 
 #if defined(IS_WINDOWS)
-  -- since it doesn't seem possible to delete a running exe on windows
+  -- since it doesn't seem possible to delete a running exec in windows
   -- we move it to temp dir, to be deleted at next reboot
-  tempFilepath <- mkGhcupTmpDir
+  tempDir <- liftIO $ getTemporaryDirectory
+  let tempFilepath = tempDir </> ghcupFilename
   hideError UnsupportedOperation $
             liftIO $ hideError NoSuchThing $
-            Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
+            Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
 #else
   -- delete it.
-  hideError doesNotExistErrorType $ rmFile ghcupFilepath
+  hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
 #endif
 
   where
@@ -1511,46 +1509,42 @@ rmGhcupDirs = do
     , binDir
     , logsDir
     , cacheDir
-    , recycleDir
+    , tmpDir
     } <- getDirs
 
   let envFilePath = baseDir </> "env"
 
   confFilePath <- getConfigFilePath
 
-  handleRm $ rmEnvFile  envFilePath
+  rmEnvFile  envFilePath
-  handleRm $ rmConfFile confFilePath
+  rmConfFile confFilePath
-  handleRm $ rmDir cacheDir
+  rmDir cacheDir
-  handleRm $ rmDir logsDir
+  rmDir logsDir
-  handleRm $ rmBinDir binDir
+  rmBinDir   binDir
-  handleRm $ rmDir recycleDir
+  rmDir tmpDir
 #if defined(IS_WINDOWS)
-  $logInfo [i|removing #{(baseDir </> "msys64")}|]
+  rmDir (baseDir </> "msys64")
-  handleRm $ rmPathForcibly (baseDir </> "msys64")
 #endif
 
-  handleRm $ removeEmptyDirsRecursive baseDir
+  liftIO $ 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 -> $logWarn [i|Part of the cleanup action failed with error: #{displayException e}
-continuing regardless...|])
 
-    rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
+    rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
     rmEnvFile enFilePath = do
       $logInfo "Removing Ghcup Environment File"
-      deleteFile enFilePath
+      liftIO $ deleteFile enFilePath
 
-    rmConfFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
+    rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
     rmConfFile confFilePath = do
       $logInfo "removing Ghcup Config File"
-      deleteFile confFilePath
+      liftIO $ deleteFile confFilePath
 
-    rmDir :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
+    rmDir :: (MonadLogger 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,
@@ -1558,9 +1552,9 @@ continuing regardless...|])
       hideErrorDef [doesNotExistErrorType] () $ do
         $logInfo [i|removing #{dir}|]
         contents <- liftIO $ getDirectoryContentsRecursive dir
-        forM_ contents (deleteFile . (dir </>))
+        forM_ contents (liftIO . deleteFile . (dir </>))
 
-    rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
+    rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
     rmBinDir binDir = do
 #if !defined(IS_WINDOWS)
       isXDGStyle <- liftIO useXDG
@@ -1589,9 +1583,9 @@ continuing regardless...|])
         compareFn :: FilePath -> FilePath -> Ordering
         compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
 
-    removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
+    removeEmptyDirsRecursive :: FilePath -> IO ()
     removeEmptyDirsRecursive fp = do
-      cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
+      cs <- listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
       forM_ cs removeEmptyDirsRecursive
       hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
         
@@ -1600,22 +1594,22 @@ continuing regardless...|])
     -- we report remaining files/dirs later,
     -- hence the force/quiet mode in these delete functions below.
 
-    deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
+    deleteFile :: FilePath -> IO ()
     deleteFile filepath = do
       hideError doesNotExistErrorType
         $ hideError InappropriateType $ rmFile filepath
 
-    removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
+    removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
     removeDirIfEmptyOrIsSymlink filepath =
       hideError UnsatisfiedConstraints $
       handleIO' InappropriateType
             (handleIfSym filepath)
-            (liftIO $ rmDirectory filepath)
+            (liftIO $ removeDirectory filepath)
       where
         handleIfSym fp e = do
           isSym <- liftIO $ pathIsSymbolicLink fp
           if isSym
-          then deleteFile fp
+          then liftIO $ deleteFile fp
           else liftIO $ ioError e
 
 
@@ -2139,14 +2133,27 @@ upgradeGHCup mtarget force' = do
   let fn = "ghcup" <> exeExt
   p <- liftE $ download dli tmp (Just fn)
   let destDir = takeDirectory destFile
-      destFile = fromMaybe (binDir </> fn) mtarget
+      destFile = fromMaybe (binDir </> fn <> exeExt) mtarget
   lift $ $(logDebug) [i|mkdir -p #{destDir}|]
   liftIO $ createDirRecursive' destDir
-  lift $ $(logDebug) [i|rm -f #{destFile}|]
+#if defined(IS_WINDOWS)
-  lift $ hideError NoSuchThing $ recycleFile destFile
+  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 $ $(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

@@ -115,7 +115,6 @@ getDownloadsF :: ( FromJSONKey Tool
                  , MonadLogger m
                  , MonadThrow m
                  , MonadFail m
-                 , MonadMask m
                  )
               => Excepts
                    '[JSONError , DownloadFailed , FileDoesNotExistError]
@@ -171,7 +170,6 @@ getBase :: ( MonadReader env m
            , MonadIO m
            , MonadCatch m
            , MonadLogger m
-           , MonadMask m
            )
         => URI
         -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
@@ -210,7 +208,6 @@ getBase uri = do
              , MonadIO m1
              , MonadFail m1
              , MonadLogger m1
-             , MonadMask m1
              )
           => URI
           -> Excepts
@@ -265,7 +262,7 @@ getBase uri = do
       pure bs
     dlWithoutMod json_file = do
       bs <- liftE $ downloadBS uri'
-      lift $ hideError doesNotExistErrorType $ recycleFile json_file
+      liftIO $ hideError doesNotExistErrorType $ rmFile json_file
       liftIO $ L.writeFile json_file bs
       liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
       pure bs
@@ -388,10 +385,10 @@ download dli dest mfn
 
     -- download
     flip onException
-         (lift $ hideError doesNotExistErrorType $ recycleFile destFile)
+         (liftIO $ hideError doesNotExistErrorType $ rmFile destFile)
      $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
           (\e ->
-            lift (hideError doesNotExistErrorType $ recycleFile destFile)
+            liftIO (hideError doesNotExistErrorType $ rmFile destFile)
               >> (throwE . DownloadFailed $ e)
           ) $ do
               Settings{ downloader, noNetwork } <- lift getSettings

lib/GHCup/Types.hs

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

lib/GHCup/Types/Optics.hs

@@ -1,11 +1,9 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE AllowAmbiguousTypes   #-}
-{-# LANGUAGE MultiParamTypeClasses   #-}
 
 {-|
 Module      : GHCup.Types.Optics
@@ -145,6 +143,3 @@ 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,7 +53,6 @@ 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
@@ -124,7 +123,6 @@ rmMinorSymlinks :: ( MonadReader env m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
-                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
@@ -136,7 +134,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}|]
-    lift $ hideError doesNotExistErrorType $ rmLink fullF
+    liftIO $ hideError doesNotExistErrorType $ rmLink fullF
 
 
 -- | Removes the set ghc version for the given target, if any.
@@ -146,7 +144,6 @@ rmPlain :: ( MonadReader env m
            , MonadThrow m
            , MonadFail m
            , MonadIO m
-           , MonadMask m
            )
         => Maybe Text -- ^ target
         -> Excepts '[NotInstalled] m ()
@@ -158,11 +155,11 @@ rmPlain target = do
     forM_ files $ \f -> do
       let fullF = binDir </> f <> exeExt
       lift $ $(logDebug) [i|rm -f #{fullF}|]
-      lift $ hideError doesNotExistErrorType $ rmLink fullF
+      liftIO $ hideError doesNotExistErrorType $ rmLink fullF
     -- old ghcup
     let hdc_file = binDir </> "haddock-ghc" <> exeExt
     lift $ $(logDebug) [i|rm -f #{hdc_file}|]
-    lift $ hideError doesNotExistErrorType $ rmLink hdc_file
+    liftIO $ hideError doesNotExistErrorType $ rmLink hdc_file
 
 
 -- | Remove the major GHC symlink, e.g. ghc-8.6.
@@ -172,7 +169,6 @@ rmMajorSymlinks :: ( MonadReader env m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
-                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
@@ -186,7 +182,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
     let f_xy = f <> "-" <> T.unpack v' <> exeExt
     let fullF = binDir </> f_xy
     lift $ $(logDebug) [i|rm -f #{fullF}|]
-    lift $ hideError doesNotExistErrorType $ rmLink fullF
+    liftIO $ hideError doesNotExistErrorType $ rmLink fullF
 
 
 
@@ -887,17 +883,8 @@ 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 :: ( Pretty (V e)
+runBuildAction :: (Pretty (V e), Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
-                  , Show (V e)
+               => FilePath          -- ^ build directory (cleaned up depending on Settings)
-                  , 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
@@ -905,9 +892,11 @@ runBuildAction bdir instdir action = do
   Settings {..} <- lift getSettings
   let exAction = do
         forM_ instdir $ \dir ->
-          lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
+          liftIO $ hideError doesNotExistErrorType $ rmPath dir
         when (keepDirs == Never)
-          $ lift $ rmBDir bdir
+          $ liftIO
+          $ hideError doesNotExistErrorType
+          $ rmPath bdir
   v <-
     flip onException exAction
     $ catchAllE
@@ -916,20 +905,10 @@ runBuildAction bdir instdir action = do
           throwE (BuildFailed bdir es)
         ) action
 
-  when (keepDirs == Never || keepDirs == Errors) $ lift $ rmBDir bdir
+  when (keepDirs == Never || keepDirs == Errors) $ liftIO $ rmPath 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
@@ -1016,13 +995,13 @@ pathIsLink = pathIsSymbolicLink
 #endif
 
 
-rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
+rmLink :: FilePath -> IO ()
 #if defined(IS_WINDOWS)
 rmLink fp = do
-  hideError doesNotExistErrorType . recycleFile $ fp
+  hideError doesNotExistErrorType . liftIO . rmFile $ fp
-  hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
+  hideError doesNotExistErrorType . liftIO . rmFile $ (dropExtension fp <.> "shim")
 #else
-rmLink = hideError doesNotExistErrorType . recycleFile
+rmLink = hideError doesNotExistErrorType . liftIO . rmFile
 #endif
 
 
@@ -1060,14 +1039,14 @@ createLink link exe = do
       shimContents = "path = " <> fullLink
 
   $(logDebug) [i|rm -f #{exe}|]
-  rmLink exe
+  liftIO $ rmLink exe
 
   $(logDebug) [i|ln -s #{fullLink} #{exe}|]
   liftIO $ copyFile shimGen exe
   liftIO $ writeFile shim shimContents
 #else
   $(logDebug) [i|rm -f #{exe}|]
-  hideError doesNotExistErrorType $ recycleFile exe
+  liftIO $ hideError doesNotExistErrorType $ rmFile exe
 
   $(logDebug) [i|ln -s #{link} #{exe}|]
   liftIO $ createFileLink link exe
@@ -1089,6 +1068,7 @@ 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
@@ -1096,7 +1076,7 @@ ensureGlobalTools = do
   void $ (\(DigestError _ _) -> do
       lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
       lift $ $(logDebug) [i|rm -f #{shimDownload}|]
-      lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
+      liftIO $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
       liftE @'[DigestError , DownloadFailed] $ dl
     ) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
   pure ()
@@ -1107,14 +1087,14 @@ ensureGlobalTools = do
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
   createDirRecursive' baseDir
   createDirRecursive' (baseDir </> "ghc")
   createDirRecursive' binDir
   createDirRecursive' cacheDir
   createDirRecursive' logsDir
   createDirRecursive' confDir
-  createDirRecursive' trashDir
+  createDirRecursive' tmpDir
   pure ()
 
 
@@ -1128,3 +1108,4 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = 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,7 +30,6 @@ module GHCup.Utils.Dirs
 #if !defined(IS_WINDOWS)
   , useXDG
 #endif
-  , cleanupTrash
   )
 where
 
@@ -54,7 +53,9 @@ 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,21 +191,23 @@ ghcupLogsDir = do
 #endif
 
 
--- | '~/.ghcup/trash'.
+-- | Defaults to '~/.ghcup/tmp.
--- Mainly used on windows to improve file removal operations
+--
-ghcupRecycleDir :: IO FilePath
+-- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
-ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
+-- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec.
+ghcupTmpDir :: IO FilePath
+ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
 
 
 
 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
+  tmpDir   <- ghcupTmpDir
   pure Dirs { .. }
 
 
@@ -259,15 +262,7 @@ parseGHCupGHCDir (T.pack -> fp) =
   throwEither $ MP.parse ghcTargetVerP "" fp
 
 
-mkGhcupTmpDir :: ( MonadReader env m
+mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
-                 , HasDirs env
-                 , MonadUnliftIO m
-                 , MonadLogger m
-                 , MonadCatch m
-                 , MonadThrow m
-                 , MonadMask m
-                 , MonadIO m)
-              => m FilePath
 mkGhcupTmpDir = do
   tmpdir <- liftIO getCanonicalTemporaryDirectory
 
@@ -288,25 +283,8 @@ mkGhcupTmpDir = do
       where t = 10^n
 
 
-withGHCupTmpDir :: ( MonadReader env m
+withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
-                   , HasDirs env
+withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
-                   , 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))
 
 
 
@@ -334,21 +312,3 @@ 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/Logger.hs

@@ -14,16 +14,12 @@ 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
@@ -83,21 +79,17 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
     rawOutter outr
 
 
-initGHCupFileLogging :: ( MonadReader env m
+initGHCupFileLogging :: (MonadIO m) => FilePath -> m FilePath
-                        , HasDirs env
+initGHCupFileLogging logsDir = do
-                        , MonadIO m
-                        , MonadMask m
-                        ) => m FilePath
-initGHCupFileLogging = do
-  Dirs { logsDir } <- getDirs
   let logfile = logsDir </> "ghcup.log"
-  logFiles <- liftIO $ findFiles
+  liftIO $ do
-    logsDir
+    logFiles <- findFiles
-    (makeRegexOpts compExtended
+      logsDir
-                   execBlank
+      (makeRegexOpts compExtended
-                   ([s|^.*\.log$|] :: B.ByteString)
+                     execBlank
-    )
+                     ([s|^.*\.log$|] :: B.ByteString)
-  forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
+      )
+    forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
 
-  liftIO $ writeFile logfile ""
+    writeFile logfile ""
-  pure logfile
+    pure logfile

lib/GHCup/Utils/Prelude.hs

@@ -19,16 +19,11 @@ 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.Reader
+import           Control.Monad.Trans.Class      ( lift )
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
 import           Data.List                      ( nub )
@@ -40,9 +35,6 @@ 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
@@ -62,9 +54,6 @@ 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
 
 
 
@@ -323,16 +312,17 @@ createDirRecursive' p =
 -- | Recursively copy the contents of one directory to another path.
 --
 -- This is a rip-off of Cabal library.
-copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
+copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
-copyDirectoryRecursive srcDir destDir doCopy = do
+copyDirectoryRecursive srcDir destDir = do
   srcFiles <- getDirectoryContentsRecursive srcDir
-  copyFilesWith destDir [ (srcDir, f)
+  copyFilesWith copyFile destDir [ (srcDir, f)
-                          | f <- srcFiles ]
+                                   | f <- srcFiles ]
   where
     -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
     -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
-    copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
+    copyFilesWith :: (FilePath -> FilePath -> IO ())
-    copyFilesWith targetDir srcFiles = do
+                  -> FilePath -> [(FilePath, FilePath)] -> IO ()
+    copyFilesWith doCopy targetDir srcFiles = do
 
       -- Create parent directories for everything
       let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
@@ -377,101 +367,34 @@ 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
-recyclePathForcibly :: ( MonadIO m
+rmPath :: (MonadIO m, MonadMask m)
-                       , MonadReader env m
+      => FilePath
-                       , HasDirs env
+      -> m ()
-                       , MonadMask m
+rmPath fp =
-                       )
-                    => 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))
+    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == InappropriateType))
     ]
     (\_ -> liftIO $ removePathForcibly fp)
 #else
-  liftIO $ removePathForcibly fp
+  liftIO $ removeDirectoryRecursive 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 $ removeDirectory fp)
-#else
-  liftIO $ removeDirectory fp
 #endif
 
 
 -- https://www.sqlite.org/src/info/89f1848d7f
 -- https://github.com/haskell/directory/issues/96
-recycleFile :: ( MonadIO m
+rmFile :: (MonadIO m, MonadMask 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)
@@ -480,34 +403,6 @@ 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)