Update .gitignore

.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 app/ lib/ test/ 
+hlint -r lib/ test/ 
 

app/ghcup-gen/Main.hs

@@ -1,7 +1,10 @@
 {-# 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 (Linux UnknownLinux `notElem` pspecs) $ do
+    when (notElem (Linux UnknownLinux) pspecs) $ do
       lift $ logError $
         "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
       addError
-    when ((Darwin `notElem` pspecs) && arch == A_64) $ do
+    when ((notElem Darwin pspecs) && arch == A_64) $ do
       lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
       addError
-    when ((FreeBSD `notElem` pspecs) && arch == A_64) $ lift $ logWarn $
+    when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ logWarn $
       "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
-    when (Windows `notElem` pspecs && arch == A_64) $ do
+    when (notElem Windows 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 (Linux Alpine `notElem` pspecs) $
+    when (notElem (Linux Alpine) 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 = _viTags =<< M.elems (availableToolVersions dls tool)
+    let allTags = join $ fmap _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 = _viTags =<< M.elems (availableToolVersions dls tool)
+    let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
-    forM_ [Latest, Recommended] $ \t -> case t `elem` allTags of
+    forM_ [Latest, Recommended] $ \t -> case elem t 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" *> runReaderT addError ref
+  when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
   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
-              runReaderT addError ref
+              (flip runReaderT ref addError)
           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
-            unless (match regex basePath) $ do
+            when (not (match regex basePath)) $ do
               logError $
                 "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
-              runReaderT addError ref
+              (flip runReaderT ref addError)
           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)
-        runReaderT addError ref
+        (flip runReaderT ref addError)

app/ghcup/BrickMain.hs

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

app/ghcup/GHCup/OptParse.hs

@@ -1,7 +1,11 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 
 
@@ -105,7 +109,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'
@@ -115,6 +119,7 @@ opts =
             <> internal
             )
           )
