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
+  other-modules:
+    GHCup.OptParse
+    GHCup.OptParse.ChangeLog
    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.GC
+    GHCup.OptParse.Install
+    GHCup.OptParse.List
    GHCup.OptParse.Nuke
    GHCup.OptParse.Prefetch
-                      GHCup.OptParse.GC
-                      GHCup.OptParse
+    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,17 +334,17 @@ 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)
+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
-    Win32.moveFile source dest
+        moveFilePortable source dest
        setModificationTime dest mtime
-#else
+  | otherwise = do
      PlatformRequest {..} <- lift getPlatformReq

      let alpineArgs
@ -368,7 +363,6 @@ installUnpackedGHC path inst ver = do
                       Nothing
      lEM $ make ["install"] (Just path)
      pure ()
-#endif


 -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@ -1147,14 +1141,16 @@ 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)
+
+          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
-#endif
+                 $ createDirectoryLink targetF fullF
+          else liftIO
                 $ createDirectoryLink targetF fullF
      _ -> pure ()

@ -1876,17 +1872,17 @@ rmGhcup = do

  unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath

-#if defined(IS_WINDOWS)
+  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 $
-            Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
-#else
+              moveFile ghcupFilepath (tempFilepath </> "ghcup")
+  else
    -- delete it.
    hideError doesNotExistErrorType $ rmFile ghcupFilepath
-#endif

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

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

  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)
+    rmBinDir binDir
+      | isWindows = removeDirIfEmptyOrIsSymlink binDir
+      | otherwise = do
          isXDGStyle <- liftIO useXDG
          if not isXDGStyle
            then removeDirIfEmptyOrIsSymlink binDir
            else pure ()
-#else
-      removeDirIfEmptyOrIsSymlink binDir
-#endif

    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)
+getLinkTarget fp
+  | isWindows = do
      content <- readFile (dropExtension fp <.> "shim")
      [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
      pure $ stripNewline $ dropPrefix "path = " p
-#else
-  getSymbolicLinkTarget fp
-#endif
+  | 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
+rmLink fp
+  | isWindows = do
      hideError doesNotExistErrorType . recycleFile $ fp
      hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
-#else
-rmLink = hideError doesNotExistErrorType . recycleFile
-#endif
+  | otherwise = hideError doesNotExistErrorType . recycleFile $ fp


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

@ -1120,13 +1081,12 @@ createLink link exe = do
      logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
      liftIO $ copyFile shimGen exe
      liftIO $ writeFile shim shimContents
-#else
+  | 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


 ensureGlobalTools :: ( MonadMask m
@ -1141,23 +1101,20 @@ ensureGlobalTools :: ( MonadMask m
                     , MonadFail m
                     )
                  => Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
-ensureGlobalTools = do
-#if defined(IS_WINDOWS)
+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
+      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
+        ) `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,11 +73,11 @@ 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)
+ghcupBaseDir
+  | isWindows = do
      bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
      pure (bdir </> "ghcup")
-#else
+  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
@ -94,7 +92,6 @@ ghcupBaseDir = do
            Just r  -> pure r
            Nothing -> liftIO getHomeDirectory
          pure (bdir </> ".ghcup")
-#endif


 -- | ~/.ghcup by default
@ -102,10 +99,9 @@ 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
+ghcupConfigDir
+  | isWindows = ghcupBaseDir
+  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
@ -120,17 +116,15 @@ ghcupConfigDir = do
            Just r  -> pure r
            Nothing -> liftIO getHomeDirectory
          pure (bdir </> ".ghcup")
-#endif


 -- | 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
+ghcupBinDir
+  | isWindows = ghcupBaseDir <&> (</> "bin")
+  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
@ -140,7 +134,6 @@ ghcupBinDir = do
              home <- liftIO getHomeDirectory
              pure (home </> ".local" </> "bin")
        else ghcupBaseDir <&> (</> "bin")
-#endif


 -- | Defaults to '~/.ghcup/cache'.
@ -148,10 +141,9 @@ 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
+ghcupCacheDir
+  | isWindows = ghcupBaseDir <&> (</> "cache")
+  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
@ -162,7 +154,6 @@ ghcupCacheDir = do
              pure (home </> ".cache")
          pure (bdir </> "ghcup")
        else ghcupBaseDir <&> (</> "cache")
-#endif


 -- | Defaults to '~/.ghcup/logs'.
@ -170,10 +161,9 @@ 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
+ghcupLogsDir
+  | isWindows = ghcupBaseDir <&> (</> "logs")
+  | otherwise = do
      xdg <- useXDG
      if xdg
        then do
@ -184,7 +174,6 @@ ghcupLogsDir = do
              pure (home </> ".cache")
          pure (bdir </> "ghcup" </> "logs")
        else ghcupBaseDir <&> (</> "logs")
-#endif


 -- | '~/.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)
+recyclePathForcibly fp
+  | isWindows = do
      Dirs { recycleDir } <- getDirs
      tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
      let dest = tmp </> takeFileName fp
-  liftIO (Win32.moveFileEx fp (Just dest) 0)
+      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)
-#else
-  liftIO $ removePathForcibly fp
-#endif
+            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)
+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 (Win32.moveFileEx fp (Just dest) 0)
+      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)
-#else
-  liftIO $ removeFile fp
-#endif
+          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)
+