Reduce IS_WINDOWS CPP

.gitlab/script/hlint.sh

@@ -15,5 +15,5 @@ git describe
 ecabal update
 ecabal install -w ghc-${GHC_VERSION} --installdir="$CI_PROJECT_DIR"/.local/bin hlint
 
-hlint -r lib/ test/ 
+hlint -r app/ lib/ test/ 
 

app/ghcup-gen/Main.hs

@@ -1,10 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE NamedFieldPuns    #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeApplications  #-}
 
 

app/ghcup-gen/Validate.hs

@@ -91,23 +91,23 @@ validate dls _ = do
   checkHasRequiredPlatforms t v tags arch pspecs = do
     let v' = prettyVer v
         arch' = prettyShow arch
-    when (notElem (Linux UnknownLinux) pspecs) $ do
+    when (Linux UnknownLinux `notElem` pspecs) $ do
       lift $ logError $
         "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
       addError
-    when ((notElem Darwin pspecs) && arch == A_64) $ do
+    when ((Darwin `notElem` pspecs) && arch == A_64) $ do
       lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
       addError
-    when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
+    when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
       "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
-    when (notElem Windows pspecs && arch == A_64) $ do
+    when (Windows `notElem` pspecs && arch == A_64) $ do
       lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
       addError
 
     -- alpine needs to be set explicitly, because
     -- we cannot assume that "Linux UnknownLinux" runs on Alpine
     -- (although it could be static)
-    when (notElem (Linux Alpine) pspecs) $
+    when (Linux Alpine `notElem` pspecs) $
       case t of
         GHCup | arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
         Cabal | v > [vver|2.4.1.0|]
@@ -117,7 +117,7 @@ validate dls _ = do
         _ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
 
   checkUniqueTags tool = do
-    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
+    let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
     let nonUnique =
           fmap fst
             .   filter (\(_, b) -> not b)
@@ -155,8 +155,8 @@ validate dls _ = do
 
   -- a tool must have at least one of each mandatory tags
   checkMandatoryTags tool = do
-    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
+    let allTags = _viTags =<< M.elems (availableToolVersions dls tool)
-    forM_ [Latest, Recommended] $ \t -> case elem t allTags of
+    forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
       False -> do
         lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
         addError
@@ -202,7 +202,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
   let dlis = either (const []) (\tool -> nubOrd $ dls ^.. each %& indices (maybe (const True) (==) tool) %> each %& indices (matchTest versionRegex . T.unpack . prettyVer) % (viSourceDL % _Just `summing` viArch % each % each % each)) etool
   let gdlis = nubOrd $ gt ^.. each
   let allDls = either (const gdlis) (const dlis) etool
-  when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
+  when (null allDls) $ logError "no tarballs selected by filter" *> runReaderT addError ref
   forM_ allDls (downloadAll ref)
 
   -- exit
@@ -260,7 +260,7 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
             when (basePath /= prel) $ do
               logError $
                 "Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
-              (flip runReaderT ref addError)
+              runReaderT addError ref
           Just (RegexDir regexString) -> do
             logInfo $
               "verifying subdir (regex): " <> T.pack regexString
@@ -268,13 +268,13 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
                   compIgnoreCase
                   execBlank
                   regexString
-            when (not (match regex basePath)) $ do
+            unless (match regex basePath) $ do
               logError $
                 "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
-              (flip runReaderT ref addError)
+              runReaderT addError ref
           Nothing -> pure ()
       VRight Nothing -> pure ()
       VLeft  e -> do
         logError $
           "Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
-        (flip runReaderT ref addError)
+        runReaderT addError ref

app/ghcup/BrickMain.hs

@@ -2,10 +2,7 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE ViewPatterns      #-}
 {-# LANGUAGE RankNTypes        #-}
 
 module BrickMain where
@@ -368,10 +365,7 @@ listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
 
 
 selectLatest :: Vector ListResult -> Int
-selectLatest v =
+selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
-  case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
-    Just ix -> ix
-    Nothing -> 0
 
 
 -- | Replace the @appState@ or construct it based on a filter function
@@ -398,14 +392,14 @@ filterVisible :: Bool -> Bool -> ListResult -> Bool
 filterVisible v t e | lInstalled e = True
                     | v
                     , not t
-                    , not (elem (lTool e) hiddenTools) = True
+                    , lTool e `notElem` hiddenTools = True
                     | not v
                     , t
-                    , not (elem Old (lTag e)) = True
+                    , Old `notElem` lTag e = True
                     | v
                     , t = True
-                    | otherwise = not (elem Old (lTag e)) &&
+                    | otherwise = (Old `notElem` lTag e) &&
-                                  not (elem (lTool e) hiddenTools)
+                                  (lTool e `notElem` hiddenTools)
 
 
 install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
@@ -507,7 +501,7 @@ del' _ (_, ListResult {..}) = do
     )
     >>= \case
           VRight vi -> do
-            forM_ (join $ fmap _viPostRemove vi) $ \msg ->
+            forM_ (_viPostRemove =<< vi) $ \msg ->
               logInfo msg
             pure $ Right ()
           VLeft  e -> pure $ Left (prettyShow e)
@@ -594,8 +588,7 @@ getGHCupInfo = do
   r <-
     flip runReaderT settings
     . runE @'[DigestError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError]
-    $ liftE
+    $ liftE getDownloadsF
-    $ getDownloadsF
 
   case r of
     VRight a -> pure $ Right a

app/ghcup/GHCup/OptParse.hs

@@ -1,11 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 
@@ -109,7 +105,7 @@ opts =
   Options
     <$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
     <*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
