Redo file handling wrt #165 and #187

Fixes #183

.gitlab-ci.yml

@@ -281,11 +281,31 @@ test:linux:cross-armv7:
     CROSS: "arm-linux-gnueabihf"
   needs: []
   when: manual
+  allow_failure: true
   before_script:
     - ./.gitlab/before_script/linux/install_deps.sh
   script:
     - ./.gitlab/script/ghcup_cross.sh
 
+test:linux:git:hadrian:
+  stage: test
+  extends:
+    - .test_ghcup_version
+    - .debian
+  variables:
+    GHC_VERSION: "8.10.5"
+    GHC_GIT_TAG: "ghc-9.0.1-release"
+    GHC_GIT_VERSION: "9.0.1"
+    CABAL_VERSION: "3.4.0.0"
+    CROSS: ""
+  needs: []
+  when: manual
+  allow_failure: true
+  before_script:
+    - ./.gitlab/before_script/linux/install_deps.sh
+  script:
+    - ./.gitlab/script/ghcup_git.sh
+
 
 ######## linux 32bit test ########
 

.gitlab/script/ghcup_git.sh

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

app/ghcup/Main.hs

@@ -34,6 +34,7 @@ import           GHCup.Version
 import           Codec.Archive
 #endif
 import           Control.Concurrent
+import           Control.Concurrent.Async
 import           Control.DeepSeq                ( force )
 import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
@@ -182,6 +183,8 @@ data GHCCompileOptions = GHCCompileOptions
   , addConfArgs  :: [Text]
   , setCompile   :: Bool
   , ovewrwiteVer :: Maybe Version
+  , buildFlavour :: Maybe String
+  , hadrian      :: Bool
   }
 
 data UpgradeOpts = UpgradeInplace
@@ -987,6 +990,16 @@ ghcCompileOpts =
               "Allows to overwrite the finally installed VERSION with a different one, e.g. when you build 8.10.4 with your own patches, you might want to set this to '8.10.4-p1'"
             )
           )
+    <*> optional
+          (option
+            str
+            (short 'f' <> long "flavour" <> metavar "BUILD_FLAVOUR" <> help
+              "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
+            )
+          )
+    <*> switch
+          (long "hadrian" <> help "Use the hadrian build system instead of make (only git versions seem to be properly supported atm)"
+          )
 
 
 toolVersionParser :: Parser ToolVersion
@@ -1330,7 +1343,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           (settings, keybindings) <- toSettings opt
 
           -- logger interpreter
-          logfile <- initGHCupFileLogging logsDir
+          logfile <- flip runReaderT dirs $ initGHCupFileLogging
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , colorOutter  = B.hPut stderr
@@ -1374,6 +1387,9 @@ 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 ()
@@ -1406,6 +1422,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           -- Effect interpreters --
           -------------------------
 
+
           let runInstTool' appstate' mInstPlatform =
                 runLogger
                   . flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
@@ -1503,6 +1520,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let runRm =
                 runLogger . runAppState . runE @'[NotInstalled]
 
+          let runNuke s' =
+                runLogger . flip runReaderT s' . runE @'[NotInstalled]
+
           let runDebugInfo =
                 runLogger
                   . runAppState
@@ -1906,6 +1926,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                         runLogger $ $(logError) $ T.pack $ prettyShow e
                         pure $ ExitFailure 8
 
+            Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
+              runLogger $ $(logError) "Hadrian cross compile support is not yet implemented!"
+              pure $ ExitFailure 9
             Compile (CompileGHC GHCCompileOptions {..}) ->
               runCompileGHC (do
                 case targetGhc of
@@ -1926,6 +1949,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             buildConfig
                             patchDir
                             addConfArgs
+                            buildFlavour
+                            hadrian
                 GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
                 let vi = getVersionInfo (_tvVersion targetVer) GHC dls
                 when setCompile $ void $ liftE $
@@ -2046,7 +2071,8 @@ Make sure to clean up #{tmpdir} afterwards.|])
                     )
                   pure ExitSuccess
                 Just uri -> do
-                  pfreq <- runAppState getPlatformReq
+                  s' <- appState
+                  pfreq <- flip runReaderT s' getPlatformReq
                   let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
                       cmd = case _rPlatform pfreq of
                               Darwin  -> "open"
@@ -2056,7 +2082,6 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
                   if clOpen
                     then do
