Merge branch 'reduce-win-cpp'

2021-10-17 21:16:59 +02:00 · 2021-10-17 21:16:59 +02:00 · 920b027a32
commit 920b027a32
parent 9d8fdfe090 9f8c9c228d
10 changed files with 380 additions and 363 deletions
--- a/app/ghcup/GHCup/OptParse/List.hs
+++ b/app/ghcup/GHCup/OptParse/List.hs
@ -11,6 +11,7 @@ module GHCup.OptParse.List where


 import           GHCup
+import           GHCup.Utils.Prelude
 import           GHCup.Types
 import           GHCup.OptParse.Common

@ -115,15 +116,9 @@ printListResult no_color raw lr = do
        . fmap
            (\ListResult {..} ->
              let marks = if
-#if defined(IS_WINDOWS)
-                    | lSet       -> (color Green "IS")
-                    | lInstalled -> (color Green "I ")
-                    | otherwise  -> (color Red "X ")
-#else
-                    | lSet       -> (color Green "✔✔")
-                    | lInstalled -> (color Green "✓ ")
-                    | otherwise  -> (color Red "✗ ")
-#endif
+                    | lSet       -> (color Green (if isWindows then "IS" else "✔✔"))
+                    | lInstalled -> (color Green (if isWindows then "I " else "✓ "))
+                    | otherwise  -> (color Red   (if isWindows then "X " else "✗ "))
              in
                (if raw then [] else [marks])
                  ++ [ fmap toLower . show $ lTool
--- a/ghcup.cabal
+++ b/ghcup.cabal
@ -16,11 +16,11 @@ description:
 category:           System
 build-type:         Simple
 extra-doc-files:
+  CHANGELOG.md
  data/config.yaml
  data/metadata/ghcup-0.0.4.yaml
  data/metadata/ghcup-0.0.5.yaml
  data/metadata/ghcup-0.0.6.yaml
-  CHANGELOG.md
  README.md

 extra-source-files:
@ -120,6 +120,7 @@ library
    , pretty-terminal       ^>=0.1.0.0
    , regex-posix           ^>=0.96
    , resourcet             ^>=1.2.2
+    , retry                 ^>=0.8.1.2
    , safe                  ^>=0.3.18
    , safe-exceptions       ^>=0.1
    , split                 ^>=0.2.3.4
@ -148,16 +149,21 @@ library

  if os(windows)
    cpp-options:   -DIS_WINDOWS
-    other-modules: GHCup.Utils.File.Windows
+    other-modules:
+      GHCup.Utils.File.Windows
+      GHCup.Utils.Prelude.Windows
+      GHCup.Utils.Windows
+
    build-depends:
      , bzlib
      , process  ^>=1.6.11.0
-      , retry    ^>=0.8.1.2
      , Win32    ^>=2.10

  else
    other-modules:
      GHCup.Utils.File.Posix
+      GHCup.Utils.Posix
+      GHCup.Utils.Prelude.Posix
      System.Console.Terminal.Common
      System.Console.Terminal.Posix

@ -172,23 +178,25 @@ library

 executable ghcup
  main-is:            Main.hs
-  other-modules:      GHCup.OptParse.Install
-                      GHCup.OptParse.Common
-                      GHCup.OptParse.Set
-                      GHCup.OptParse.UnSet
-                      GHCup.OptParse.Rm
-                      GHCup.OptParse.Compile
-                      GHCup.OptParse.Config
-                      GHCup.OptParse.Whereis
-                      GHCup.OptParse.List
-                      GHCup.OptParse.DInfo
-                      GHCup.OptParse.Upgrade
-                      GHCup.OptParse.ToolRequirements
-                      GHCup.OptParse.ChangeLog
-                      GHCup.OptParse.Nuke
-                      GHCup.OptParse.Prefetch
-                      GHCup.OptParse.GC
-                      GHCup.OptParse
+  other-modules:
+    GHCup.OptParse
+    GHCup.OptParse.ChangeLog
+    GHCup.OptParse.Common
+    GHCup.OptParse.Compile
+    GHCup.OptParse.Config
+    GHCup.OptParse.DInfo
+    GHCup.OptParse.GC
+    GHCup.OptParse.Install
+    GHCup.OptParse.List
+    GHCup.OptParse.Nuke
+    GHCup.OptParse.Prefetch
+    GHCup.OptParse.Rm
+    GHCup.OptParse.Set
+    GHCup.OptParse.ToolRequirements
+    GHCup.OptParse.UnSet
+    GHCup.OptParse.Upgrade
+    GHCup.OptParse.Whereis
+
  hs-source-dirs:     app/ghcup
  default-language:   Haskell2010
  default-extensions:
--- a/lib/GHCup.hs
+++ b/lib/GHCup.hs
@ -52,9 +52,7 @@ import           Control.Monad.Fail             ( MonadFail )
 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
@ -96,9 +94,6 @@ import qualified Data.Map.Strict               as Map
 import qualified Data.Text                     as T
 import qualified Data.Text.IO                  as T
 import qualified Data.Text.Encoding            as E
-#if defined(IS_WINDOWS)
-import qualified System.Win32.File             as Win32
-#endif
 import qualified Text.Megaparsec               as MP
 import GHCup.Utils.MegaParsec
 import Control.Concurrent (threadDelay)
@ -339,36 +334,35 @@ installUnpackedGHC :: ( MonadReader env m
                   -> 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
+installUnpackedGHC path inst ver
+  | isWindows = do
+      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
+        moveFilePortable source dest
+        setModificationTime dest mtime
+  | otherwise = do
+      PlatformRequest {..} <- lift getPlatformReq

-  let alpineArgs
-       | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
-       = ["--disable-ld-override"]
-       | otherwise
-       = []
+      let alpineArgs
+           | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
+           = ["--disable-ld-override"]
+           | otherwise
+           = []

-  lift $ logInfo "Installing GHC (this may take a while)"
-  lEM $ execLogged "sh"
-                   ("./configure" : ("--prefix=" <> inst) 
-                    : alpineArgs
-                   )
-                   (Just path)
-                   "ghc-configure"
-                   Nothing
-  lEM $ make ["install"] (Just path)
-  pure ()
-#endif
+      lift $ logInfo "Installing GHC (this may take a while)"
+      lEM $ execLogged "sh"
+                       ("./configure" : ("--prefix=" <> inst) 
+                        : alpineArgs
+                       )
+                       (Just path)
+                       "ghc-configure"
+                       Nothing
+      lEM $ make ["install"] (Just path)
+      pure ()


 -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@ -1147,15 +1141,17 @@ setGHC ver sghc = do
          logDebug $ "rm -f " <> T.pack fullF
          hideError doesNotExistErrorType $ rmDirectoryLink fullF
          logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
-          liftIO
-#if defined(IS_WINDOWS)
-            -- On windows we need to be more permissive
-            -- in case symlinks can't be created, be just
-            -- give up here. This symlink isn't strictly necessary.
-            $ hideError permissionErrorType
-            $ hideError illegalOperationErrorType
-#endif
-            $ createDirectoryLink targetF fullF
+
+          if isWindows
+          then liftIO
+                 -- On windows we need to be more permissive
+                 -- in case symlinks can't be created, be just
+                 -- give up here. This symlink isn't strictly necessary.
+                 $ hideError permissionErrorType
+                 $ hideError illegalOperationErrorType
+                 $ createDirectoryLink targetF fullF
+          else liftIO
+                 $ createDirectoryLink targetF fullF
      _ -> pure ()

 unsetGHC :: ( MonadReader env m
@ -1876,17 +1872,17 @@ rmGhcup = do

  unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath

-#if defined(IS_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
-  tempFilepath <- mkGhcupTmpDir
-  hideError UnsupportedOperation $
-            liftIO $ hideError NoSuchThing $
-            Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
-#else
-  -- delete it.
-  hideError doesNotExistErrorType $ rmFile ghcupFilepath
-#endif
+  if isWindows
+  then do
+    -- 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
+    tempFilepath <- mkGhcupTmpDir
+    hideError UnsupportedOperation $
+              liftIO $ hideError NoSuchThing $
+              moveFile ghcupFilepath (tempFilepath </> "ghcup")
+  else
+    -- delete it.
+    hideError doesNotExistErrorType $ rmFile ghcupFilepath

  where
    handlePathNotPresent fp _err = do
@ -1946,10 +1942,9 @@ rmGhcupDirs = do

  handleRm $ rmBinDir binDir
  handleRm $ rmDir recycleDir
-#if defined(IS_WINDOWS)
-  logInfo $ "removing " <> T.pack (baseDir </> "msys64")
-  handleRm $ rmPathForcibly (baseDir </> "msys64")
-#endif
+  when isWindows $ do
+    logInfo $ "removing " <> T.pack (baseDir </> "msys64")
+    handleRm $ rmPathForcibly (baseDir </> "msys64")

  handleRm $ removeEmptyDirsRecursive baseDir

@ -1983,15 +1978,13 @@ rmGhcupDirs = do
        forM_ contents (deleteFile . (dir </>))

    rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
-    rmBinDir binDir = do
-#if !defined(IS_WINDOWS)
-      isXDGStyle <- liftIO useXDG
-      if not isXDGStyle
-        then removeDirIfEmptyOrIsSymlink binDir
-        else pure ()
-#else
-      removeDirIfEmptyOrIsSymlink binDir
-#endif
+    rmBinDir binDir
+      | isWindows = removeDirIfEmptyOrIsSymlink binDir
+      | otherwise = do
+          isXDGStyle <- liftIO useXDG
+          if not isXDGStyle
+            then removeDirIfEmptyOrIsSymlink binDir
+            else pure ()

    reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
    reportRemainingFiles dir = do
@ -2311,11 +2304,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                       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
+    let possible_files = if isWindows
+                         then ((workdir </> "hadrian") </>) <$> ["build.bat"]
+                         else ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
    exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))
    case filter fst exsists of
      [] -> throwE HadrianNotFound
@ -2489,9 +2480,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                      (\x -> ["--target=" <> T.unpack x])
                      (_tvTarget tver)
            ++ ["--prefix=" <> ghcdir]
-#if defined(IS_WINDOWS)
-            ++ ["--enable-tarballs-autodownload"]
-#endif
+            ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
            ++ fmap T.unpack aargs
            )
            (Just workdir)
@ -2505,9 +2494,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                   (\x -> ["--target=" <> T.unpack x])
                   (_tvTarget tver)
          ++ ["--prefix=" <> ghcdir]
-#if defined(IS_WINDOWS)
-          ++ ["--enable-tarballs-autodownload"]
-#endif
+          ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
          ++ fmap T.unpack aargs
          )
          (Just workdir)