-    <*> (optional
+    <*> optional
           (option
             (eitherReader parseUri)
             (  short 's'
@@ -119,7 +115,6 @@ opts =
             <> internal
             )
           )
-        )
     <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
     <*> optional (option
           (eitherReader keepOnParser)
@@ -164,11 +159,10 @@ com =
       (  command
           "tui"
           (   (\_ -> Interactive)
-          <$> (info
+          <$> info
                 helper
                 (  progDesc "Start the interactive GHCup UI"
                 )
-              )
           )
       <>  command
 #else

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}

app/ghcup/GHCup/OptParse/Common.hs

@@ -1,11 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 module GHCup.OptParse.Common where
@@ -160,7 +156,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
   archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32)
   platformP :: MP.Parsec Void Text PlatformRequest
   platformP = choice'
-    [ (\a mv -> PlatformRequest a FreeBSD mv)
+    [ (`PlatformRequest` FreeBSD)
     <$> (archP <* MP.chunk "-")
     <*> (  MP.chunk "portbld"
         *> (   MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof))
@@ -168,7 +164,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of
            )
         <* MP.chunk "-freebsd"
         )
-    , (\a mv -> PlatformRequest a Darwin mv)
+    , (`PlatformRequest` Darwin)
     <$> (archP <* MP.chunk "-")
     <*> (  MP.chunk "apple"
         *> (   MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof))
@@ -311,11 +307,8 @@ tagCompleter tool add = listIOCompleter $ do
   mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
   case mGhcUpInfo of
     VRight ghcupInfo -> do
-      let allTags = filter (\t -> t /= Old)
+      let allTags = filter (/= Old)
-            $ join
+            $ _viTags =<< M.elems (availableToolVersions (_ghcupDownloads ghcupInfo) tool)
-            $ fmap _viTags
-            $ M.elems
-            $ availableToolVersions (_ghcupDownloads ghcupInfo) tool
       pure $ nub $ (add ++) $ fmap tagToString allTags
     VLeft _ -> pure  (nub $ ["recommended", "latest"] ++ add)
 
@@ -396,7 +389,7 @@ fromVersion' :: ( HasLog env
                    ] m (GHCTargetVersion, Maybe VersionInfo)
 fromVersion' SetRecommended tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-  (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool
+  bimap mkTVer Just <$> getRecommended dls tool
     ?? TagNotFound Recommended tool
 fromVersion' (SetToolVersion v) tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
@@ -407,18 +400,18 @@ fromVersion' (SetToolVersion v) tool = do
       lift (getLatestToolFor tool pvpIn dls) >>= \case
         Just (pvp_, vi') -> do
           v' <- lift $ pvpToVersion pvp_
-          when (v' /= (_tvVersion v)) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
+          when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v')
           pure (GHCTargetVersion (_tvTarget v) v', Just vi')
         Nothing -> pure (v, vi)
 fromVersion' (SetToolTag Latest) tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-  (\(x, y) -> (mkTVer x, Just y)) <$> getLatest dls tool ?? TagNotFound Latest tool
+  bimap mkTVer Just <$> getLatest dls tool ?? TagNotFound Latest tool
 fromVersion' (SetToolTag Recommended) tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-  (\(x, y) -> (mkTVer x, Just y)) <$> getRecommended dls tool ?? TagNotFound Recommended tool
+  bimap mkTVer Just <$> getRecommended dls tool ?? TagNotFound Recommended tool
 fromVersion' (SetToolTag (Base pvp'')) GHC = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
-  (\(x, y) -> (mkTVer x, Just y)) <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
+  bimap mkTVer Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC
 fromVersion' SetNext tool = do
   GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
   next <- case tool of
@@ -430,7 +423,7 @@ fromVersion' SetNext tool = do
         . dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set)
         . cycle
         . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y))
-        . filter (\GHCTargetVersion {..} -> _tvTarget == Nothing)
+        . filter (\GHCTargetVersion {..} -> isNothing _tvTarget)
         $ ghcs) ?? NoToolVersionSet tool
     Cabal -> do
       set <- cabalSet !? NoToolVersionSet tool

app/ghcup/GHCup/OptParse/Compile.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -508,7 +507,7 @@ compile compileCommand settings runAppState runLogger = do
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
                   Never -> runLogger $ logError $ T.pack $ prettyShow err
-                  _ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
                         "Check the logs at " <> T.pack logsDir <> " and the build directory "
                         <> T.pack tmpdir <> " for more clues." <> "\n" <>
                         "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")

app/ghcup/GHCup/OptParse/Config.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -84,7 +83,7 @@ prettyDebugInfo DebugInfo {..} = "Debug Info" <> "\n" <>
 type DInfoEffects = '[ NoCompatiblePlatform , NoCompatibleArch , DistroNotFound ]
 
 runDebugInfo :: (ReaderT env m (VEither DInfoEffects a) -> m (VEither DInfoEffects a))
-             -> (Excepts DInfoEffects (ReaderT env m) a)
+             -> Excepts DInfoEffects (ReaderT env m) a
              -> m (VEither DInfoEffects a)
 runDebugInfo runAppState =
         runAppState

app/ghcup/GHCup/OptParse/GC.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -104,7 +103,7 @@ type GCEffects = '[ NotInstalled ]
 
 runGC :: MonadUnliftIO m
       => (ReaderT AppState m (VEither GCEffects a) -> m (VEither GCEffects a))
-      -> (Excepts GCEffects (ResourceT (ReaderT AppState m)) a)
+      -> Excepts GCEffects (ResourceT (ReaderT AppState m)) a
       -> m (VEither GCEffects a)
 runGC runAppState =
   runAppState

app/ghcup/GHCup/OptParse/Install.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -275,7 +274,7 @@ runInstTool appstate' mInstPlatform =
     -------------------
 
 
-install :: (Either InstallCommand InstallOptions) -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
+install :: Either InstallCommand InstallOptions -> Settings -> IO AppState -> (ReaderT LeanAppState IO () -> IO ()) -> IO ExitCode
 install installCommand settings getAppState' runLogger = case installCommand of
   (Right iopts) -> do
     runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