+        )
     <*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
     <*> optional (option
           (eitherReader keepOnParser)
@@ -159,10 +164,11 @@ com =
       (  command
           "tui"
           (   (\_ -> Interactive)
-          <$> info
+          <$> (info
                 helper
                 (  progDesc "Start the interactive GHCup UI"
                 )
+              )
           )
       <>  command
 #else

app/ghcup/GHCup/OptParse/ChangeLog.hs

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

app/ghcup/GHCup/OptParse/Common.hs

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

app/ghcup/GHCup/OptParse/Compile.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -507,7 +508,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,6 +2,7 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -83,7 +84,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,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -103,7 +104,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,6 +2,7 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -274,7 +275,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.")
@@ -323,8 +324,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,7 +1,11 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -11,7 +15,6 @@ module GHCup.OptParse.List where
 
 
 import           GHCup
-import           GHCup.Utils.Prelude
 import           GHCup.Types
 import           GHCup.OptParse.Common
 
@@ -96,7 +99,7 @@ printListResult :: Bool -> Bool -> [ListResult] -> IO ()
 printListResult no_color raw lr = do
 
   let
-    color | raw || no_color = (\_ x -> x)
+    color | raw || no_color = flip const
           | otherwise       = Pretty.color
 
   let
@@ -116,16 +119,22 @@ printListResult no_color raw lr = do
         . fmap
             (\ListResult {..} ->
               let marks = if
-                    | lSet       -> (color Green (if isWindows then "IS" else "✔✔"))
+#if defined(IS_WINDOWS)
-                    | lInstalled -> (color Green (if isWindows then "I " else "✓ "))
+                    | lSet       -> (color Green "IS")
-                    | otherwise  -> (color Red   (if isWindows then "X " else "✗ "))
+                    | lInstalled -> (color Green "I ")
+                    | 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"]
@@ -142,10 +151,10 @@ printListResult no_color raw lr = do
         $ lr
   let cols =
         foldr (\xs ys -> zipWith (:) xs ys) (replicate (length rows) []) rows
-      lengths = fmap (maximum . fmap strWidth) cols
+      lengths = fmap maximum . (fmap . fmap) strWidth $ cols
       padded  = fmap (\xs -> zipWith padTo xs lengths) rows
 
-  forM_ padded $ \row -> putStrLn $ unwords row
+  forM_ padded $ \row -> putStrLn $ intercalate " " row
  where
 
   padTo str' x =

app/ghcup/GHCup/OptParse/Nuke.hs

@@ -3,6 +3,9 @@
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -46,7 +49,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,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -84,7 +85,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")
       )
       <>
@@ -117,7 +118,7 @@ prefetchP = subparser
       <>
      command
       "metadata"
-      (PrefetchMetadata <$ info
+      (const PrefetchMetadata <$> info
         helper
         ( progDesc "Download ghcup's metadata, needed for various operations")
       )
@@ -161,7 +162,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
@@ -196,20 +197,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,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -131,7 +132,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
@@ -151,7 +152,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,6 +2,8 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
@@ -40,7 +42,6 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import qualified Data.Text                     as T
 import Data.Bifunctor (second)
 import Control.Exception.Safe (MonadMask)
-import GHCup.Types.Optics
 
 
 
@@ -186,7 +187,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
@@ -200,7 +201,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
@@ -214,7 +215,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
@@ -228,7 +229,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
@@ -242,18 +243,15 @@ runSetStack runAppState =
     -------------------
 
 
-set :: forall m env.
+set :: forall m . ( Monad m
-       ( 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 env m (VEither eff GHCTargetVersion)
+    -> (forall eff . ReaderT LeanAppState m (VEither eff GHCTargetVersion)
         -> m (VEither eff GHCTargetVersion))
     -> (ReaderT LeanAppState m () -> m ())
     -> m ExitCode

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -2,6 +2,10 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -45,7 +49,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,6 +2,7 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -35,7 +36,6 @@ 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,6 +110,7 @@ unsetParser =
                  )
            )
       )
+    )
  where
   unsetGHCFooter :: String
   unsetGHCFooter = [s|Discussion:
@@ -155,7 +156,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
@@ -174,11 +175,9 @@ unset :: ( Monad m
          , MonadMask m
          , MonadUnliftIO m
          , MonadFail m
-         , HasDirs env
-         , HasLog env
          )
       => UnsetCommand
-      -> (ReaderT env m (VEither UnsetEffects ())
+      -> (ReaderT LeanAppState m (VEither UnsetEffects ())
           -> m (VEither UnsetEffects ()))
       -> (ReaderT LeanAppState m () -> m ())
       -> m ExitCode

app/ghcup/GHCup/OptParse/Upgrade.hs

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

app/ghcup/GHCup/OptParse/Whereis.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 {-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
 
@@ -112,7 +113,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
@@ -265,7 +266,7 @@ whereis :: ( Monad m
       -> (ReaderT LeanAppState m () -> m ())
       -> m ExitCode
 whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
-  Dirs{ .. }  <- runReaderT getDirs leanAppstate
+  VRight Dirs{ .. }  <- runAppState (VRight <$> getDirs)
   case (whereisCommand, whereisOptions) of
     (WhereisTool tool (Just (ToolVersion v)), WhereisOptions{..}) ->
       runLeanWhereIs leanAppstate (do
@@ -282,7 +283,7 @@ whereis whereisCommand whereisOptions runAppState leanAppstate runLogger = do
                 runLogger $ logError $ T.pack $ prettyShow e
                 pure $ ExitFailure 30
 
-    (WhereisTool tool whereVer, WhereisOptions{..}) -> do
+    (WhereisTool tool whereVer, WhereisOptions{..}) ->
       runWhereIs runAppState (do
         (v, _) <- liftE $ fromVersion whereVer tool
         loc <- liftE $ whereIsTool tool v

app/ghcup/Main.hs

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

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,7 +120,6 @@ 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
@@ -149,21 +148,16 @@ library
 
   if os(windows)
     cpp-options:   -DIS_WINDOWS
-    other-modules:
+    other-modules: GHCup.Utils.File.Windows
-      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
 
@@ -178,25 +172,23 @@ library
 
 executable ghcup
   main-is:            Main.hs
-  other-modules:
+  other-modules:      GHCup.OptParse.Install
-    GHCup.OptParse
+                      GHCup.OptParse.Common
-    GHCup.OptParse.ChangeLog
+                      GHCup.OptParse.Set
-    GHCup.OptParse.Common
+                      GHCup.OptParse.UnSet
-    GHCup.OptParse.Compile
+                      GHCup.OptParse.Rm
-    GHCup.OptParse.Config
+                      GHCup.OptParse.Compile
-    GHCup.OptParse.DInfo
+                      GHCup.OptParse.Config
-    GHCup.OptParse.GC
+                      GHCup.OptParse.Whereis
-    GHCup.OptParse.Install
+                      GHCup.OptParse.List
-    GHCup.OptParse.List
+                      GHCup.OptParse.DInfo
-    GHCup.OptParse.Nuke
+                      GHCup.OptParse.Upgrade
-    GHCup.OptParse.Prefetch
+                      GHCup.OptParse.ToolRequirements
-    GHCup.OptParse.Rm
+                      GHCup.OptParse.ChangeLog
-    GHCup.OptParse.Set
+                      GHCup.OptParse.Nuke
-    GHCup.OptParse.ToolRequirements
+                      GHCup.OptParse.Prefetch
-    GHCup.OptParse.UnSet
+                      GHCup.OptParse.GC
-    GHCup.OptParse.Upgrade
+                      GHCup.OptParse
-    GHCup.OptParse.Whereis
-
   hs-source-dirs:     app/ghcup
   default-language:   Haskell2010
   default-extensions:

lib/GHCup.hs

@@ -52,7 +52,9 @@ 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
@@ -94,6 +96,9 @@ 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)
@@ -334,35 +339,36 @@ installUnpackedGHC :: ( MonadReader env m
                    -> FilePath      -- ^ Path to install to
                    -> Version       -- ^ The GHC version
                    -> Excepts '[ProcessError] m ()
-installUnpackedGHC path inst ver
+installUnpackedGHC path inst ver = do
-  | isWindows = do
+#if defined(IS_WINDOWS)
-      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
-        moveFilePortable source dest
+    Win32.moveFile source dest
-        setModificationTime dest mtime
+    setModificationTime dest mtime
-  | otherwise = do
+#else
-      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
@@ -1141,17 +1147,15 @@ 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 isWindows
+#if defined(IS_WINDOWS)
-          then liftIO
+            -- On windows we need to be more permissive
-                 -- On windows we need to be more permissive
+            -- in case symlinks can't be created, be just
-                 -- in case symlinks can't be created, be just
+            -- give up here. This symlink isn't strictly necessary.
-                 -- give up here. This symlink isn't strictly necessary.
+            $ hideError permissionErrorType
-                 $ hideError permissionErrorType
+            $ hideError illegalOperationErrorType
-                 $ hideError illegalOperationErrorType
+#endif
-                 $ createDirectoryLink targetF fullF
+            $ createDirectoryLink targetF fullF
-          else liftIO
-                 $ createDirectoryLink targetF fullF
       _ -> pure ()
 
 unsetGHC :: ( MonadReader env m
@@ -1872,17 +1876,17 @@ rmGhcup = do
 
   unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
 
-  if isWindows
+#if defined(IS_WINDOWS)
-  then do
+  -- since it doesn't seem possible to delete a running exe on windows
-    -- since it doesn't seem possible to delete a running exe on windows
+  -- we move it to temp dir, to be deleted at next reboot
-    -- we move it to temp dir, to be deleted at next reboot
+  tempFilepath <- mkGhcupTmpDir
-    tempFilepath <- mkGhcupTmpDir
+  hideError UnsupportedOperation $
-    hideError UnsupportedOperation $
+            liftIO $ hideError NoSuchThing $
-              liftIO $ hideError NoSuchThing $
+            Win32.moveFileEx ghcupFilepath (Just (tempFilepath </> "ghcup")) 0
-              moveFile ghcupFilepath (tempFilepath </> "ghcup")
+#else
-  else
+  -- delete it.
-    -- delete it.
+  hideError doesNotExistErrorType $ rmFile ghcupFilepath
-    hideError doesNotExistErrorType $ rmFile ghcupFilepath
+#endif
 
   where
     handlePathNotPresent fp _err = do
@@ -1942,9 +1946,10 @@ rmGhcupDirs = do
 
   handleRm $ rmBinDir binDir
   handleRm $ rmDir recycleDir
-  when isWindows $ do
+#if defined(IS_WINDOWS)
-    logInfo $ "removing " <> T.pack (baseDir </> "msys64")
+  logInfo $ "removing " <> T.pack (baseDir </> "msys64")
-    handleRm $ rmPathForcibly (baseDir </> "msys64")
+  handleRm $ rmPathForcibly (baseDir </> "msys64")
+#endif
 
   handleRm $ removeEmptyDirsRecursive baseDir
 
@@ -1978,13 +1983,15 @@ rmGhcupDirs = do
         forM_ contents (deleteFile . (dir </>))
 
     rmBinDir :: (MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
-    rmBinDir binDir
+    rmBinDir binDir = do
-      | isWindows = removeDirIfEmptyOrIsSymlink binDir
+#if !defined(IS_WINDOWS)
-      | otherwise = do
+      isXDGStyle <- liftIO useXDG
-          isXDGStyle <- liftIO useXDG
+      if not isXDGStyle
-          if not isXDGStyle
+        then removeDirIfEmptyOrIsSymlink binDir
-            then removeDirIfEmptyOrIsSymlink binDir
+        else pure ()
-            else pure ()
+#else
+      removeDirIfEmptyOrIsSymlink binDir
+#endif
 
     reportRemainingFiles :: MonadIO m => FilePath -> m [FilePath]
     reportRemainingFiles dir = do
@@ -2304,9 +2311,11 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                        m
                        FilePath
   findHadrianFile workdir = do
-    let possible_files = if isWindows
+#if defined(IS_WINDOWS)
-                         then ((workdir </> "hadrian") </>) <$> ["build.bat"]
+    let possible_files = ((workdir </> "hadrian") </>) <$> ["build.bat"]
-                         else ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
+#else   
+    let possible_files = ((workdir </> "hadrian") </>) <$> ["build", "build.sh"]
+#endif
     exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f))
     case filter fst exsists of
       [] -> throwE HadrianNotFound
@@ -2480,7 +2489,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                       (\x -> ["--target=" <> T.unpack x])
                       (_tvTarget tver)
             ++ ["--prefix=" <> ghcdir]
-            ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
+#if defined(IS_WINDOWS)
+            ++ ["--enable-tarballs-autodownload"]
+#endif
             ++ fmap T.unpack aargs
             )
             (Just workdir)
@@ -2494,7 +2505,9 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
                    (\x -> ["--target=" <> T.unpack x])
                    (_tvTarget tver)
           ++ ["--prefix=" <> ghcdir]
-          ++ (if isWindows then ["--enable-tarballs-autodownload"] else [])
+#if defined(IS_WINDOWS)
+          ++ ["--enable-tarballs-autodownload"]
+#endif
           ++ fmap T.unpack aargs
           )
           (Just workdir)

lib/GHCup/Utils.hs

@@ -22,21 +22,13 @@ 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.Utils.Windows
-#else
-import GHCup.Utils.Posix
-#endif
 import           GHCup.Download
+#endif
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.Optics
@@ -59,6 +51,9 @@ 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
@@ -74,6 +69,11 @@ 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,17 +1000,50 @@ getVersionInfo v' tool =
 
 -- | The file extension for executables.
 exeExt :: String
-exeExt
+#if defined(IS_WINDOWS)
-  | isWindows = ".exe"
+exeExt = ".exe"
-  | otherwise = ""
+#else
+exeExt = ""
+#endif
 
 -- | The file extension for executables.
 exeExt' :: ByteString
-exeExt'
+#if defined(IS_WINDOWS)
-  | isWindows = ".exe"
+exeExt' = ".exe"
-  | otherwise = ""
+#else
+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
@@ -1019,27 +1052,33 @@ exeExt'
 -- On windows, we have to emulate symlinks via shims,
 -- see 'createLink'.
 getLinkTarget :: FilePath -> IO FilePath
-getLinkTarget fp
+getLinkTarget fp = do
-  | isWindows = do
+#if defined(IS_WINDOWS)
-      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
-  | otherwise = getSymbolicLinkTarget fp
+#else
+  getSymbolicLinkTarget fp
+#endif
 
 
 -- | Checks whether the path is a link.
 pathIsLink :: FilePath -> IO Bool
-pathIsLink fp
+#if defined(IS_WINDOWS)
-  | isWindows = doesPathExist (dropExtension fp <.> "shim")
+pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
-  | otherwise = pathIsSymbolicLink fp
+#else
+pathIsLink = pathIsSymbolicLink
+#endif
 
 
 rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m ()
-rmLink fp
+#if defined(IS_WINDOWS)
-  | isWindows = do
+rmLink fp = do
-      hideError doesNotExistErrorType . recycleFile $ fp
+  hideError doesNotExistErrorType . recycleFile $ fp
-      hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
+  hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim")
-  | otherwise = hideError doesNotExistErrorType . recycleFile $ fp
+#else
+rmLink = hideError doesNotExistErrorType . recycleFile
+#endif
 
 
 -- | Creates a symbolic link on unix and a fake symlink on windows for
@@ -1063,30 +1102,31 @@ createLink :: ( MonadMask m
            => FilePath      -- ^ path to the target executable
            -> FilePath      -- ^ path to be created
            -> m ()
-createLink link exe
+createLink link exe = do
-  | isWindows = do
+#if defined(IS_WINDOWS)
-      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
-  | otherwise = do
+#else
-      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
@@ -1101,20 +1141,23 @@ ensureGlobalTools :: ( MonadMask m
                      , MonadFail m
                      )
                   => Excepts '[GPGError, DigestError , DownloadFailed, NoDownload] m ()
-ensureGlobalTools
+ensureGlobalTools = do
-  | isWindows = do
+#if defined(IS_WINDOWS)
-      (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)
-  | otherwise = pure ()
+  pure ()
+#else
+  pure ()
+#endif
 
 
 -- | Ensure ghcup directory structure exists.

lib/GHCup/Utils/Dirs.hs

@@ -25,7 +25,9 @@ module GHCup.Utils.Dirs
   , relativeSymlink
   , withGHCupTmpDir
   , getConfigFilePath
+#if !defined(IS_WINDOWS)
   , useXDG
+#endif
   , cleanupTrash
   )
 where
@@ -73,25 +75,26 @@ 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
+ghcupBaseDir = do
-  | isWindows = do
+#if defined(IS_WINDOWS)
-      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")
-  | otherwise = do
+    else do
-      xdg <- useXDG
+      bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-      if xdg
+        Just r  -> pure r
-        then do
+        Nothing -> liftIO getHomeDirectory
-          bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
+      pure (bdir </> ".ghcup")
-            Just r  -> pure r
+#endif
-            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
@@ -99,41 +102,45 @@ ghcupBaseDir
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
 ghcupConfigDir :: IO FilePath
-ghcupConfigDir
+ghcupConfigDir = do
-  | isWindows = ghcupBaseDir
+#if defined(IS_WINDOWS)
-  | otherwise = do
+  ghcupBaseDir
-      xdg <- useXDG
+#else
-      if xdg
+  xdg <- useXDG
-        then do
+  if xdg
-          bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
+    then do
-            Just r  -> pure r
+      bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
-            Nothing -> do
+        Just r  -> pure r
-              home <- liftIO getHomeDirectory
+        Nothing -> do
-              pure (home </> ".config")
+          home <- liftIO getHomeDirectory
-          pure (bdir </> "ghcup")
+          pure (home </> ".config")
-        else do
+      pure (bdir </> "ghcup")
-          bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+    else do
-            Just r  -> pure r
+      bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-            Nothing -> liftIO getHomeDirectory
+        Just r  -> pure r
-          pure (bdir </> ".ghcup")
+        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
+ghcupBinDir = do
-  | isWindows = ghcupBaseDir <&> (</> "bin")
+#if defined(IS_WINDOWS)
-  | otherwise = do
+  ghcupBaseDir <&> (</> "bin")
-      xdg <- useXDG
+#else
-      if xdg
+  xdg <- useXDG
-        then do
+  if xdg
-          lookupEnv "XDG_BIN_HOME" >>= \case
+    then do
-            Just r  -> pure r
+      lookupEnv "XDG_BIN_HOME" >>= \case
-            Nothing -> do
+        Just r  -> pure r
-              home <- liftIO getHomeDirectory
+        Nothing -> do
-              pure (home </> ".local" </> "bin")
+          home <- liftIO getHomeDirectory
-        else ghcupBaseDir <&> (</> "bin")
+          pure (home </> ".local" </> "bin")
+    else ghcupBaseDir <&> (</> "bin")
+#endif
 
 
 -- | Defaults to '~/.ghcup/cache'.
@@ -141,19 +148,21 @@ ghcupBinDir
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
 ghcupCacheDir :: IO FilePath
-ghcupCacheDir
+ghcupCacheDir = do
-  | isWindows = ghcupBaseDir <&> (</> "cache")
+#if defined(IS_WINDOWS)
-  | otherwise = do
+  ghcupBaseDir <&> (</> "cache")
-      xdg <- useXDG
+#else
-      if xdg
+  xdg <- useXDG
-        then do
+  if xdg
-          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+    then do
-            Just r  -> pure r
+      bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
-            Nothing -> do
+        Just r  -> pure r
-              home <- liftIO getHomeDirectory
+        Nothing -> do
-              pure (home </> ".cache")
+          home <- liftIO getHomeDirectory
-          pure (bdir </> "ghcup")
+          pure (home </> ".cache")
-        else ghcupBaseDir <&> (</> "cache")
+      pure (bdir </> "ghcup")
+    else ghcupBaseDir <&> (</> "cache")
+#endif
 
 
 -- | Defaults to '~/.ghcup/logs'.
@@ -161,19 +170,21 @@ ghcupCacheDir
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
 ghcupLogsDir :: IO FilePath
-ghcupLogsDir
+ghcupLogsDir = do
-  | isWindows = ghcupBaseDir <&> (</> "logs")
+#if defined(IS_WINDOWS)
-  | otherwise = do
+  ghcupBaseDir <&> (</> "logs")
-      xdg <- useXDG
+#else
-      if xdg
+  xdg <- useXDG
-        then do
+  if xdg
-          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+    then do
-            Just r  -> pure r
+      bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
-            Nothing -> do
+        Just r  -> pure r
-              home <- liftIO getHomeDirectory
+        Nothing -> do
-              pure (home </> ".cache")
+          home <- liftIO getHomeDirectory
-          pure (bdir </> "ghcup" </> "logs")
+          pure (home </> ".cache")
-        else ghcupBaseDir <&> (</> "logs")
+      pure (bdir </> "ghcup" </> "logs")
+    else ghcupBaseDir <&> (</> "logs")
+#endif
 
 
 -- | '~/.ghcup/trash'.
@@ -309,8 +320,10 @@ 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

@@ -1,14 +0,0 @@
-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,25 +17,14 @@ Portability : portable
 
 GHCup specific prelude. Lots of Excepts functionality.
 -}
-module GHCup.Utils.Prelude
+module GHCup.Utils.Prelude where
-  (module GHCup.Utils.Prelude,
-#if defined(IS_WINDOWS)
-   module GHCup.Utils.Prelude.Windows
-#else
-   module GHCup.Utils.Prelude.Posix
-#endif
-  )
-where
 
+#if defined(IS_WINDOWS)
 import           GHCup.Types
+#endif
 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
@@ -56,13 +45,17 @@ 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
@@ -76,6 +69,9 @@ import qualified Data.Text.Lazy                as TL
 import qualified Data.Text.Lazy.Builder        as B
 import qualified Data.Text.Lazy.Builder.Int    as B
 import qualified Data.Text.Lazy.Encoding       as TLE
+#if defined(IS_WINDOWS)
+import qualified System.Win32.File             as Win32
+#endif
 
 
 -- $setup
@@ -442,17 +438,19 @@ recyclePathForcibly :: ( MonadIO m
                        )
                     => FilePath
                     -> m ()
-recyclePathForcibly fp
+recyclePathForcibly fp = do
-  | isWindows = do
+#if defined(IS_WINDOWS)
-      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 (moveFile fp dest)
+  liftIO (Win32.moveFileEx fp (Just dest) 0)
-          `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)
-  | otherwise = liftIO $ removePathForcibly fp
+#else
+  liftIO $ removePathForcibly fp
+#endif
 
 
 rmPathForcibly :: ( MonadIO m
@@ -460,17 +458,23 @@ rmPathForcibly :: ( MonadIO m
                   )
                => FilePath
                -> m ()
-rmPathForcibly fp
+rmPathForcibly fp =
-  | isWindows = recover (liftIO $ removePathForcibly fp)
+#if defined(IS_WINDOWS)
-  | otherwise = liftIO $ removePathForcibly fp
+  recover (liftIO $ removePathForcibly fp)
+#else
+  liftIO $ removePathForcibly fp
+#endif
 
 
 rmDirectory :: (MonadIO m, MonadMask m)
             => FilePath
             -> m ()
-rmDirectory fp
+rmDirectory fp =
-  | isWindows = recover (liftIO $ removeDirectory fp)
+#if defined(IS_WINDOWS)
-  | otherwise = liftIO $ removeDirectory fp
+  recover (liftIO $ removeDirectory fp)
+#else
+  liftIO $ removeDirectory fp
+#endif
 
 
 -- https://www.sqlite.org/src/info/89f1848d7f
@@ -482,18 +486,20 @@ recycleFile :: ( MonadIO m
                )
             => FilePath
             -> m ()
-recycleFile fp
+recycleFile fp = do
-  | isWindows = do
+#if defined(IS_WINDOWS)
-      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 (moveFile fp dest)
+  liftIO (Win32.moveFileEx fp (Just dest) 0)
-        `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)
-  | otherwise = liftIO $ removeFile fp
+#else
+  liftIO $ removeFile fp
+#endif
 
 
 rmFile :: ( MonadIO m
@@ -501,19 +507,26 @@ rmFile :: ( MonadIO m
           )
       => FilePath
       -> m ()
-rmFile fp
+rmFile fp =
-  | isWindows = recover (liftIO $ removeFile fp)
+#if defined(IS_WINDOWS)
-  | otherwise = liftIO $ removeFile fp
+  recover (liftIO $ removeFile fp)
+#else
+  liftIO $ removeFile fp
+#endif
 
 
 rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
                 => FilePath
                 -> m ()
-rmDirectoryLink fp
+rmDirectoryLink fp = 
-  | isWindows = recover (liftIO $ removeDirectoryLink fp)
+#if defined(IS_WINDOWS)
-  | otherwise = liftIO $ removeDirectoryLink fp
+  recover (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)
@@ -522,6 +535,7 @@ recover action =
     ,\_ -> Handler (\e -> pure (ioeGetErrorType e == UnsatisfiedConstraints))
     ]
     (\_ -> action)
+#endif
 
 
 copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Excepts xs m ()
@@ -738,3 +752,5 @@ breakOn needle haystack | needle `isPrefixOf` haystack = ([], haystack)
 breakOn _ [] = ([], [])
 breakOn needle (x:xs) = first (x:) $ breakOn needle xs
 
+
+

lib/GHCup/Utils/Prelude/Posix.hs

@@ -1,20 +0,0 @@
-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

@@ -1,17 +0,0 @@
-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

@@ -1,48 +0,0 @@
-{-# 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)
-