--- a/lib/GHCup/Utils.hs
+++ b/lib/GHCup/Utils.hs
@ -22,13 +22,21 @@ installation and introspection of files/versions etc.
 module GHCup.Utils
  ( module GHCup.Utils.Dirs
  , module GHCup.Utils
+#if defined(IS_WINDOWS)
+  , module GHCup.Utils.Windows
+#else
+  , module GHCup.Utils.Posix
+#endif
  )
 where


 #if defined(IS_WINDOWS)
-import           GHCup.Download
+import GHCup.Utils.Windows
+#else
+import GHCup.Utils.Posix
 #endif
+import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
@ -51,9 +59,6 @@ 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
 import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.Foldable
@ -69,11 +74,6 @@ import           Safe
 import           System.Directory      hiding   ( findFiles )
 import           System.FilePath
 import           System.IO.Error
-#if defined(IS_WINDOWS)
-import           System.Win32.Console
-import           System.Win32.File     hiding ( copyFile )
-import           System.Win32.Types
-#endif
 import           Text.Regex.Posix
 import           URI.ByteString

@ -1000,50 +1000,17 @@ getVersionInfo v' tool =

 -- | The file extension for executables.
 exeExt :: String
-#if defined(IS_WINDOWS)
-exeExt = ".exe"
-#else
-exeExt = ""
-#endif
+exeExt
+  | isWindows = ".exe"
+  | otherwise = ""

 -- | The file extension for executables.
 exeExt' :: ByteString