@@ -324,8 +323,8 @@ install installCommand settings getAppState' runLogger = case installCommand of
                 pure $ ExitFailure 3
               VLeft err@(V (BuildFailed tmpdir _)) -> do
                 case keepDirs settings of
-                  Never -> runLogger $ (logError $ T.pack $ prettyShow err)
+                  Never -> runLogger (logError $ T.pack $ prettyShow err)
-                  _ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
+                  _ -> runLogger (logError $ T.pack (prettyShow err) <> "\n" <>
                     "Check the logs at " <> T.pack logsDir <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <>
                     "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
                 pure $ ExitFailure 3

app/ghcup/GHCup/OptParse/List.hs

@@ -1,11 +1,7 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -15,6 +11,7 @@ module GHCup.OptParse.List where
 
 
 import           GHCup
+import           GHCup.Utils.Prelude
 import           GHCup.Types
 import           GHCup.OptParse.Common
 
@@ -99,7 +96,7 @@ printListResult :: Bool -> Bool -> [ListResult] -> IO ()
 printListResult no_color raw lr = do
 
   let
-    color | raw || no_color = flip const
+    color | raw || no_color = (\_ x -> x)
           | otherwise       = Pretty.color
 
   let
@@ -119,22 +116,16 @@ printListResult no_color raw lr = do
         . fmap
             (\ListResult {..} ->
               let marks = if
-#if defined(IS_WINDOWS)
+                    | lSet       -> (color Green (if isWindows then "IS" else "✔✔"))
-                    | lSet       -> (color Green "IS")
+                    | lInstalled -> (color Green (if isWindows then "I " else "✓ "))
-                    | lInstalled -> (color Green "I ")
+                    | otherwise  -> (color Red   (if isWindows then "X " else "✗ "))
-                    | otherwise  -> (color Red "X ")
-#else
-                    | lSet       -> (color Green "✔✔")
-                    | lInstalled -> (color Green "✓ ")
-                    | otherwise  -> (color Red "✗ ")
-#endif
               in
                 (if raw then [] else [marks])
                   ++ [ fmap toLower . show $ lTool
                      , case lCross of
                        Nothing -> T.unpack . prettyVer $ lVer
                        Just c  -> T.unpack (c <> "-" <> prettyVer lVer)
-                     , intercalate "," $ (filter (/= "") . fmap printTag $ sort lTag)
+                     , intercalate "," (filter (/= "") . fmap printTag $ sort lTag)
                      , intercalate ","
                      $  (if hlsPowered
                           then [color Green "hls-powered"]
@@ -151,10 +142,10 @@ printListResult no_color raw lr = do
         $ lr
   let cols =
         foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
-      lengths = fmap maximum . (fmap . fmap) strWidth $ cols
+      lengths = fmap (maximum . fmap strWidth) cols
       padded  = fmap (\xs -> zipWith padTo xs lengths) rows
 
-  forM_ padded $ \row -> putStrLn $ intercalate " " row
+  forM_ padded $ \row -> putStrLn $ unwords row
  where
 
   padTo str' x =

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -3,9 +3,6 @@
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -49,7 +46,7 @@ type NukeEffects = '[ NotInstalled ]
 
 
 runNuke :: AppState
-        -> (Excepts NukeEffects (ReaderT AppState m) a)
+        -> Excepts NukeEffects (ReaderT AppState m) a
         -> m (VEither NukeEffects a)
 runNuke s' =
   flip runReaderT s' . runE @NukeEffects

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -85,7 +84,7 @@ prefetchP = subparser
           <$> (PrefetchGHCOptions
                 <$> ( switch (short 's' <> long "source" <> help "Download source tarball instead of bindist") <**> helper )
                 <*> optional (option str (short 'd' <> long "directory" <> help "directory to download into (default: ~/.ghcup/cache/)")))
-          <*> ( optional (toolVersionArgument Nothing (Just GHC)) ))
+          <*>  optional (toolVersionArgument Nothing (Just GHC)) )
         ( progDesc "Download GHC assets for installation")
       )
       <>
@@ -118,7 +117,7 @@ prefetchP = subparser
       <>
      command
       "metadata"
-      (const PrefetchMetadata <$> info
+      (PrefetchMetadata <$ info
         helper
         ( progDesc "Download ghcup's metadata, needed for various operations")
       )
@@ -162,7 +161,7 @@ type PrefetchEffects = '[ TagNotFound
 
 runPrefetch :: MonadUnliftIO m
             => (ReaderT AppState m (VEither PrefetchEffects a) -> m (VEither PrefetchEffects a))
-            -> (Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a)
+            -> Excepts PrefetchEffects (ResourceT (ReaderT AppState m)) a
             -> m (VEither PrefetchEffects a)
 runPrefetch runAppState =
   runAppState
@@ -197,20 +196,20 @@ prefetch prefetchCommand runAppState runLogger =
           if pfGHCSrc
           then liftE $ fetchGHCSrc (_tvVersion v) pfCacheDir
           else liftE $ fetchToolBindist (_tvVersion v) GHC pfCacheDir
-      PrefetchCabal (PrefetchOptions {pfCacheDir}) mt   -> do
+      PrefetchCabal PrefetchOptions {pfCacheDir} mt   -> do
         forM_ pfCacheDir (liftIO . createDirRecursive')
         (v, _) <- liftE $ fromVersion mt Cabal
         liftE $ fetchToolBindist (_tvVersion v) Cabal pfCacheDir
-      PrefetchHLS (PrefetchOptions {pfCacheDir}) mt   -> do
+      PrefetchHLS PrefetchOptions {pfCacheDir} mt   -> do
         forM_ pfCacheDir (liftIO . createDirRecursive')
         (v, _) <- liftE $ fromVersion mt HLS
         liftE $ fetchToolBindist (_tvVersion v) HLS pfCacheDir
-      PrefetchStack (PrefetchOptions {pfCacheDir}) mt   -> do
+      PrefetchStack PrefetchOptions {pfCacheDir} mt   -> do
         forM_ pfCacheDir (liftIO . createDirRecursive')
         (v, _) <- liftE $ fromVersion mt Stack
         liftE $ fetchToolBindist (_tvVersion v) Stack pfCacheDir
       PrefetchMetadata -> do
-        _ <- liftE $ getDownloadsF
+        _ <- liftE getDownloadsF
         pure ""
        ) >>= \case
                 VRight _ -> do

app/ghcup/GHCup/OptParse/Rm.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -132,7 +131,7 @@ type RmEffects = '[ NotInstalled ]
 
 
 runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
-            -> (Excepts RmEffects (ReaderT env m) a)
+            -> Excepts RmEffects (ReaderT env m) a
             -> m (VEither RmEffects a)
 runRm runAppState =
     runAppState
@@ -152,7 +151,7 @@ rm :: ( Monad m
       , MonadUnliftIO m
       , MonadFail m
       )
-   => (Either RmCommand RmOptions)
+   => Either RmCommand RmOptions
    -> (ReaderT AppState m (VEither RmEffects (Maybe VersionInfo))
        -> m (VEither RmEffects (Maybe VersionInfo)))
    -> (ReaderT LeanAppState m () -> m ())

app/ghcup/GHCup/OptParse/Set.hs

@@ -2,8 +2,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -42,6 +40,7 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import qualified Data.Text                     as T
 import Data.Bifunctor (second)
 import Control.Exception.Safe (MonadMask)
+import GHCup.Types.Optics
 
 
 
@@ -187,7 +186,7 @@ type SetGHCEffects = '[ FileDoesNotExistError
                    , NoToolVersionSet]
 
 runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a))
-          -> (Excepts SetGHCEffects (ReaderT env m) a)
+          -> Excepts SetGHCEffects (ReaderT env m) a
           -> m (VEither SetGHCEffects a)
 runSetGHC runAppState =
     runAppState
@@ -201,7 +200,7 @@ type SetCabalEffects = '[ NotInstalled
                         , NoToolVersionSet]
 
 runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a))