-                      s' <- appState
                       flip runReaderT s' $
                         exec cmd
                              [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
@@ -2068,10 +2093,10 @@ Make sure to clean up #{tmpdir} afterwards.|])
                                   >> pure (ExitFailure 13)
                     else putStrLn uri' >> pure ExitSuccess
 
-            Nuke ->
-              runRm (do
-                   s' <- liftIO appState
-                   void $ liftIO $ evaluate $ force s'
+            Nuke -> do
+              s' <- liftIO appState
+              void $ liftIO $ evaluate $ force s'
+              runNuke s' (do
                    lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
                    lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
                    liftIO $ threadDelay 10000000  -- wait 10s

ghcup.cabal

@@ -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

lib/GHCup.hs

@@ -54,6 +54,9 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
+#if defined(IS_WINDOWS)
+import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
+#endif
 import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.List
@@ -252,22 +255,6 @@ 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
@@ -283,7 +270,6 @@ 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
@@ -295,13 +281,29 @@ installUnpackedGHC :: ( MonadReader env m
                       , MonadThrow m
                       , MonadLogger m
                       , MonadIO m
+                      , MonadUnliftIO m
+                      , MonadMask m
                       )
                    => FilePath      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
                    -> FilePath      -- ^ Path to install to
                    -> Version       -- ^ The GHC version
                    -> Excepts '[ProcessError] m ()
 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
@@ -312,9 +314,6 @@ installUnpackedGHC path inst ver = do
   lift $ $(logInfo) "Installing GHC (this may take a while)"
   lEM $ execLogged "sh"
                    ("./configure" : ("--prefix=" <> inst) 
-#if defined(IS_WINDOWS)
-                    : "--enable-tarballs-autodownload"
-#endif
                     : alpineArgs
                    )
                    (Just path)
@@ -322,6 +321,7 @@ installUnpackedGHC path inst ver = do
                    Nothing
   lEM $ make ["install"] (Just path)
   pure ()
+#endif
 
 
 -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@@ -801,7 +801,10 @@ setGHC ver sghc = do
   symlinkShareDir :: ( MonadReader env m
                      , HasDirs env
                      , MonadIO m
-                     , MonadLogger m)
+                     , MonadLogger m
+                     , MonadCatch m
+                     , MonadMask m
+                     )
                   => FilePath
                   -> String
                   -> m ()
@@ -816,7 +819,7 @@ setGHC ver sghc = do
           let fullF   = destdir </> sharedir
           let targetF = "." </> "ghc" </> ver' </> sharedir
           $(logDebug) [i|rm -f #{fullF}|]
-          liftIO $ hideError doesNotExistErrorType $ removeDirectoryLink fullF
+          hideError doesNotExistErrorType $ rmDirectoryLink fullF
           $(logDebug) [i|ln -s #{targetF} #{fullF}|]
           liftIO
 #if defined(IS_WINDOWS)
@@ -884,7 +887,7 @@ setHLS ver = do
   oldSyms <- lift hlsSymlinks
   forM_ oldSyms $ \f -> do
     lift $ $(logDebug) [i|rm #{binDir </> f}|]
-    liftIO $ rmLink (binDir </> f)
+    lift $ rmLink (binDir </> f)
 
   -- set haskell-language-server-<ghcver> symlinks
   bins <- lift $ hlsServerBinaries ver
@@ -1010,10 +1013,10 @@ listVersions lt' criteria = do
             slr <- strayCabals avTools cSet cabals
             pure (sort (slr ++ lr))
           HLS -> do
-            slr <- strayHLS avTools
+            slr <- strayHLS avTools hlsSet' hlses
             pure (sort (slr ++ lr))
           Stack -> do
-            slr <- strayStacks avTools
+            slr <- strayStacks avTools sSet stacks
             pure (sort (slr ++ lr))
           GHCup -> pure lr
       Nothing -> do
@@ -1113,15 +1116,16 @@ listVersions lt' criteria = do
               , MonadLogger m
               , MonadIO m)
            => Map.Map Version [Tag]
+           -> Maybe Version
+           -> [Either FilePath Version]
            -> m [ListResult]
-  strayHLS avTools = do
-    hlss <- getInstalledHLSs
+  strayHLS avTools hlsSet' hlss = do
     fmap catMaybes $ forM hlss $ \case
       Right ver ->
         case Map.lookup ver avTools of
           Just _  -> pure Nothing
           Nothing -> do
-            lSet    <- fmap (== Just ver) hlsSet
+            let lSet = hlsSet' == Just ver
             pure $ Just $ ListResult
               { lTool      = HLS
               , lVer       = ver
@@ -1147,15 +1151,16 @@ listVersions lt' criteria = do
                  , MonadIO m
                  )
               => Map.Map Version [Tag]
+              -> Maybe Version
+              -> [Either FilePath Version]
               -> m [ListResult]
-  strayStacks avTools = do
-    stacks <- getInstalledStacks
+  strayStacks avTools stackSet' stacks = do
     fmap catMaybes $ forM stacks $ \case
       Right ver ->
         case Map.lookup ver avTools of
           Just _  -> pure Nothing
           Nothing -> do
-            lSet    <- fmap (== Just ver) hlsSet
+            let lSet = stackSet' == Just ver
             pure $ Just $ ListResult
               { lTool      = Stack
               , lVer       = ver
@@ -1305,7 +1310,7 @@ rmGHCVer ver = do
   -- then fix them (e.g. with an earlier version)
 
   lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
-  liftIO $ rmPath dir
+  lift $ recyclePathForcibly dir
 
   v' <-
     handle
@@ -1317,9 +1322,7 @@ rmGHCVer ver = do
 
   Dirs {..} <- lift getDirs
 
-  liftIO
-    $ hideError doesNotExistErrorType
-    $ rmFile (baseDir </> "share")
+  lift $ hideError doesNotExistErrorType $ rmDirectoryLink (baseDir </> "share")
 
 
 -- | Delete a cabal version. Will try to fix the @cabal@ symlink
@@ -1344,13 +1347,13 @@ rmCabalVer ver = do
   Dirs {..} <- lift getDirs
 
   let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
-  liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> cabalFile)
+  lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> cabalFile)
 
   when (Just ver == cSet) $ do
     cVers <- lift $ fmap rights getInstalledCabals
     case headMay . reverse . sort $ cVers of
       Just latestver -> setCabal latestver
-      Nothing        -> liftIO $ rmLink (binDir </> "cabal" <> exeExt)
+      Nothing        -> lift $ rmLink (binDir </> "cabal" <> exeExt)
 
 
 -- | Delete a hls version. Will try to fix the hls symlinks
@@ -1375,7 +1378,7 @@ rmHLSVer ver = do
   Dirs {..} <- lift getDirs
 
   bins <- lift $ hlsAllBinaries ver
-  forM_ bins $ \f -> liftIO $ rmFile (binDir </> f)
+  forM_ bins $ \f -> lift $ recycleFile (binDir </> f)
 
   when (Just ver == isHlsSet) $ do
     -- delete all set symlinks
@@ -1383,7 +1386,7 @@ rmHLSVer ver = do
     forM_ oldSyms $ \f -> do
       let fullF = binDir </> f
       lift $ $(logDebug) [i|rm #{fullF}|]
-      liftIO $ rmLink fullF
+      lift $ rmLink fullF
     -- set latest hls
     hlsVers <- lift $ fmap rights getInstalledHLSs
     case headMay . reverse . sort $ hlsVers of
@@ -1413,13 +1416,13 @@ rmStackVer ver = do
   Dirs {..} <- lift getDirs
 
   let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-  liftIO $ hideError doesNotExistErrorType $ rmFile (binDir </> stackFile)
+  lift $ hideError doesNotExistErrorType $ recycleFile (binDir </> stackFile)
 
   when (Just ver == sSet) $ do
     sVers <- lift $ fmap rights getInstalledStacks
     case headMay . reverse . sort $ sVers of
       Just latestver -> setStack latestver
-      Nothing        -> liftIO $ rmLink (binDir </> "stack" <> exeExt)
+      Nothing        -> lift $ rmLink (binDir </> "stack" <> exeExt)
 
 
 -- assuming the current scheme of having just 1 ghcup bin, no version info is required.
@@ -1428,10 +1431,12 @@ rmGhcup :: ( MonadReader env m
            , MonadIO m
            , MonadCatch m
            , MonadLogger m
+           , MonadMask m
+           , MonadUnliftIO m
            )
         => m ()
 rmGhcup = do
-  Dirs {binDir} <- getDirs
+  Dirs { .. } <- getDirs
   let ghcupFilename = "ghcup" <> exeExt
   let ghcupFilepath = binDir </> ghcupFilename
 
@@ -1453,16 +1458,15 @@ rmGhcup = do
   unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
 
 #if defined(IS_WINDOWS)
-  -- since it doesn't seem possible to delete a running exec in windows
+  -- since it doesn't seem possible to delete a running exe on windows
   -- we move it to temp dir, to be deleted at next reboot
-  tempDir <- liftIO $ getTemporaryDirectory
-  let tempFilepath = tempDir </> ghcupFilename
+  tempFilepath <- mkGhcupTmpDir
   hideError UnsupportedOperation $
             liftIO $ hideError NoSuchThing $
-            Win32.moveFileEx ghcupFilepath (Just tempFilepath) Win32.mOVEFILE_REPLACE_EXISTING
+            Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
 #else
   -- delete it.
-  hideError doesNotExistErrorType $ liftIO $ rmFile ghcupFilepath
+  hideError doesNotExistErrorType $ rmFile ghcupFilepath
 #endif
 
   where
@@ -1507,42 +1511,46 @@ rmGhcupDirs = do
     , binDir
     , logsDir
     , cacheDir
-    , tmpDir
+    , recycleDir
     } <- getDirs
 
   let envFilePath = baseDir </> "env"
 
   confFilePath <- getConfigFilePath
 
-  rmEnvFile  envFilePath
-  rmConfFile confFilePath
-  rmDir cacheDir
-  rmDir logsDir
-  rmBinDir   binDir
-  rmDir tmpDir
+  handleRm $ rmEnvFile  envFilePath
+  handleRm $ rmConfFile confFilePath
+  handleRm $ rmDir cacheDir
+  handleRm $ rmDir logsDir
+  handleRm $ rmBinDir binDir
+  handleRm $ rmDir recycleDir
 #if defined(IS_WINDOWS)
-  rmDir (baseDir </> "msys64")
+  $logInfo [i|removing #{(baseDir </> "msys64")}|]
+  handleRm $ rmPathForcibly (baseDir </> "msys64")
 #endif
 
-  liftIO $ removeEmptyDirsRecursive baseDir
+  handleRm $ removeEmptyDirsRecursive baseDir
 
   -- report files in baseDir that are left-over after
   -- the standard location deletions above
   hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
 
   where
+    handleRm :: (MonadCatch m, MonadLogger m)  => m () -> m ()
+    handleRm = handleIO (\e -> $logWarn [i|Part of the cleanup action failed with error: #{displayException e}
+continuing regardless...|])
 
-    rmEnvFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
+    rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     rmEnvFile enFilePath = do
       $logInfo "Removing Ghcup Environment File"
-      liftIO $ deleteFile enFilePath
+      deleteFile enFilePath
 
-    rmConfFile :: (MonadCatch m, MonadLogger m, MonadIO m) => FilePath -> m ()
+    rmConfFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     rmConfFile confFilePath = do
       $logInfo "removing Ghcup Config File"
-      liftIO $ deleteFile confFilePath
+      deleteFile confFilePath
 
-    rmDir :: (MonadLogger m, MonadIO m, MonadCatch m) => FilePath -> m ()
+    rmDir :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     rmDir dir =
       -- 'getDirectoryContentsRecursive' is lazy IO. In case
       -- an error leaks through, we catch it here as well,
@@ -1550,9 +1558,9 @@ rmGhcupDirs = do
       hideErrorDef [doesNotExistErrorType] () $ do
         $logInfo [i|removing #{dir}|]
         contents <- liftIO $ getDirectoryContentsRecursive dir
-        forM_ contents (liftIO . deleteFile . (dir </>))
+        forM_ contents (deleteFile . (dir </>))
 
-    rmBinDir :: (MonadCatch m, MonadIO m) => FilePath -> m ()
+    rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     rmBinDir binDir = do
 #if !defined(IS_WINDOWS)
       isXDGStyle <- liftIO useXDG
@@ -1581,9 +1589,9 @@ rmGhcupDirs = do
         compareFn :: FilePath -> FilePath -> Ordering
         compareFn fp1 fp2 = compare (calcDepth fp1) (calcDepth fp2)
 
-    removeEmptyDirsRecursive :: FilePath -> IO ()
+    removeEmptyDirsRecursive :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     removeEmptyDirsRecursive fp = do
-      cs <- listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
+      cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
       forM_ cs removeEmptyDirsRecursive
       hideError InappropriateType $ removeDirIfEmptyOrIsSymlink fp
         
@@ -1592,22 +1600,22 @@ rmGhcupDirs = do
     -- we report remaining files/dirs later,
     -- hence the force/quiet mode in these delete functions below.
 
-    deleteFile :: FilePath -> IO ()
+    deleteFile :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m) => FilePath -> m ()
     deleteFile filepath = do
       hideError doesNotExistErrorType
         $ hideError InappropriateType $ rmFile filepath
 
-    removeDirIfEmptyOrIsSymlink :: (MonadCatch m, MonadIO m) => FilePath -> m ()
+    removeDirIfEmptyOrIsSymlink :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
     removeDirIfEmptyOrIsSymlink filepath =
       hideError UnsatisfiedConstraints $
       handleIO' InappropriateType
             (handleIfSym filepath)
-            (liftIO $ removeDirectory filepath)
+            (liftIO $ rmDirectory filepath)
       where
         handleIfSym fp e = do
           isSym <- liftIO $ pathIsSymbolicLink fp
           if isSym
-          then liftIO $ deleteFile fp
+          then deleteFile fp
           else liftIO $ ioError e
 
 
@@ -1665,10 +1673,12 @@ compileGHC :: ( MonadMask m
            => Either GHCTargetVersion GitBranch          -- ^ version to install
            -> Maybe Version            -- ^ overwrite version
            -> Either Version FilePath  -- ^ version to bootstrap with
-           -> Maybe Int                  -- ^ jobs
+           -> Maybe Int                -- ^ jobs
            -> Maybe FilePath           -- ^ build config
            -> Maybe FilePath           -- ^ patch directory
-           -> [Text]                     -- ^ additional args to ./configure
+           -> [Text]                   -- ^ additional args to ./configure
+           -> Maybe String             -- ^ build flavour
+           -> Bool
            -> Excepts
                 '[ AlreadyInstalled
                  , BuildFailed
@@ -1687,7 +1697,7 @@ compileGHC :: ( MonadMask m
                  ]
                 m
                 GHCTargetVersion
-compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
+compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour hadrian
   = do
     PlatformRequest { .. } <- lift getPlatformReq
     GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -1772,8 +1782,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs
       tmpUnpack
       Nothing
       (do
-        b <- compileBindist bghc tver workdir ghcdir
-        bmk <- liftIO $ B.readFile (build_mk workdir)
+        b <- if hadrian
+             then compileHadrianBindist bghc tver workdir ghcdir
+             else compileMakeBindist bghc tver workdir ghcdir
+        bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk workdir)
         pure (b, bmk)
       )
 
@@ -1804,40 +1816,238 @@ BUILD_MAN = NO
 BUILD_SPHINX_HTML = NO
 BUILD_SPHINX_PDF = NO
 HADDOCK_DOCS = NO
+ifneq "$(BuildFlavour)" ""
+include mk/flavours/$(BuildFlavour).mk
+endif
 Stage1Only = YES|]
     _ -> [s|
 V=0
 BUILD_MAN = NO
 BUILD_SPHINX_HTML = NO
 BUILD_SPHINX_PDF = NO
-HADDOCK_DOCS = YES|]
+HADDOCK_DOCS = YES
+ifneq "$(BuildFlavour)" ""
+include mk/flavours/$(BuildFlavour).mk
+endif|]
 
-  compileBindist :: ( MonadReader env m
-                    , HasDirs env
-                    , HasSettings env
-                    , HasPlatformReq env
-                    , MonadThrow m
-                    , MonadCatch m
-                    , MonadLogger m
-                    , MonadIO m
-                    , MonadFail m
-                    )
-                 => Either FilePath FilePath
-                 -> GHCTargetVersion
-                 -> FilePath
-                 -> FilePath
-                 -> Excepts
-                      '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
-                      m
-                      (Maybe FilePath)  -- ^ output path of bindist, None for cross
-  compileBindist bghc tver workdir ghcdir = do
-    lift $ $(logInfo) [i|configuring build|]
-    liftE checkBuildConfig
-    
+  compileHadrianBindist :: ( MonadReader env m
+                           , HasDirs env
+                           , HasSettings env
+                           , HasPlatformReq env
+                           , MonadThrow m
+                           , MonadCatch m
+                           , MonadLogger m
+                           , MonadIO m
+                           , MonadFail m
+                           )
+                        => Either FilePath FilePath
+                        -> GHCTargetVersion
+                        -> FilePath
+                        -> FilePath
+                        -> Excepts
+                             '[ FileDoesNotExistError
+                              , HadrianNotFound
+                              , InvalidBuildConfig
+                              , PatchFailed
+                              , ProcessError
+                              , NotFoundInPATH
+                              , CopyError]
+                             m
+                             (Maybe FilePath)  -- ^ output path of bindist, None for cross
+  compileHadrianBindist bghc tver workdir ghcdir = do
+    lEM $ execLogged "python3" ["./boot"] (Just workdir) "ghc-bootstrap" Nothing
+
+    liftE $ configureBindist bghc tver workdir ghcdir
+
+    lift $ $(logInfo) [i|Building (this may take a while)...|]
+    hadrian_build <- liftE $ findHadrianFile workdir
+    lEM $ execLogged hadrian_build
+                          ( maybe [] (\j  -> [[i|-j#{j}|]]         ) jobs
+                         ++ maybe [] (\bf -> [[i|--flavour=#{bf}|]]) buildFlavour
+                         ++ ["binary-dist"]
+                          )
+                          (Just workdir) "ghc-make" Nothing
+    [tar] <- liftIO $ findFiles
+      (workdir </> "_build" </> "bindist")
+      (makeRegexOpts compExtended
+                     execBlank
+                     ([s|^ghc-.*\.tar\..*$|] :: ByteString)
+      )
+    liftE $ fmap Just $ copyBindist tver tar (workdir </> "_build" </> "bindist")
+
+  findHadrianFile :: (MonadIO m)
+                  => FilePath
+                  -> Excepts
+                       '[HadrianNotFound]
+                       m
+                       FilePath
+  findHadrianFile workdir = do
+#if defined(IS_WINDOWS)
+    let possible_files = ((workdir </> "hadrian") </>) <$> ["build.bat"]
+#else   
+    let possible_files = ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
+#endif
+    exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))
+    case filter fst exsists of
+      [] -> throwE HadrianNotFound
+      ((_, x):_) -> pure x
+
+  compileMakeBindist :: ( MonadReader env m
+                        , HasDirs env
+                        , HasSettings env
+                        , HasPlatformReq env
+                        , MonadThrow m
+                        , MonadCatch m
+                        , MonadLogger m
+                        , MonadIO m
+                        , MonadFail m
+                        )
+                     => Either FilePath FilePath
+                     -> GHCTargetVersion
+                     -> FilePath
+                     -> FilePath
+                     -> Excepts
+                          '[ FileDoesNotExistError
+                           , HadrianNotFound
+                           , InvalidBuildConfig
+                           , PatchFailed
+                           , ProcessError
+                           , NotFoundInPATH
+                           , CopyError]
+                          m
+                       (Maybe FilePath)  -- ^ output path of bindist, None for cross
+  compileMakeBindist bghc tver workdir ghcdir = do
+    liftE $ configureBindist bghc tver workdir ghcdir
+
+    case mbuildConfig of
+      Just bc -> liftIOException
+        doesNotExistErrorType
+        (FileDoesNotExistError bc)
+        (liftIO $ copyFile bc (build_mk workdir))
+      Nothing ->
+        liftIO $ B.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf)
+
+    liftE $ checkBuildConfig (build_mk workdir)
+
+    lift $ $(logInfo) [i|Building (this may take a while)...|]
+    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
+
+    if | isCross tver -> do
+          lift $ $(logInfo) [i|Installing cross toolchain...|]
+          lEM $ make ["install"] (Just workdir)
+          pure Nothing
+       | otherwise -> do
+          lift $ $(logInfo) [i|Creating bindist...|]
+          lEM $ make ["binary-dist"] (Just workdir)
+          [tar] <- liftIO $ findFiles
+            workdir
+            (makeRegexOpts compExtended
+                           execBlank
+                           ([s|^ghc-.*\.tar\..*$|] :: ByteString)
+            )
+          liftE $ fmap Just $ copyBindist tver tar workdir
+
+  build_mk workdir = workdir </> "mk" </> "build.mk"
+
+  copyBindist :: ( MonadReader env m
+                 , HasDirs env
+                 , HasSettings env
+                 , HasPlatformReq env
+                 , MonadIO m
+                 , MonadThrow m
+                 , MonadCatch m
+                 , MonadLogger m
+                 )
+              => GHCTargetVersion
+              -> FilePath           -- ^ tar file
+              -> FilePath           -- ^ workdir
+              -> Excepts
+                   '[CopyError]
+                   m
+                   FilePath
+  copyBindist tver tar workdir = do
     Dirs {..} <- lift getDirs
     pfreq <- lift getPlatformReq
+    c       <- liftIO $ BL.readFile (workdir </> tar)
+    cDigest <-
+      fmap (T.take 8)
+      . lift
+      . throwEither
+      . E.decodeUtf8'
+      . B16.encode
+      . SHA256.hashlazy
+      $ c
+    cTime <- liftIO getCurrentTime
+    let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
+    let tarPath = cacheDir </> tarName
+    handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
+                                                             tarPath
+    lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
+    pure tarPath
 
-    forM_ patchdir $ \dir -> liftE $ applyPatches dir workdir
+  checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m)
+                   => FilePath
+                   -> Excepts
+                        '[FileDoesNotExistError, InvalidBuildConfig]
+                        m
+                        ()
+  checkBuildConfig bc = do
+    c <- liftIOException
+           doesNotExistErrorType
+           (FileDoesNotExistError bc)
+           (liftIO $ B.readFile bc)
+    let lines' = fmap T.strip . T.lines $ decUTF8Safe c
+
+   -- for cross, we need Stage1Only
+    case targetGhc of
+      Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
+        (InvalidBuildConfig
+          [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
+        )
+      _ -> pure ()
+
+    forM_ buildFlavour $ \bf ->
+      when ([i|BuildFlavour = #{bf}|] `notElem` lines') $ do
+        lift $ $(logWarn) [i|Customly specified build config overwrites --flavour=#{bf} switch! Waiting 5 seconds...|]
+        liftIO $ threadDelay 5000000
+
+  addBuildFlavourToConf bc = case buildFlavour of
+    Just bf -> [i|BuildFlavour = #{bf}|] <> [s|
+|] <> [i|#{bc}|]
+    Nothing -> bc
+
+  isCross :: GHCTargetVersion -> Bool
+  isCross = isJust . _tvTarget
+
+
+  configureBindist :: ( MonadReader env m
+                      , HasDirs env
+                      , HasSettings env
+                      , HasPlatformReq env
+                      , MonadThrow m
+                      , MonadCatch m
+                      , MonadLogger m
+                      , MonadIO m
+                      , MonadFail m
+                      )
+                   => Either FilePath FilePath
+                   -> GHCTargetVersion
+                   -> FilePath
+                   -> FilePath
+                   -> Excepts
+                        '[ FileDoesNotExistError
+                         , InvalidBuildConfig
+                         , PatchFailed
+                         , ProcessError
+                         , NotFoundInPATH
+                         , CopyError
+                         ]
+                        m
+                        ()
+  configureBindist bghc tver workdir ghcdir = do
+    lift $ $(logInfo) [s|configuring build|]
+    
+    forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
 
     cEnv <- liftIO getEnvironment
 
@@ -1878,75 +2088,9 @@ HADDOCK_DOCS = YES|]
           (Just workdir)
           "ghc-conf"
           (Just cEnv)
+    pure ()
 
-    case mbuildConfig of
-      Just bc -> liftIOException
-        doesNotExistErrorType
-        (FileDoesNotExistError bc)
-        (liftIO $ copyFile bc (build_mk workdir))
-      Nothing ->
-        liftIO $ B.writeFile (build_mk workdir) defaultConf
 
-    lift $ $(logInfo) [i|Building (this may take a while)...|]
-    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
-
-    if | isCross tver -> do
-          lift $ $(logInfo) [i|Installing cross toolchain...|]
-          lEM $ make ["install"] (Just workdir)
-          pure Nothing
-       | otherwise -> do
-          lift $ $(logInfo) [i|Creating bindist...|]
-          lEM $ make ["binary-dist"] (Just workdir)
-          [tar] <- liftIO $ findFiles
-            workdir
-            (makeRegexOpts compExtended
-                           execBlank
-                           ([s|^ghc-.*\.tar\..*$|] :: ByteString)
-            )
-          c       <- liftIO $ BL.readFile (workdir </> tar)
-          cDigest <-
-            fmap (T.take 8)
-            . lift
-            . throwEither
-            . E.decodeUtf8'
-            . B16.encode
-            . SHA256.hashlazy
-            $ c
-          cTime <- liftIO getCurrentTime
-          let tarName = makeValid [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
-          let tarPath = cacheDir </> tarName
-          handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
-                                                                   tarPath
-          lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
-          pure $ Just tarPath
-
-  build_mk workdir = workdir </> "mk" </> "build.mk"
-
-  checkBuildConfig :: (MonadCatch m, MonadIO m)
-                   => Excepts
-                        '[FileDoesNotExistError, InvalidBuildConfig]
-                        m
-                        ()
-  checkBuildConfig = do
-    c <- case mbuildConfig of
-      Just bc -> do
-        liftIOException
-          doesNotExistErrorType
-          (FileDoesNotExistError bc)
-          (liftIO $ B.readFile bc)
-      Nothing -> pure defaultConf
-    let lines' = fmap T.strip . T.lines $ decUTF8Safe c
-
-   -- for cross, we need Stage1Only
-    case targetGhc of
-      Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE
-        (InvalidBuildConfig
-          [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|]
-        )
-      _ -> pure ()
-
-  isCross :: GHCTargetVersion -> Bool
-  isCross = isJust . _tvTarget
 
 
 
@@ -1995,27 +2139,14 @@ upgradeGHCup mtarget force' = do
   let fn = "ghcup" <> exeExt
   p <- liftE $ download dli tmp (Just fn)
   let destDir = takeDirectory destFile
-      destFile = fromMaybe (binDir </> fn <> exeExt) mtarget
+      destFile = fromMaybe (binDir </> fn) mtarget
   lift $ $(logDebug) [i|mkdir -p #{destDir}|]
   liftIO $ createDirRecursive' destDir
-#if defined(IS_WINDOWS)
-  let tempGhcup = cacheDir </> "ghcup.old"
-  liftIO $ hideError NoSuchThing $ rmFile tempGhcup
-
-  lift $ $(logDebug) [i|mv #{destFile} #{tempGhcup}|]
-  -- NoSuchThing may be raised when we're updating ghcup from
-  -- a non-standard location
-  liftIO $ hideError NoSuchThing $ Win32.moveFileEx destFile (Just tempGhcup) 0
-  lift $ $(logDebug) [i|cp #{p} #{destFile}|]
-  handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
-                                                           destFile
-#else
   lift $ $(logDebug) [i|rm -f #{destFile}|]
-  liftIO $ hideError NoSuchThing $ rmFile destFile
+  lift $ hideError NoSuchThing $ recycleFile destFile
   lift $ $(logDebug) [i|cp #{p} #{destFile}|]
   handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
                                                            destFile
-#endif
   lift $ chmod_755 destFile
 
   liftIO (isInPath destFile) >>= \b -> unless b $

lib/GHCup/Download.hs

@@ -115,6 +115,7 @@ getDownloadsF :: ( FromJSONKey Tool
                  , MonadLogger m
                  , MonadThrow m
                  , MonadFail m
+                 , MonadMask m
                  )
               => Excepts
                    '[JSONError , DownloadFailed , FileDoesNotExistError]
@@ -170,6 +171,7 @@ getBase :: ( MonadReader env m
            , MonadIO m
            , MonadCatch m
            , MonadLogger m
+           , MonadMask m
            )
         => URI
         -> Excepts '[JSONError , FileDoesNotExistError] m GHCupInfo
@@ -208,6 +210,7 @@ getBase uri = do
              , MonadIO m1
              , MonadFail m1
              , MonadLogger m1
+             , MonadMask m1
              )
           => URI
           -> Excepts
@@ -262,7 +265,7 @@ getBase uri = do
       pure bs
     dlWithoutMod json_file = do
       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
@@ -385,10 +388,10 @@ download 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

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.HughesPJClass
+import           Text.PrettyPrint               hiding ( (<>) )
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           URI.ByteString
 
 
@@ -240,6 +240,13 @@ instance Pretty NoNetwork where
   pPrint NoNetwork =
     text [i|A download was required or requested, but '--offline' was specified.|]
 
+data HadrianNotFound = HadrianNotFound
+  deriving Show
+
+instance Pretty HadrianNotFound where
+  pPrint HadrianNotFound =
+    text [i|Could not find Hadrian build files. Does this GHC version support Hadrian builds?|]
+
 
     -------------------------
     --[ High-level errors ]--
@@ -256,11 +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

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

lib/GHCup/Types/Optics.hs

@@ -1,9 +1,11 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE ConstraintKinds       #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE AllowAmbiguousTypes   #-}
+{-# LANGUAGE MultiParamTypeClasses   #-}
 
 {-|
 Module      : GHCup.Types.Optics
@@ -143,3 +145,6 @@ getCache = getSettings <&> cache
 getDownloader :: (MonadReader env m, HasSettings env) => m Downloader
 getDownloader = getSettings <&> downloader
 
+
+instance LabelOptic "dirs" A_Lens Dirs Dirs Dirs Dirs where
+  labelOptic = lens id (\_ d -> d)

lib/GHCup/Utils.hs

@@ -53,6 +53,7 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
+import           Control.Monad.IO.Unlift        ( MonadUnliftIO( withRunInIO ) )
 #if defined(IS_WINDOWS)
 import           Data.Bits
 #endif
@@ -78,6 +79,7 @@ import           System.Win32.Console
 import           System.Win32.File     hiding ( copyFile )
 import           System.Win32.Types
 #endif
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
 import           Text.Regex.Posix
 import           URI.ByteString
 
@@ -122,6 +124,7 @@ rmMinorSymlinks :: ( MonadReader env m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
+                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
@@ -133,7 +136,7 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
     let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
     let fullF = binDir </> f_xyz
     lift $ $(logDebug) [i|rm -f #{fullF}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+    lift $ hideError doesNotExistErrorType $ rmLink fullF
 
 
 -- | Removes the set ghc version for the given target, if any.
@@ -143,6 +146,7 @@ rmPlain :: ( MonadReader env m
            , MonadThrow m
            , MonadFail m
            , MonadIO m
+           , MonadMask m
            )
         => Maybe Text -- ^ target
         -> Excepts '[NotInstalled] m ()
@@ -154,11 +158,11 @@ rmPlain target = do
     forM_ files $ \f -> do
       let fullF = binDir </> f <> exeExt
       lift $ $(logDebug) [i|rm -f #{fullF}|]
-      liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+      lift $ hideError doesNotExistErrorType $ rmLink fullF
     -- old ghcup
     let hdc_file = binDir </> "haddock-ghc" <> exeExt
     lift $ $(logDebug) [i|rm -f #{hdc_file}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink hdc_file
+    lift $ hideError doesNotExistErrorType $ rmLink hdc_file
 
 
 -- | Remove the major GHC symlink, e.g. ghc-8.6.
@@ -168,6 +172,7 @@ rmMajorSymlinks :: ( MonadReader env m
                    , MonadLogger m
                    , MonadThrow m
                    , MonadFail m
+                   , MonadMask m
                    )
                 => GHCTargetVersion
                 -> Excepts '[NotInstalled] m ()
@@ -181,7 +186,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
     let f_xy = f <> "-" <> T.unpack v' <> exeExt
     let fullF = binDir </> f_xy
     lift $ $(logDebug) [i|rm -f #{fullF}|]
-    liftIO $ hideError doesNotExistErrorType $ rmLink fullF
+    lift $ hideError doesNotExistErrorType $ rmLink fullF
 
 
 
@@ -882,8 +887,17 @@ getChangeLog dls tool (Right tag) =
 --
 --   1. the build directory, depending on the KeepDirs setting
 --   2. the install destination, depending on whether the build failed
-runBuildAction :: (Show (V e), MonadReader env m, HasDirs env, HasSettings env, MonadIO m, MonadMask m)
-               => FilePath          -- ^ build directory (cleaned up depending on Settings)
+runBuildAction :: ( Pretty (V e)
+                  , Show (V e)
+                  , MonadReader env m
+                  , HasDirs env
+                  , HasSettings env
+                  , MonadIO m
+                  , MonadMask m
+                  , MonadLogger m
+                  , MonadUnliftIO m
+                  )
+               => FilePath        -- ^ build directory (cleaned up depending on Settings)
                -> Maybe FilePath  -- ^ dir to *always* clean up on exception
                -> Excepts e m a
                -> Excepts '[BuildFailed] m a
@@ -891,11 +905,9 @@ runBuildAction bdir instdir action = do
   Settings {..} <- lift getSettings
   let exAction = do
         forM_ instdir $ \dir ->
-          liftIO $ hideError doesNotExistErrorType $ rmPath dir
+          lift $ hideError doesNotExistErrorType $ recyclePathForcibly dir
         when (keepDirs == Never)
-          $ liftIO
-          $ hideError doesNotExistErrorType
-          $ rmPath bdir
+          $ lift $ rmBDir bdir
   v <-
     flip onException exAction
     $ catchAllE
@@ -904,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
@@ -994,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 . liftIO . rmFile $ (dropExtension fp <.> "shim")
+  hideError doesNotExistErrorType . recycleFile $ fp
+  hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
 #else
-rmLink = hideError doesNotExistErrorType . liftIO . rmFile
+rmLink = hideError doesNotExistErrorType . recycleFile
 #endif
 
 
@@ -1038,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
@@ -1067,7 +1089,6 @@ ensureGlobalTools :: ( MonadMask m
 ensureGlobalTools = do
 #if defined(IS_WINDOWS)
   (GHCupInfo _ _ gTools) <- lift getGHCupInfo
-  settings <- lift getSettings
   dirs <- lift getDirs
   shimDownload <- liftE $ lE @_ @'[NoDownload]
     $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
@@ -1075,7 +1096,7 @@ ensureGlobalTools = do
   void $ (\(DigestError _ _) -> do
       lift $ $(logWarn) [i|Digest doesn't match, redownloading gs.exe...|]
       lift $ $(logDebug) [i|rm -f #{shimDownload}|]
-      liftIO $ hideError doesNotExistErrorType $ rmFile (cacheDir dirs </> "gs.exe")
+      lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
       liftE @'[DigestError , DownloadFailed] $ dl
     ) `catchE` (liftE @'[DigestError , DownloadFailed] dl)
   pure ()
@@ -1086,14 +1107,14 @@ ensureGlobalTools = do
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir) = do
   createDirRecursive' baseDir
   createDirRecursive' (baseDir </> "ghc")
   createDirRecursive' binDir
   createDirRecursive' cacheDir
   createDirRecursive' logsDir
   createDirRecursive' confDir
-  createDirRecursive' tmpDir
+  createDirRecursive' trashDir
   pure ()
 
 
@@ -1107,4 +1128,3 @@ ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir tmpDir) = do
 ghcBinaryName :: GHCTargetVersion -> String
 ghcBinaryName (GHCTargetVersion (Just t) v') = T.unpack (t <> "-ghc-" <> prettyVer v' <> T.pack exeExt)
 ghcBinaryName (GHCTargetVersion Nothing  v') = T.unpack ("ghc-" <> prettyVer v' <> T.pack exeExt)
-

lib/GHCup/Utils/Dirs.hs

@@ -30,6 +30,7 @@ module GHCup.Utils.Dirs
 #if !defined(IS_WINDOWS)
   , useXDG
 #endif
+  , cleanupTrash
   )
 where
 
@@ -53,9 +54,7 @@ import           Data.String.Interpolate
 import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
 import           Haskus.Utils.Variant.Excepts
 import           Optics
-#if !defined(IS_WINDOWS)
 import           System.Directory                                                
-#endif
 import           System.DiskSpace                                                
 import           System.Environment
 import           System.FilePath
@@ -191,23 +190,21 @@ ghcupLogsDir = do
 #endif
 
 
--- | Defaults to '~/.ghcup/tmp.
---
--- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
--- then uses 'XDG_DATA_HOME/ghcup/tmp' as per xdg spec.
-ghcupTmpDir :: IO FilePath
-ghcupTmpDir = ghcupBaseDir <&> (</> "tmp")
+-- | '~/.ghcup/trash'.
+-- Mainly used on windows to improve file removal operations
+ghcupRecycleDir :: IO FilePath
+ghcupRecycleDir = ghcupBaseDir <&> (</> "trash")
 
 
 
 getAllDirs :: IO Dirs
 getAllDirs = do
-  baseDir  <- ghcupBaseDir
-  binDir   <- ghcupBinDir
-  cacheDir <- ghcupCacheDir
-  logsDir  <- ghcupLogsDir
-  confDir  <- ghcupConfigDir
-  tmpDir   <- ghcupTmpDir
+  baseDir    <- ghcupBaseDir
+  binDir     <- ghcupBinDir
+  cacheDir   <- ghcupCacheDir
+  logsDir    <- ghcupLogsDir
+  confDir    <- ghcupConfigDir
+  recycleDir <- ghcupRecycleDir
   pure Dirs { .. }
 
 
@@ -262,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
 
@@ -283,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 = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) rmPath)
+withGHCupTmpDir :: ( MonadReader env m
+                   , 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))
 
 
 
@@ -312,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/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 logsDir = do
+initGHCupFileLogging :: ( MonadReader env m
+                        , HasDirs env
+                        , MonadIO m
+                        , MonadMask m
+                        ) => m FilePath
+initGHCupFileLogging = do
+  Dirs { logsDir } <- getDirs
   let logfile = logsDir </> "ghcup.log"
-  liftIO $ do
-    logFiles <- findFiles
-      logsDir
-      (makeRegexOpts compExtended
-                     execBlank
-                     ([s|^.*\.log$|] :: B.ByteString)
-      )
-    forM_ logFiles $ hideError doesNotExistErrorType . rmFile . (logsDir </>)
+  logFiles <- liftIO $ findFiles
+    logsDir
+    (makeRegexOpts compExtended
+                   execBlank
+                   ([s|^.*\.log$|] :: B.ByteString)
+    )
+  forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (logsDir </>)
 
-    writeFile logfile ""
-    pure logfile
+  liftIO $ writeFile 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 srcDir destDir = do
+copyDirectoryRecursive :: FilePath -> FilePath -> (FilePath -> FilePath -> IO ()) -> IO ()
+copyDirectoryRecursive srcDir destDir doCopy = do
   srcFiles <- getDirectoryContentsRecursive srcDir
-  copyFilesWith copyFile destDir [ (srcDir, f)
-                                   | f <- srcFiles ]
+  copyFilesWith destDir [ (srcDir, f)
+                          | f <- srcFiles ]
   where
     -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
     -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
-    copyFilesWith :: (FilePath -> FilePath -> IO ())
-                  -> FilePath -> [(FilePath, FilePath)] -> IO ()
-    copyFilesWith doCopy targetDir srcFiles = do
+    copyFilesWith :: FilePath -> [(FilePath, FilePath)] -> IO ()
+    copyFilesWith 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)
-      => FilePath
-      -> m ()
-rmPath fp =
+recyclePathForcibly :: ( MonadIO m
+                       , MonadReader env m
+                       , HasDirs env
+                       , MonadMask m
+                       )
+                    => FilePath
+                    -> m ()
+recyclePathForcibly fp = do
+#if defined(IS_WINDOWS)
+  Dirs { recycleDir } <- getDirs
+  tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
+  let dest = tmp </> takeFileName fp
+  liftIO (Win32.moveFileEx fp (Just dest) 0)
+      `catch`
+      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+      `finally`
+        (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+#else
+  liftIO $ removePathForcibly fp
+#endif
+
+
+rmPathForcibly :: ( MonadIO m
+                  , MonadMask m
+                  )
+               => FilePath
+               -> m ()
+rmPathForcibly fp =
+#if defined(IS_WINDOWS)
+  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)