-#if defined(IS_WINDOWS)
-exeExt' = ".exe"
-#else
-exeExt' = ""
-#endif
+exeExt'
+  | isWindows = ".exe"
+  | otherwise = ""


-- | Enables ANSI support on windows, does nothing on unix.
--
-- Returns 'Left str' on errors and 'Right bool' on success, where
-- 'bool' markes whether ansi support was already enabled.
--
-- This function never crashes.
--
-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
-enableAnsiSupport :: IO (Either String Bool)
-#if defined(IS_WINDOWS)
-enableAnsiSupport = handleIO (pure . Left . displayException) $ do
-  -- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
-  -- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
-  h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
-    fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
-  when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
-
-  -- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
-  m <- getConsoleMode h
-
-  -- VT processing not already enabled?
-  if ((m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING) == 0)
-  -- https://docs.microsoft.com/en-us/windows/console/setconsolemode
-  then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
-    >> pure (Right False)
-  else pure (Right True)
-#else
-enableAnsiSupport = pure (Right True)
-#endif


 -- | On unix, we can use symlinks, so we just get the
@ -1052,33 +1019,27 @@ enableAnsiSupport = pure (Right True)
 -- On windows, we have to emulate symlinks via shims,
 -- see 'createLink'.
 getLinkTarget :: FilePath -> IO FilePath