-            -> (Excepts SetCabalEffects (ReaderT env m) a)
+            -> Excepts SetCabalEffects (ReaderT env m) a
             -> m (VEither SetCabalEffects a)
 runSetCabal runAppState =
     runAppState
@@ -215,7 +214,7 @@ type SetHLSEffects = '[ NotInstalled
                       , NoToolVersionSet]
 
 runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a))
-          -> (Excepts SetHLSEffects (ReaderT env m) a)
+          -> Excepts SetHLSEffects (ReaderT env m) a
           -> m (VEither SetHLSEffects a)
 runSetHLS runAppState =
     runAppState
@@ -229,7 +228,7 @@ type SetStackEffects = '[ NotInstalled
                         , NoToolVersionSet]
 
 runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a))
-            -> (Excepts SetStackEffects (ReaderT env m) a)
+            -> Excepts SetStackEffects (ReaderT env m) a
             -> m (VEither SetStackEffects a)
 runSetStack runAppState =
     runAppState
@@ -243,15 +242,18 @@ runSetStack runAppState =
     -------------------
 
 
-set :: forall m . ( Monad m
+set :: forall m env.
+       ( Monad m
        , MonadMask m
        , MonadUnliftIO m
        , MonadFail m
+       , HasDirs env
+       , HasLog env
        )
     => Either SetCommand SetOptions
     -> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
         -> m (VEither eff GHCTargetVersion))