-getLinkTarget fp = do
-#if defined(IS_WINDOWS)
-  content <- readFile (dropExtension fp <.> "shim")
-  [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
-  pure $ stripNewline $ dropPrefix "path = " p
-#else
-  getSymbolicLinkTarget fp
-#endif
+getLinkTarget fp
+  | isWindows = do
+      content <- readFile (dropExtension fp <.> "shim")
+      [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
+      pure $ stripNewline $ dropPrefix "path = " p
+  | otherwise = getSymbolicLinkTarget fp


 -- | Checks whether the path is a link.
 pathIsLink :: FilePath -> IO Bool
-#if defined(IS_WINDOWS)
-pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
-#else
-pathIsLink = pathIsSymbolicLink
-#endif
+pathIsLink fp
+  | isWindows = doesPathExist (dropExtension fp <.> "shim")
+  | otherwise = pathIsSymbolicLink fp


 rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
-#if defined(IS_WINDOWS)
-rmLink fp = do
-  hideError doesNotExistErrorType . recycleFile $ fp
-  hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
-#else
-rmLink = hideError doesNotExistErrorType . recycleFile
-#endif
+rmLink fp
+  | isWindows = do
+      hideError doesNotExistErrorType . recycleFile $ fp
+      hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
+  | otherwise = hideError doesNotExistErrorType . recycleFile $ fp


 -- | Creates a symbolic link on unix and a fake symlink on windows for
@ -1102,31 +1063,30 @@ createLink :: ( MonadMask m
           => FilePath      -- ^ path to the target executable
           -> FilePath      -- ^ path to be created
           -> m ()
-createLink link exe = do
-#if defined(IS_WINDOWS)
-  dirs <- getDirs
-  let shimGen = cacheDir dirs </> "gs.exe"
+createLink link exe
+  | isWindows = do
+      dirs <- getDirs
+      let shimGen = cacheDir dirs </> "gs.exe"

-  let shim = dropExtension exe <.> "shim"
-      -- For hardlinks, link needs to be absolute.
-      -- If link is relative, it's relative to the target exe.
-      -- Note that (</>) drops lhs when rhs is absolute.
-      fullLink = takeDirectory exe </> link
-      shimContents = "path = " <> fullLink
+      let shim = dropExtension exe <.> "shim"
+          -- For hardlinks, link needs to be absolute.
+          -- If link is relative, it's relative to the target exe.
+          -- Note that (</>) drops lhs when rhs is absolute.
+          fullLink = takeDirectory exe </> link
+          shimContents = "path = " <> fullLink

-  logDebug $ "rm -f " <> T.pack exe
-  rmLink exe
+      logDebug $ "rm -f " <> T.pack exe
+      rmLink exe

-  logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
-  liftIO $ copyFile shimGen exe
-  liftIO $ writeFile shim shimContents
-#else
-  logDebug $ "rm -f " <> T.pack exe
-  hideError doesNotExistErrorType $ recycleFile exe
+      logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
+      liftIO $ copyFile shimGen exe
+      liftIO $ writeFile shim shimContents
+  | otherwise = do
+      logDebug $ "rm -f " <> T.pack exe
+      hideError doesNotExistErrorType $ recycleFile exe

-  logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
-  liftIO $ createFileLink link exe
-#endif
+      logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
+      liftIO $ createFileLink link exe


 ensureGlobalTools :: ( MonadMask m
@ -1141,23 +1101,20 @@ ensureGlobalTools :: ( MonadMask m
                     , MonadFail m
                     )
                  => Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
-ensureGlobalTools = do
-#if defined(IS_WINDOWS)
-  (GHCupInfo _ _ gTools) <- lift getGHCupInfo
-  dirs <- lift getDirs
-  shimDownload <- liftE $ lE @_ @'[NoDownload]
-    $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
-  let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
-  void $ (\(DigestError _ _ _) -> do
-      lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
-      lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
-      lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
-      liftE @'[GPGError, DigestError , DownloadFailed] $ dl
-    ) `catchE` (liftE @'[GPGError, DigestError , DownloadFailed] dl)
-  pure ()
-#else
-  pure ()
-#endif
+ensureGlobalTools
+  | isWindows = do
+      (GHCupInfo _ _ gTools) <- lift getGHCupInfo
+      dirs <- lift getDirs
+      shimDownload <- liftE $ lE @_ @'[NoDownload]
+        $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
+      let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
+      void $ (\DigestError{} -> do
+          lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
+          lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
+          lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
+          liftE @'[GPGError, DigestError , DownloadFailed] $ dl
+        ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
+  | otherwise = pure ()


 -- | Ensure ghcup directory structure exists.
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@ -25,9 +25,7 @@ module GHCup.Utils.Dirs
  , relativeSymlink
  , withGHCupTmpDir
  , getConfigFilePath
-#if !defined(IS_WINDOWS)
  , useXDG
-#endif
  , cleanupTrash
  )
 where
@ -75,26 +73,25 @@ import Control.Concurrent (threadDelay)
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
 ghcupBaseDir :: IO FilePath
-ghcupBaseDir = do
-#if defined(IS_WINDOWS)
-  bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
-  pure (bdir </> "ghcup")
-#else
-  xdg <- useXDG
-  if xdg
-    then do
-      bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
-        Just r  -> pure r
-        Nothing -> do
-          home <- liftIO getHomeDirectory
-          pure (home </> ".local" </> "share")
+ghcupBaseDir
+  | isWindows = do
+      bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
      pure (bdir </> "ghcup")
-    else do
-      bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-        Just r  -> pure r
-        Nothing -> liftIO getHomeDirectory
-      pure (bdir </> ".ghcup")
-#endif
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".local" </> "share")
+          pure (bdir </> "ghcup")
+        else do
+          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+            Just r  -> pure r
+            Nothing -> liftIO getHomeDirectory
+          pure (bdir </> ".ghcup")


 -- | ~/.ghcup by default
@ -102,45 +99,41 @@ ghcupBaseDir = do
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
 ghcupConfigDir :: IO FilePath
-ghcupConfigDir = do
-#if defined(IS_WINDOWS)
-  ghcupBaseDir
-#else
-  xdg <- useXDG
-  if xdg
-    then do
-      bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
-        Just r  -> pure r
-        Nothing -> do
-          home <- liftIO getHomeDirectory
-          pure (home </> ".config")
-      pure (bdir </> "ghcup")
-    else do
-      bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-        Just r  -> pure r
-        Nothing -> liftIO getHomeDirectory
-      pure (bdir </> ".ghcup")
-#endif
+ghcupConfigDir
+  | isWindows = ghcupBaseDir
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".config")
+          pure (bdir </> "ghcup")
+        else do
+          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+            Just r  -> pure r
+            Nothing -> liftIO getHomeDirectory
+          pure (bdir </> ".ghcup")


 -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
 -- (which, sadly is not strictly xdg spec).
 ghcupBinDir :: IO FilePath
-ghcupBinDir = do
-#if defined(IS_WINDOWS)
-  ghcupBaseDir <&> (</> "bin")
-#else
-  xdg <- useXDG
-  if xdg
-    then do
-      lookupEnv "XDG_BIN_HOME" >>= \case
-        Just r  -> pure r
-        Nothing -> do
-          home <- liftIO getHomeDirectory
-          pure (home </> ".local" </> "bin")
-    else ghcupBaseDir <&> (</> "bin")
-#endif
+ghcupBinDir
+  | isWindows = ghcupBaseDir <&> (</> "bin")
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          lookupEnv "XDG_BIN_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".local" </> "bin")
+        else ghcupBaseDir <&> (</> "bin")


 -- | Defaults to '~/.ghcup/cache'.
@ -148,21 +141,19 @@ ghcupBinDir = do
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
 ghcupCacheDir :: IO FilePath
-ghcupCacheDir = do
-#if defined(IS_WINDOWS)
-  ghcupBaseDir <&> (</> "cache")
-#else
-  xdg <- useXDG
-  if xdg
-    then do
-      bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
-        Just r  -> pure r
-        Nothing -> do
-          home <- liftIO getHomeDirectory
-          pure (home </> ".cache")
-      pure (bdir </> "ghcup")
-    else ghcupBaseDir <&> (</> "cache")
-#endif
+ghcupCacheDir
+  | isWindows = ghcupBaseDir <&> (</> "cache")
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".cache")
+          pure (bdir </> "ghcup")
+        else ghcupBaseDir <&> (</> "cache")


 -- | Defaults to '~/.ghcup/logs'.
@ -170,21 +161,19 @@ ghcupCacheDir = do
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
 ghcupLogsDir :: IO FilePath
-ghcupLogsDir = do
-#if defined(IS_WINDOWS)
-  ghcupBaseDir <&> (</> "logs")
-#else
-  xdg <- useXDG
-  if xdg
-    then do
-      bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
-        Just r  -> pure r
-        Nothing -> do
-          home <- liftIO getHomeDirectory
-          pure (home </> ".cache")
-      pure (bdir </> "ghcup" </> "logs")
-    else ghcupBaseDir <&> (</> "logs")
-#endif
+ghcupLogsDir
+  | isWindows = ghcupBaseDir <&> (</> "logs")
+  | otherwise = do
+      xdg <- useXDG
+      if xdg
+        then do
+          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+            Just r  -> pure r
+            Nothing -> do
+              home <- liftIO getHomeDirectory
+              pure (home </> ".cache")
+          pure (bdir </> "ghcup" </> "logs")
+        else ghcupBaseDir <&> (</> "logs")


 -- | '~/.ghcup/trash'.
@ -320,10 +309,8 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
    --------------


-#if !defined(IS_WINDOWS)
 useXDG :: IO Bool
 useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
-#endif


 relativeSymlink :: FilePath  -- ^ the path in which to create the symlink
--- a/lib/GHCup/Utils/Posix.hs
+++ b/lib/GHCup/Utils/Posix.hs
@ -0,0 +1,14 @@
+module GHCup.Utils.Posix where
+
+
+-- | Enables ANSI support on windows, does nothing on unix.
+--
+-- Returns 'Left str' on errors and 'Right bool' on success, where
+-- 'bool' markes whether ansi support was already enabled.
+--
+-- This function never crashes.
+--
+-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
+enableAnsiSupport :: IO (Either String Bool)
+enableAnsiSupport = pure (Right True)
+
--- a/lib/GHCup/Utils/Prelude.hs
+++ b/lib/GHCup/Utils/Prelude.hs
@ -17,14 +17,25 @@ Portability : portable

 GHCup specific prelude. Lots of Excepts functionality.
 -}
-module GHCup.Utils.Prelude where
-
+module GHCup.Utils.Prelude
+  (module GHCup.Utils.Prelude,
 #if defined(IS_WINDOWS)
-import           GHCup.Types
+   module GHCup.Utils.Prelude.Windows
+#else
+   module GHCup.Utils.Prelude.Posix
 #endif
+  )
+where
+
+import           GHCup.Types
 import           GHCup.Errors
 import           GHCup.Types.Optics
 import {-# SOURCE #-} GHCup.Utils.Logger
+#if defined(IS_WINDOWS)
+import           GHCup.Utils.Prelude.Windows
+#else
+import           GHCup.Utils.Prelude.Posix
+#endif

 import           Control.Applicative
 import           Control.Exception.Safe
@ -45,17 +56,13 @@ import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
 import           System.IO.Error
-#if defined(IS_WINDOWS)
 import           System.IO.Temp
-#endif
 import           System.IO.Unsafe
 import           System.Directory
 import           System.FilePath

-#if defined(IS_WINDOWS)
 import           Control.Retry
 import           GHC.IO.Exception
-#endif

 import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
@ -69,9 +76,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


 -- $setup
@ -438,19 +442,17 @@ recyclePathForcibly :: ( MonadIO 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
+recyclePathForcibly fp
+  | isWindows = do
+      Dirs { recycleDir } <- getDirs
+      tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
+      let dest = tmp </> takeFileName fp
+      liftIO (moveFile fp dest)
+          `catch`
+          (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+          `finally`
+            liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+  | otherwise = liftIO $ removePathForcibly fp


 rmPathForcibly :: ( MonadIO m
@ -458,23 +460,17 @@ rmPathForcibly :: ( MonadIO m
                  )
               => FilePath
               -> m ()
-rmPathForcibly fp =
-#if defined(IS_WINDOWS)
-  recover (liftIO $ removePathForcibly fp)
-#else
-  liftIO $ removePathForcibly fp
-#endif
+rmPathForcibly fp
+  | isWindows = recover (liftIO $ removePathForcibly fp)
+  | otherwise = liftIO $ removePathForcibly fp


 rmDirectory :: (MonadIO m, MonadMask m)
            => FilePath
            -> m ()
-rmDirectory fp =
-#if defined(IS_WINDOWS)
-  recover (liftIO $ removeDirectory fp)
-#else
-  liftIO $ removeDirectory fp
-#endif
+rmDirectory fp
+  | isWindows = recover (liftIO $ removeDirectory fp)
+  | otherwise = liftIO $ removeDirectory fp


 -- https://www.sqlite.org/src/info/89f1848d7f
@ -486,20 +482,18 @@ recycleFile :: ( MonadIO m
               )
            => 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
+recycleFile fp
+  | isWindows = do
+      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 (moveFile fp dest)
+        `catch`
+          (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+        `finally`
+          liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+  | otherwise = liftIO $ removeFile fp


 rmFile :: ( MonadIO m
@ -507,26 +501,19 @@ rmFile :: ( MonadIO m
          )
      => FilePath
      -> m ()
-rmFile fp =
-#if defined(IS_WINDOWS)
-  recover (liftIO $ removeFile fp)
-#else
-  liftIO $ removeFile fp
-#endif
+rmFile fp
+  | isWindows = recover (liftIO $ removeFile fp)
+  | otherwise = liftIO $ removeFile fp


 rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
                => FilePath
                -> m ()
-rmDirectoryLink fp = 
-#if defined(IS_WINDOWS)
-  recover (liftIO $ removeDirectoryLink fp)
-#else
-  liftIO $ removeDirectoryLink fp
-#endif
+rmDirectoryLink fp
+  | isWindows = recover (liftIO $ removeDirectoryLink fp)
+  | otherwise = liftIO $ removeDirectoryLink fp


-#if defined(IS_WINDOWS)
 recover :: (MonadIO m, MonadMask m) => m a -> m a
 recover action = 
  recovering (fullJitterBackoff 25000 <> limitRetries 10)
@ -535,7 +522,6 @@ recover action =
    ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
    ]
    (\_ -> action)
-#endif


 copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
@ -752,5 +738,3 @@ breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
 breakOn _ [] = ([], [])
 breakOn needle (x:xs) = first (x:) $ breakOn needle xs

-
-
--- a/lib/GHCup/Utils/Prelude/Posix.hs
+++ b/lib/GHCup/Utils/Prelude/Posix.hs
@ -0,0 +1,20 @@
+module GHCup.Utils.Prelude.Posix where
+
+import System.Directory
+import System.Posix.Files
+
+
+isWindows, isNotWindows :: Bool
+isWindows = False
+isNotWindows = not isWindows
+
+
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile = rename
+
+
+moveFilePortable :: FilePath -> FilePath -> IO ()
+moveFilePortable from to = do
+  copyFile from to
+  removeFile from
+  
--- a/lib/GHCup/Utils/Prelude/Windows.hs
+++ b/lib/GHCup/Utils/Prelude/Windows.hs
@ -0,0 +1,17 @@
+module GHCup.Utils.Prelude.Windows where
+
+import qualified System.Win32.File             as Win32
+
+
+isWindows, isNotWindows :: Bool
+isWindows = True
+isNotWindows = not isWindows
+
+
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile from to = Win32.moveFileEx from (Just to) 0
+
+
+moveFilePortable :: FilePath -> FilePath -> IO ()
+moveFilePortable = Win32.moveFile
+
--- a/lib/GHCup/Utils/Windows.hs
+++ b/lib/GHCup/Utils/Windows.hs
@ -0,0 +1,48 @@
+{-# LANGUAGE CPP                   #-}
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+
+module GHCup.Utils.Windows where
+
+
+import           Control.Exception.Safe
+import           Control.Monad
+#if !MIN_VERSION_base(4,13,0)
+import           Control.Monad.Fail             ( MonadFail )
+#endif
+import           Data.Bits
+
+import           System.Win32.Console
+import           System.Win32.File     hiding ( copyFile )
+import           System.Win32.Types
+
+
+
+
+-- | Enables ANSI support on windows, does nothing on unix.
+--
+-- Returns 'Left str' on errors and 'Right bool' on success, where
+-- 'bool' markes whether ansi support was already enabled.
+--
+-- This function never crashes.
+--
+-- Rip-off of https://docs.rs/ansi_term/0.12.1/x86_64-pc-windows-msvc/src/ansi_term/windows.rs.html#10-61
+enableAnsiSupport :: IO (Either String Bool)
+enableAnsiSupport = handleIO (pure . Left . displayException) $ do
+  -- ref: https://docs.microsoft.com/en-us/windows/win32/api/fileapi/nf-fileapi-createfilew
+  -- Using `CreateFileW("CONOUT$", ...)` to retrieve the console handle works correctly even if STDOUT and/or STDERR are redirected
+  h <- createFile "CONOUT$" (gENERIC_WRITE .|. gENERIC_READ)
+    fILE_SHARE_WRITE Nothing oPEN_EXISTING 0 Nothing
+  when (h == iNVALID_HANDLE_VALUE ) $ fail "invalid handle value"
+
+  -- ref: https://docs.microsoft.com/en-us/windows/console/getconsolemode
+  m <- getConsoleMode h
+
+  -- VT processing not already enabled?
+  if m .&. eNABLE_VIRTUAL_TERMINAL_PROCESSING == 0
+  -- https://docs.microsoft.com/en-us/windows/console/setconsolemode
+  then setConsoleMode h (m .|. eNABLE_VIRTUAL_TERMINAL_PROCESSING)
+    >> pure (Right False)
+  else pure (Right True)
+