-    -> (forall eff . ReaderT LeanAppState m (VEither eff GHCTargetVersion)
+    -> (forall eff. ReaderT env m (VEither eff GHCTargetVersion)
         -> m (VEither eff GHCTargetVersion))
     -> (ReaderT LeanAppState m () -> m ())
     -> m ExitCode

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -2,10 +2,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -49,7 +45,7 @@ type ToolRequirementsEffects = '[ NoCompatiblePlatform , DistroNotFound , NoTool
 
 
 runToolRequirements :: (ReaderT env m (VEither ToolRequirementsEffects a) -> m (VEither ToolRequirementsEffects a))
-                    -> (Excepts ToolRequirementsEffects (ReaderT env m) a)
+                    -> Excepts ToolRequirementsEffects (ReaderT env m) a
                     -> m (VEither ToolRequirementsEffects a)
 runToolRequirements runAppState =
     runAppState

app/ghcup/GHCup/OptParse/UnSet.hs

@@ -2,7 +2,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -36,6 +35,7 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
+import GHCup.Types.Optics
 
 
 
@@ -72,7 +72,7 @@ data UnsetOptions = UnsetOptions
           
 unsetParser :: Parser UnsetCommand
 unsetParser =
-  (subparser
+  subparser
       (  command
           "ghc"
           (   UnsetGHC
@@ -110,7 +110,6 @@ unsetParser =
                  )
            )
       )
-    )
  where
   unsetGHCFooter :: String
   unsetGHCFooter = [s|Discussion:
@@ -156,7 +155,7 @@ type UnsetEffects = '[ NotInstalled ]
 
 
 runUnsetGHC :: (ReaderT env m (VEither UnsetEffects a) -> m (VEither UnsetEffects a))
-            -> (Excepts UnsetEffects (ReaderT env m) a)
+            -> Excepts UnsetEffects (ReaderT env m) a
             -> m (VEither UnsetEffects a)
 runUnsetGHC runLeanAppState =
     runLeanAppState
@@ -175,9 +174,11 @@ unset :: ( Monad m
          , MonadMask m
          , MonadUnliftIO m
          , MonadFail m
+         , HasDirs env
+         , HasLog env
          )
       => UnsetCommand
-      -> (ReaderT LeanAppState m (VEither UnsetEffects ())
+      -> (ReaderT env m (VEither UnsetEffects ())
           -> m (VEither UnsetEffects ()))
       -> (ReaderT LeanAppState m () -> m ())
       -> m ExitCode

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -3,9 +3,6 @@
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 

app/ghcup/GHCup/OptParse/Whereis.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -113,7 +112,7 @@ whereisP = subparser
       <>
      command
       "ghcup"
-      (WhereisTool GHCup <$> info ( (pure Nothing) <**> helper ) ( progDesc "Get ghcup location" ))
+      (WhereisTool GHCup <$> info ( pure Nothing <**> helper ) ( progDesc "Get ghcup location" ))
     ) <|> subparser ( commandGroup "Directory locations:"
       <>
      command
@@ -266,7 +265,7 @@ whereis :: ( Monad m
       -> (ReaderT LeanAppState m () -> m ())
       -> m ExitCode
 whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
-  VRight Dirs{ .. }  <- runAppState (VRight <$> getDirs)
+  Dirs{ .. }  <- runReaderT getDirs leanAppstate
   case (whereisCommand, whereisOptions) of
     (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
       runLeanWhereIs leanAppstate (do
@@ -283,7 +282,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                 runLogger $ logError $ T.pack $ prettyShow e
                 pure $ ExitFailure 30
 
-    (WhereisTool tool whereVer, WhereisOptions{..}) ->
+    (WhereisTool tool whereVer, WhereisOptions{..}) -> do
       runWhereIs runAppState (do
         (v, _) <- liftE $ fromVersion whereVer tool
         loc <- liftE $ whereIsTool tool v

app/ghcup/Main.hs

@@ -5,7 +5,6 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 
@@ -112,7 +111,7 @@ plan_json = $( do
                              c <- B.readFile fp
                              (Just res) <- pure $ decodeStrict' @Value c
                              pure (fp, T.unpack $ decUTF8Safe' $ encodePretty res))
-                when (not . null $ fp ) $ qAddDependentFile fp
+                unless (null fp) $ qAddDependentFile fp
                 pure . LitE . StringL $ c)
 
 
@@ -124,8 +123,7 @@ main = do
   void enableAnsiSupport
 
   let versionHelp = infoOption
-        ( ("The GHCup Haskell installer, version " <>)
+        ( "The GHCup Haskell installer, version " <> (head . lines $ describe_result)
-          (head . lines $ describe_result)
         )
         (long "version" <> help "Show version" <> hidden)
   let planJson = infoOption
@@ -170,7 +168,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           (settings, keybindings) <- toSettings opt
 
           -- logger interpreter
-          logfile <- flip runReaderT dirs initGHCupFileLogging
+          logfile <- runReaderT initGHCupFileLogging dirs
           no_color <- isJust <$> lookupEnv "NO_COLOR"
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
@@ -204,8 +202,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                 ghcupInfo <-
                   ( flip runReaderT leanAppstate
                     . runE @'[DigestError, GPGError, JSONError , DownloadFailed, FileDoesNotExistError]
-                    $ liftE
+                    $ liftE getDownloadsF
-                    $ getDownloadsF
                     )
                     >>= \case
                           VRight r -> pure r
@@ -215,7 +212,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             exitWith (ExitFailure 2)
                 let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
 
-                race_ (liftIO $ flip runReaderT s' cleanupTrash)
+                race_ (liftIO $ runReaderT cleanupTrash s')
                       (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
 
                 case optCommand of
@@ -229,11 +226,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                   Interactive -> pure ()
 #endif
                   _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
-                         Nothing -> flip runReaderT s' checkForUpdates
+                         Nothing -> runReaderT checkForUpdates s'
                          Just _ -> pure ()
 
                 -- TODO: always run for windows
-                (siletRunLogger $ flip runReaderT s' $ runE ensureGlobalTools) >>= \case
+                siletRunLogger (flip runReaderT s' $ runE ensureGlobalTools) >>= \case
                   VRight _ -> pure ()
                   VLeft e -> do
                     runLogger
@@ -251,7 +248,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 #endif
               runAppState action' = do
                 s' <- liftIO appState
-                flip runReaderT s' action'
+                runReaderT action' s'
                   
 
           -----------------

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.Common
+    GHCup.OptParse
-                      GHCup.OptParse.Set
+    GHCup.OptParse.ChangeLog
-                      GHCup.OptParse.UnSet
+    GHCup.OptParse.Common
-                      GHCup.OptParse.Rm
+    GHCup.OptParse.Compile
-                      GHCup.OptParse.Compile
+    GHCup.OptParse.Config
-                      GHCup.OptParse.Config
+    GHCup.OptParse.DInfo
-                      GHCup.OptParse.Whereis
+    GHCup.OptParse.GC
-                      GHCup.OptParse.List
+    GHCup.OptParse.Install
-                      GHCup.OptParse.DInfo
+    GHCup.OptParse.List
-                      GHCup.OptParse.Upgrade
+    GHCup.OptParse.Nuke
-                      GHCup.OptParse.ToolRequirements
+    GHCup.OptParse.Prefetch
-                      GHCup.OptParse.ChangeLog
+    GHCup.OptParse.Rm
-                      GHCup.OptParse.Nuke
+    GHCup.OptParse.Set
-                      GHCup.OptParse.Prefetch
+    GHCup.OptParse.ToolRequirements
-                      GHCup.OptParse.GC
+    GHCup.OptParse.UnSet
-                      GHCup.OptParse
+    GHCup.OptParse.Upgrade
+    GHCup.OptParse.Whereis
+
   hs-source-dirs:     app/ghcup
   default-language:   Haskell2010
   default-extensions:

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
+installUnpackedGHC path inst ver
-#if defined(IS_WINDOWS)
+  | isWindows = do
-  lift $ logInfo "Installing GHC (this may take a while)"
+      lift $ logInfo "Installing GHC (this may take a while)"
-  -- Windows bindists are relocatable and don't need
+      -- Windows bindists are relocatable and don't need
-  -- to run configure.
+      -- to run configure.
-  -- We also must make sure to preserve mtime to not confuse ghc-pkg.
+      -- 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
+      lift $ withRunInIO $ \run -> flip onException (run $ recyclePathForcibly inst) $ copyDirectoryRecursive path inst $ \source dest -> do
-    mtime <- getModificationTime source
+        mtime <- getModificationTime source
-    Win32.moveFile source dest
+        moveFilePortable source dest
-    setModificationTime dest mtime
+        setModificationTime dest mtime
-#else
+  | otherwise = do
-  PlatformRequest {..} <- lift getPlatformReq
+      PlatformRequest {..} <- lift getPlatformReq
 
-  let alpineArgs
+      let alpineArgs
-       | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
+           | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform
-       = ["--disable-ld-override"]
+           = ["--disable-ld-override"]
-       | otherwise
+           | otherwise
-       = []
+           = []
 
-  lift $ logInfo "Installing GHC (this may take a while)"
+      lift $ logInfo "Installing GHC (this may take a while)"
-  lEM $ execLogged "sh"
+      lEM $ execLogged "sh"
-                   ("./configure" : ("--prefix=" <> inst) 
+                       ("./configure" : ("--prefix=" <> inst) 
-                    : alpineArgs
+                        : alpineArgs
-                   )
+                       )
-                   (Just path)
+                       (Just path)
-                   "ghc-configure"
+                       "ghc-configure"
-                   Nothing
+                       Nothing
-  lEM $ make ["install"] (Just path)
+      lEM $ make ["install"] (Just path)
-  pure ()
+      pure ()
-#endif
 
 
 -- | 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)
+          if isWindows
-            -- On windows we need to be more permissive
+          then liftIO
-            -- in case symlinks can't be created, be just
+                 -- On windows we need to be more permissive
-            -- give up here. This symlink isn't strictly necessary.
+                 -- in case symlinks can't be created, be just
-            $ hideError permissionErrorType
+                 -- give up here. This symlink isn't strictly necessary.
-            $ hideError illegalOperationErrorType
+                 $ hideError permissionErrorType
-#endif
+                 $ hideError illegalOperationErrorType
-            $ createDirectoryLink targetF fullF
+                 $ 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)
+  if isWindows
-  -- since it doesn't seem possible to delete a running exe on windows
+  then do
-  -- we move it to temp dir, to be deleted at next reboot
+    -- since it doesn't seem possible to delete a running exe on windows
-  tempFilepath <- mkGhcupTmpDir
+    -- we move it to temp dir, to be deleted at next reboot
-  hideError UnsupportedOperation $
+    tempFilepath <- mkGhcupTmpDir
-            liftIO $ hideError NoSuchThing $
+    hideError UnsupportedOperation $
-            Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
+              liftIO $ hideError NoSuchThing $
-#else
+              moveFile ghcupFilepath (tempFilepath </> "ghcup")
-  -- delete it.
+  else
-  hideError doesNotExistErrorType $ rmFile ghcupFilepath
+    -- delete it.
-#endif
+    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)
+  when isWindows $ do
-  logInfo $ "removing " <> T.pack (baseDir </> "msys64")
+    logInfo $ "removing " <> T.pack (baseDir </> "msys64")
-  handleRm $ rmPathForcibly (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
+    rmBinDir binDir
-#if !defined(IS_WINDOWS)
+      | isWindows = removeDirIfEmptyOrIsSymlink binDir
-      isXDGStyle <- liftIO useXDG
+      | otherwise = do
-      if not isXDGStyle
+          isXDGStyle <- liftIO useXDG
-        then removeDirIfEmptyOrIsSymlink binDir
+          if not isXDGStyle
-        else pure ()
+            then removeDirIfEmptyOrIsSymlink binDir
-#else
+            else pure ()
-      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 = if isWindows
-    let possible_files = ((workdir </> "hadrian") </>) <$> ["build.bat"]
+                         then ((workdir </> "hadrian") </>) <$> ["build.bat"]
-#else   
+                         else ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
-    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
@@ -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)
+            ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
-            ++ ["--enable-tarballs-autodownload"]
-#endif
             ++ 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)
+          ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
-          ++ ["--enable-tarballs-autodownload"]
-#endif
           ++ fmap T.unpack aargs
           )
           (Just workdir)

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
-exeExt = ".exe"
+  | isWindows = ".exe"
-#else
+  | otherwise = ""
-exeExt = ""
-#endif
 
 -- | The file extension for executables.
 exeExt' :: ByteString
-#if defined(IS_WINDOWS)
+exeExt'
-exeExt' = ".exe"
+  | isWindows = ".exe"
-#else
+  | otherwise = ""
-exeExt' = ""
-#endif
 
 
--- | 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
+getLinkTarget fp
-#if defined(IS_WINDOWS)
+  | isWindows = do
-  content <- readFile (dropExtension fp <.> "shim")
+      content <- readFile (dropExtension fp <.> "shim")
-  [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
+      [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content
-  pure $ stripNewline $ dropPrefix "path = " p
+      pure $ stripNewline $ dropPrefix "path = " p
-#else
+  | otherwise = getSymbolicLinkTarget fp
-  getSymbolicLinkTarget fp
-#endif
 
 
 -- | Checks whether the path is a link.
 pathIsLink :: FilePath -> IO Bool
-#if defined(IS_WINDOWS)
+pathIsLink fp
-pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
+  | isWindows = doesPathExist (dropExtension fp <.> "shim")
-#else
+  | otherwise = pathIsSymbolicLink fp
-pathIsLink = pathIsSymbolicLink
-#endif
 
 
 rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
-#if defined(IS_WINDOWS)
+rmLink fp
-rmLink fp = do
+  | isWindows = do
-  hideError doesNotExistErrorType . recycleFile $ fp
+      hideError doesNotExistErrorType . recycleFile $ fp
-  hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
+      hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
-#else
+  | otherwise = hideError doesNotExistErrorType . recycleFile $ fp
-rmLink = hideError doesNotExistErrorType . recycleFile
-#endif
 
 
 -- | 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
+createLink link exe
-#if defined(IS_WINDOWS)
+  | isWindows = do
-  dirs <- getDirs
+      dirs <- getDirs
-  let shimGen = cacheDir dirs </> "gs.exe"
+      let shimGen = cacheDir dirs </> "gs.exe"
 
-  let shim = dropExtension exe <.> "shim"
+      let shim = dropExtension exe <.> "shim"
-      -- For hardlinks, link needs to be absolute.
+          -- For hardlinks, link needs to be absolute.
-      -- If link is relative, it's relative to the target exe.
+          -- If link is relative, it's relative to the target exe.
-      -- Note that (</>) drops lhs when rhs is absolute.
+          -- Note that (</>) drops lhs when rhs is absolute.
-      fullLink = takeDirectory exe </> link
+          fullLink = takeDirectory exe </> link
-      shimContents = "path = " <> fullLink
+          shimContents = "path = " <> fullLink
 
-  logDebug $ "rm -f " <> T.pack exe
+      logDebug $ "rm -f " <> T.pack exe
-  rmLink exe
+      rmLink exe
 
-  logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
+      logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
-  liftIO $ copyFile shimGen exe
+      liftIO $ copyFile shimGen exe
-  liftIO $ writeFile shim shimContents
+      liftIO $ writeFile shim shimContents
-#else
+  | otherwise = do
-  logDebug $ "rm -f " <> T.pack exe
+      logDebug $ "rm -f " <> T.pack exe
-  hideError doesNotExistErrorType $ recycleFile exe
+      hideError doesNotExistErrorType $ recycleFile exe
 
-  logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
+      logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe
-  liftIO $ createFileLink link 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
+ensureGlobalTools
-#if defined(IS_WINDOWS)
+  | isWindows = do
-  (GHCupInfo _ _ gTools) <- lift getGHCupInfo
+      (GHCupInfo _ _ gTools) <- lift getGHCupInfo
-  dirs <- lift getDirs
+      dirs <- lift getDirs
-  shimDownload <- liftE $ lE @_ @'[NoDownload]
+      shimDownload <- liftE $ lE @_ @'[NoDownload]
-    $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
+        $ maybe (Left NoDownload) Right $ Map.lookup ShimGen gTools
-  let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
+      let dl = downloadCached' shimDownload (Just "gs.exe") Nothing
-  void $ (\(DigestError _ _ _) -> do
+      void $ (\DigestError{} -> do
-      lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
+          lift $ logWarn "Digest doesn't match, redownloading gs.exe..."
-      lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
+          lift $ logDebug ("rm -f " <> T.pack (cacheDir dirs </> "gs.exe"))
-      lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
+          lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
-      liftE @'[GPGError, DigestError , DownloadFailed] $ dl
+          liftE @'[GPGError, DigestError , DownloadFailed] $ dl
-    ) `catchE` (liftE @'[GPGError, DigestError , DownloadFailed] dl)
+        ) `catchE` liftE @'[GPGError, DigestError , DownloadFailed] dl
-  pure ()
+  | otherwise = pure ()
-#else
-  pure ()
-#endif
 
 
 -- | Ensure ghcup directory structure exists.

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
+ghcupBaseDir
-#if defined(IS_WINDOWS)
+  | isWindows = do
-  bdir <- fromMaybe "C:\\" <$> lookupEnv "GHCUP_INSTALL_BASE_PREFIX"
+      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")
       pure (bdir </> "ghcup")
-    else do
+  | otherwise = do
-      bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+      xdg <- useXDG
-        Just r  -> pure r
+      if xdg
-        Nothing -> liftIO getHomeDirectory
+        then do
-      pure (bdir </> ".ghcup")
+          bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
-#endif
+            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
+ghcupConfigDir
-#if defined(IS_WINDOWS)
+  | isWindows = ghcupBaseDir
-  ghcupBaseDir
+  | otherwise = do
-#else
+      xdg <- useXDG
-  xdg <- useXDG
+      if xdg
-  if xdg
+        then do
-    then do
+          bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
-      bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
+            Just r  -> pure r
-        Just r  -> pure r
+            Nothing -> do
-        Nothing -> do
+              home <- liftIO getHomeDirectory
-          home <- liftIO getHomeDirectory
+              pure (home </> ".config")
-          pure (home </> ".config")
+          pure (bdir </> "ghcup")
-      pure (bdir </> "ghcup")
+        else do
-    else do
+          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-      bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+            Just r  -> pure r
-        Just r  -> pure r
+            Nothing -> liftIO getHomeDirectory
-        Nothing -> liftIO getHomeDirectory
+          pure (bdir </> ".ghcup")
-      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
+ghcupBinDir
-#if defined(IS_WINDOWS)
+  | isWindows = ghcupBaseDir <&> (</> "bin")
-  ghcupBaseDir <&> (</> "bin")
+  | otherwise = do
-#else
+      xdg <- useXDG
-  xdg <- useXDG
+      if xdg
-  if xdg
+        then do
-    then do
+          lookupEnv "XDG_BIN_HOME" >>= \case
-      lookupEnv "XDG_BIN_HOME" >>= \case
+            Just r  -> pure r
-        Just r  -> pure r
+            Nothing -> do
-        Nothing -> do
+              home <- liftIO getHomeDirectory
-          home <- liftIO getHomeDirectory
+              pure (home </> ".local" </> "bin")
-          pure (home </> ".local" </> "bin")
+        else ghcupBaseDir <&> (</> "bin")
-    else ghcupBaseDir <&> (</> "bin")
-#endif
 
 
 -- | 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
+ghcupCacheDir
-#if defined(IS_WINDOWS)
+  | isWindows = ghcupBaseDir <&> (</> "cache")
-  ghcupBaseDir <&> (</> "cache")
+  | otherwise = do
-#else
+      xdg <- useXDG
-  xdg <- useXDG
+      if xdg
-  if xdg
+        then do
-    then do
+          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
-      bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+            Just r  -> pure r
-        Just r  -> pure r
+            Nothing -> do
-        Nothing -> do
+              home <- liftIO getHomeDirectory
-          home <- liftIO getHomeDirectory
+              pure (home </> ".cache")
-          pure (home </> ".cache")
+          pure (bdir </> "ghcup")
-      pure (bdir </> "ghcup")
+        else ghcupBaseDir <&> (</> "cache")
-    else ghcupBaseDir <&> (</> "cache")
-#endif
 
 
 -- | 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
+ghcupLogsDir
-#if defined(IS_WINDOWS)
+  | isWindows = ghcupBaseDir <&> (</> "logs")
-  ghcupBaseDir <&> (</> "logs")
+  | otherwise = do
-#else
+      xdg <- useXDG
-  xdg <- useXDG
+      if xdg
-  if xdg
+        then do
-    then do
+          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
-      bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+            Just r  -> pure r
-        Just r  -> pure r
+            Nothing -> do
-        Nothing -> do
+              home <- liftIO getHomeDirectory
-          home <- liftIO getHomeDirectory
+              pure (home </> ".cache")
-          pure (home </> ".cache")
+          pure (bdir </> "ghcup" </> "logs")
-      pure (bdir </> "ghcup" </> "logs")
+        else ghcupBaseDir <&> (</> "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

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)
+

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
+recyclePathForcibly fp
-#if defined(IS_WINDOWS)
+  | isWindows = do
-  Dirs { recycleDir } <- getDirs
+      Dirs { recycleDir } <- getDirs
-  tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
+      tmp <- liftIO $ createTempDirectory recycleDir "recyclePathForcibly"
-  let dest = tmp </> takeFileName fp
+      let dest = tmp </> takeFileName fp
-  liftIO (Win32.moveFileEx fp (Just dest) 0)
+      liftIO (moveFile fp dest)
-      `catch`
+          `catch`
-      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+          (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
-      `finally`
+          `finally`
-        (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+            liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-#else
+  | otherwise = liftIO $ removePathForcibly fp
-  liftIO $ removePathForcibly fp
-#endif
 
 
 rmPathForcibly :: ( MonadIO m
@@ -458,23 +460,17 @@ rmPathForcibly :: ( MonadIO m
                   )
                => FilePath
                -> m ()
-rmPathForcibly fp =
+rmPathForcibly fp
-#if defined(IS_WINDOWS)
+  | isWindows = recover (liftIO $ removePathForcibly fp)
-  recover (liftIO $ removePathForcibly fp)
+  | otherwise = liftIO $ removePathForcibly fp
-#else
-  liftIO $ removePathForcibly fp
-#endif
 
 
 rmDirectory :: (MonadIO m, MonadMask m)
             => FilePath
             -> m ()
-rmDirectory fp =
+rmDirectory fp
-#if defined(IS_WINDOWS)
+  | isWindows = recover (liftIO $ removeDirectory fp)
-  recover (liftIO $ removeDirectory fp)
+  | otherwise = liftIO $ removeDirectory fp
-#else
-  liftIO $ removeDirectory fp
-#endif
 
 
 -- https://www.sqlite.org/src/info/89f1848d7f
@@ -486,20 +482,18 @@ recycleFile :: ( MonadIO m
                )
             => FilePath
             -> m ()
-recycleFile fp = do
+recycleFile fp
-#if defined(IS_WINDOWS)
+  | isWindows = do
-  Dirs { recycleDir } <- getDirs
+      Dirs { recycleDir } <- getDirs
-  liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
+      liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
-  tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
+      tmp <- liftIO $ createTempDirectory recycleDir "recycleFile"
-  let dest = tmp </> takeFileName fp
+      let dest = tmp </> takeFileName fp
-  liftIO (Win32.moveFileEx fp (Just dest) 0)
+      liftIO (moveFile fp dest)
-    `catch`
+        `catch`
-      (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
+          (\e -> if isPermissionError e {- EXDEV on windows -} then recover (liftIO $ removePathForcibly fp) else throwIO e)
-    `finally`
+        `finally`
-      (liftIO $ handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+          liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-#else
+  | otherwise = liftIO $ removeFile fp
-  liftIO $ removeFile fp
-#endif
 
 
 rmFile :: ( MonadIO m
@@ -507,26 +501,19 @@ rmFile :: ( MonadIO m
           )
       => FilePath
       -> m ()
-rmFile fp =
+rmFile fp
-#if defined(IS_WINDOWS)
+  | isWindows = recover (liftIO $ removeFile fp)
-  recover (liftIO $ removeFile fp)
+  | otherwise = liftIO $ removeFile fp
-#else
-  liftIO $ removeFile fp
-#endif
 
 
 rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
                 => FilePath
                 -> m ()
-rmDirectoryLink fp = 
+rmDirectoryLink fp
-#if defined(IS_WINDOWS)
+  | isWindows = recover (liftIO $ removeDirectoryLink fp)
-  recover (liftIO $ removeDirectoryLink fp)
+  | otherwise = 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)
@@ -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
 
-
-

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
+  

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
+

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)
+