hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Drop monad-logger

Browse Source
This commit is contained in:
Julian Ospald
2021-08-30 22:41:58 +02:00
parent 3a7895e5ea
commit 13143b8e4d
19 changed files with 541 additions and 590 deletions
Download Patch File Download Diff File Expand all files Collapse all files

36
app/ghcup-gen/Main.hs
View File

@@ -11,20 +11,29 @@
module Main where
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
import Data.Char ( toLower )
#if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) )
#endif
import Options.Applicative hiding ( style )
import Haskus.Utils.Variant.Excepts
import System.Console.Pretty
import System.Exit
import System.IO ( stdout )
import System.IO ( stderr )
import Text.Regex.Posix
import Validate
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text.IO as T
import qualified Data.Text as T
import qualified Data.ByteString as B
import qualified Data.Yaml as Y
@@ -105,10 +114,27 @@ com = subparser
main :: IO ()
main = do
let loggerConfig = LoggerConfig { lcPrintDebug = True
, colorOutter = T.hPutStr stderr
, rawOutter = \_ -> pure ()
}
dirs <- liftIO getAllDirs
let leanAppstate = LeanAppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings loggerConfig
pfreq <- (
flip runReaderT leanAppstate . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
flip runReaderT leanAppstate $ logError $ T.pack $ prettyShow e
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq loggerConfig
_ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts validate
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter)
ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
pure ()
where
@@ -123,5 +149,5 @@ main = do
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of
Right r -> pure r
Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av gt)
f av gt
>>= exitWith

120
app/ghcup-gen/Validate.hs
View File

@@ -12,11 +12,9 @@ module Validate where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Platform
import GHCup.Types hiding ( LeanAppState (..) )
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ
import Codec.Archive
@@ -24,7 +22,6 @@ import Control.Applicative
import Control.Exception.Safe
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT )
@@ -39,12 +36,10 @@ import Haskus.Utils.Variant.Excepts
import Optics
import System.FilePath
import System.Exit
import System.IO
import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import qualified Data.Version as V
@@ -62,7 +57,7 @@ addError = do
liftIO $ modifyIORef ref (+ 1)
validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
validate :: (Monad m, MonadReader env m, HasLog env, MonadThrow m, MonadIO m, MonadUnliftIO m)
=> GHCupDownloads
-> M.Map GlobalTool DownloadInfo
-> m ExitCode
@@ -89,23 +84,23 @@ validate dls _ = do
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) "All good"
lift $ logInfo "All good"
pure ExitSuccess
where
checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v
arch' = prettyShow arch
when (notElem (Linux UnknownLinux) pspecs) $ do
lift $ $(logError) $
lift $ logError $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
when ((notElem Darwin pspecs) && arch == A_64) $ do
lift $ $(logError) $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
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 ((notElem FreeBSD 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
lift $ $(logError) $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError
-- alpine needs to be set explicitly, because
@@ -113,12 +108,12 @@ validate dls _ = do
-- (although it could be static)
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
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|]
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)) >> addError
GHC | Latest `elem` tags || Recommended `elem` tags
, arch `elem` [A_64, A_32] -> lift ($(logError) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
_ -> lift $ $(logWarn) $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
, arch `elem` [A_64, A_32] -> lift (logError $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch))
_ -> 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
@@ -138,7 +133,7 @@ validate dls _ = do
case join nonUnique of
[] -> pure ()
xs -> do
lift $ $(logError) $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
lift $ logError $ "Tags not unique for " <> T.pack (prettyShow tool) <> ": " <> T.pack (prettyShow xs)
addError
where
isUniqueTag Latest = True
@@ -154,7 +149,7 @@ validate dls _ = do
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure ()
_ -> do
lift $ $(logError) $ "GHC version " <> prettyVer v <> " is not valid"
lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
addError
-- a tool must have at least one of each mandatory tags
@@ -162,7 +157,7 @@ validate dls _ = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do
lift $ $(logError) $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
lift $ logError $ "Tag " <> T.pack (prettyShow t) <> " missing from " <> T.pack (prettyShow tool)
addError
True -> pure ()
@@ -171,7 +166,7 @@ validate dls _ = do
let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do
lift $ $(logError) $ "Base tag missing from GHC ver " <> prettyVer ver
lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
addError
True -> pure ()
@@ -184,7 +179,10 @@ data TarballFilter = TarballFilter
}
validateTarballs :: ( Monad m
, MonadLogger m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadThrow m
, MonadIO m
, MonadUnliftIO m
@@ -199,45 +197,37 @@ validateTarballs :: ( Monad m
validateTarballs (TarballFilter etool versionRegex) dls gt = do
ref <- liftIO $ newIORef 0
flip runReaderT ref $ do
-- download/verify all tarballs
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" *> addError
forM_ allDls downloadAll
-- download/verify all tarballs
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)
forM_ allDls (downloadAll ref)
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
lift $ $(logInfo) "All good"
pure ExitSuccess
-- exit
e <- liftIO $ readIORef ref
if e > 0
then pure $ ExitFailure e
else do
logInfo "All good"
pure ExitSuccess
where
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = \_ -> pure ()
}
downloadAll dli = do
dirs <- liftIO getAllDirs
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
lift $ runLogger
($(logError) $ T.pack $ prettyShow e)
liftIO $ exitWith (ExitFailure 2)
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
r <-
runLogger
. flip runReaderT appstate
. runResourceT
downloadAll :: ( MonadUnliftIO m
, MonadIO m
, MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadCatch m
, MonadMask m
, MonadThrow m
)
=> IORef Int
-> DownloadInfo
-> m ()
downloadAll ref dli = do
r <- runResourceT
. runE @'[DigestError
, DownloadFailed
, UnknownArchive
@@ -263,26 +253,26 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
VRight (Just basePath) -> do
case _dlSubdir dli of
Just (RealDir prel) -> do
lift $ $(logInfo)
logInfo
$ " verifying subdir: " <> T.pack prel
when (basePath /= prel) $ do
lift $ $(logError) $
logError $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
addError
(flip runReaderT ref addError)
Just (RegexDir regexString) -> do
lift $ $(logInfo) $
logInfo $
"verifying subdir (regex): " <> T.pack regexString
let regex = makeRegexOpts
compIgnoreCase
execBlank
regexString
when (not (match regex basePath)) $ do
lift $ $(logError) $
logError $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
addError
(flip runReaderT ref addError)
Nothing -> pure ()
VRight Nothing -> pure ()
VLeft e -> do
lift $ $(logError) $
logError $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e)
addError
(flip runReaderT ref addError)

55
app/ghcup/BrickMain.hs
View File

@@ -13,11 +13,11 @@ module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics hiding ( getGHCupInfo )
import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils
import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File
import GHCup.Utils.Logger
import Brick
import Brick.Widgets.Border
@@ -29,7 +29,6 @@ import Brick.Widgets.List ( listSelectedFocusedAttr
)
import Codec.Archive
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource
@@ -417,12 +416,8 @@ install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, Monad
install' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. runResourceT
runResourceT
. runE
@'[ AlreadyInstalled
, ArchiveResult
@@ -462,7 +457,7 @@ install' _ (_, ListResult {..}) = do
>>= \case
VRight vi -> do
forM_ (_viPostInstall =<< vi) $ \msg ->
myLoggerT l $ $(logInfo) msg
logInfo msg
pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
@@ -473,12 +468,9 @@ install' _ (_, ListResult {..}) = do
set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
flip runReaderT settings
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
run (do
@@ -501,9 +493,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif
del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
let run = myLoggerT l . runE @'[NotInstalled]
let run = runE @'[NotInstalled]
run (do
let vi = getVersionInfo lVer lTool dls
@@ -517,7 +507,7 @@ del' _ (_, ListResult {..}) = do
>>= \case
VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyShow e)
@@ -546,6 +536,10 @@ settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
newIORef $ AppState (Settings { cache = True
, noVerify = False
, keepDirs = Never
@@ -559,27 +553,14 @@ settings' = unsafePerformIO $ do
defaultKeyBindings
(GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing)
loggerConfig
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: AppState
-> LoggerConfig
-> IO ()
brickMain s l = do
brickMain s = do
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
no_color <- isJust <$> lookupEnv "NO_COLOR"
@@ -596,7 +577,7 @@ brickMain s l = do
)
$> ()
Left e -> do
runLogger ($(logError) $ "Error building app state: " <> T.pack (show e))
flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e)
exitWith $ ExitFailure 2
@@ -607,12 +588,9 @@ defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = Fal
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE
$ getDownloadsF
@@ -625,14 +603,11 @@ getGHCupInfo = do
getAppData :: Maybe GHCupInfo
-> IO (Either String BrickData)
getAppData mgi = runExceptT $ do
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
runLogger . flip runReaderT settings $ do
flip runReaderT settings $ do
lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV)

268
app/ghcup/Main.hs
View File

@@ -40,7 +40,6 @@ import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Aeson ( decodeStrict', Value )
@@ -1099,19 +1098,18 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
let loggerConfig = LoggerConfig
{ lcPrintDebug = False
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
loggerConfig
mGhcUpInfo <- runLogger . flip runReaderT appState . runE $ getDownloadsF
mGhcUpInfo <- flip runReaderT appState . runE $ getDownloadsF
case mGhcUpInfo of
VRight ghcupInfo -> do
let allTags = filter (\t -> t /= Old)
@@ -1131,14 +1129,14 @@ versionCompleter criteria tool = listIOCompleter $ do
, colorOutter = mempty
, rawOutter = mempty
}
let runLogger = myLoggerT loggerConfig
settings = Settings True False Never Curl False GHCupURL True
let settings = Settings True False Never Curl False GHCupURL True
let leanAppState = LeanAppState
settings
dirs'
defaultKeyBindings
mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF
loggerConfig
mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do
forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState
@@ -1147,8 +1145,9 @@ versionCompleter criteria tool = listIOCompleter $ do
defaultKeyBindings
ghcupInfo
pfreq
loggerConfig
runEnv = runLogger . flip runReaderT appState
runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ T.unpack . prettyVer . lVer <$> installedVersions
@@ -1435,18 +1434,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
(settings, keybindings) <- toSettings opt
-- logger interpreter
logfile <- flip runReaderT dirs $ initGHCupFileLogging
logfile <- flip runReaderT dirs initGHCupFileLogging
let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr
, colorOutter = T.hPutStr stderr
, rawOutter =
case optCommand of
Nuke -> \_ -> pure ()
_ -> B.appendFile logfile
_ -> T.appendFile logfile
}
let runLogger = myLoggerT loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () }
let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
let runLogger = flip runReaderT leanAppstate
let siletRunLogger = flip runReaderT (leanAppstate { loggerConfig = loggerConfig { colorOutter = \_ -> pure () } } :: LeanAppState)
-------------------------
@@ -1454,7 +1455,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-------------------------
let leanAppstate = LeanAppState settings dirs keybindings
appState = do
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
@@ -1462,12 +1462,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
ghcupInfo <-
( runLogger
. flip runReaderT leanAppstate
( flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE
$ getDownloadsF
@@ -1476,12 +1475,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2)
let s' = AppState settings dirs keybindings ghcupInfo pfreq
let s' = AppState settings dirs keybindings ghcupInfo pfreq loggerConfig
race_ (liftIO $ runLogger $ flip runReaderT dirs $ cleanupTrash)
(threadDelay 5000000 >> runLogger ($(logWarn) $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
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
Nuke -> pure ()
@@ -1493,7 +1492,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Interactive -> pure ()
#endif
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates
Nothing -> flip runReaderT s' checkForUpdates
Just _ -> pure ()
-- TODO: always run for windows
@@ -1501,7 +1500,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) $ T.pack $ prettyShow e)
(logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 30)
pure s'
@@ -1526,8 +1525,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runInstTool' appstate' mInstPlatform =
runLogger
. flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
flip runReaderT (maybe appstate' (\x -> appstate'{ pfreq = x } :: AppState) mInstPlatform)
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -1555,8 +1553,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanSetGHC =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
@@ -1566,8 +1563,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runSetGHC =
runLogger
. runAppState
runAppState
. runE
@'[ FileDoesNotExistError
, NotInstalled
@@ -1578,8 +1574,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanSetCabal =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1588,8 +1583,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runSetCabal =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1599,8 +1593,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runSetHLS =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1609,8 +1602,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runLeanSetHLS =
runLogger
. runLeanAppState
runLeanAppState
. runE
@'[ NotInstalled
, TagNotFound
@@ -1618,23 +1610,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet
]
let runListGHC = runLogger . runAppState
let runListGHC = runAppState
let runRm =
runLogger . runAppState . runE @'[NotInstalled]
runAppState . runE @'[NotInstalled]
let runNuke s' =
runLogger . flip runReaderT s' . runE @'[NotInstalled]
flip runReaderT s' . runE @'[NotInstalled]
let runDebugInfo =
runLogger
. runAppState
runAppState
. runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ AlreadyInstalled
@@ -1654,10 +1644,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let
runLeanWhereIs =
runLogger
-- Don't use runLeanAppState here, which is disabled on windows.
-- This is the only command on all platforms that doesn't need full appstate.
. flip runReaderT leanAppstate
flip runReaderT leanAppstate
. runE
@'[ NotInstalled
, NoToolVersionSet
@@ -1666,8 +1655,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
runWhereIs =
runLogger
. runAppState
runAppState
. runE
@'[ NotInstalled
, NoToolVersionSet
@@ -1676,8 +1664,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
let runUpgrade =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ DigestError
@@ -1689,8 +1676,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
let runPrefetch =
runLogger
. runAppState
runAppState
. runResourceT
. runE
@'[ TagNotFound
@@ -1728,25 +1714,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "GHC installation successful"
runLogger $ logInfo "GHC installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err)
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ (logError $ T.pack $ prettyShow err)
_ -> 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
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 3
@@ -1768,18 +1754,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "Cabal installation successful"
runLogger $ logInfo "Cabal installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"Cabal ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm cabal " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
let installHLS InstallOptions{..} =
@@ -1800,12 +1786,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "HLS installation successful"
runLogger $ logInfo "HLS installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"HLS ver "
<> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls "
@@ -1814,8 +1800,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
let installStack InstallOptions{..} =
@@ -1836,18 +1822,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight vi -> do
runLogger $ $(logInfo) "Stack installation successful"
runLogger $ logInfo "Stack installation successful"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"Stack ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft e -> do
runLogger $ do
$(logError) $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir
logError $ T.pack $ prettyShow e
logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4
@@ -1861,11 +1847,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 5
let setCabal' SetOptions{ sToolVer } =
@@ -1879,11 +1865,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setHLS' SetOptions{ sToolVer } =
@@ -1897,11 +1883,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"HLS " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let setStack' SetOptions{ sToolVer } =
@@ -1915,11 +1901,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight GHCTargetVersion{..} -> do
runLogger
$ $(logInfo) $
$ logInfo $
"Stack " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
@@ -1932,10 +1918,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 7
let rmCabal' tv =
@@ -1948,10 +1934,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmHLS' tv =
@@ -1964,10 +1950,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
let rmStack' tv =
@@ -1980,31 +1966,31 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
res <- case optCommand of
#if defined(BRICK)
Interactive -> do
s' <- appState
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess
liftIO $ brickMain s' >> pure ExitSuccess
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
runLogger (logWarn "This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.")
installGHC iopts
Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts
Install (Left (InstallStack iopts)) -> installStack iopts
InstallCabalLegacy iopts -> do
runLogger ($(logWarn) "This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.")
runLogger (logWarn "This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.")
installCabal iopts
Set (Right sopts) -> do
runLogger ($(logWarn) "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
setGHC' sopts
Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' sopts
@@ -2019,7 +2005,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
Rm (Right rmopts) -> do
runLogger ($(logWarn) "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
runLogger (logWarn "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
rmGHC' rmopts
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
@@ -2033,11 +2019,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStrLn $ prettyDebugInfo dinfo
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 8
Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do
runLogger $ $(logError) "Hadrian cross compile support is not yet implemented!"
runLogger $ logError "Hadrian cross compile support is not yet implemented!"
pure $ ExitFailure 9
Compile (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC (do
@@ -2046,8 +2032,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg
lift $ $(logInfo)
lift $ logInfo msg
lift $ logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure ()
@@ -2070,32 +2056,32 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
)
>>= \case
VRight (vi, tv) -> do
runLogger $ $(logInfo)
runLogger $ logInfo
"GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
putStr (T.unpack $ tVerToText tv)
pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $
runLogger $ logWarn $
"GHC ver " <> prettyVer v <> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm ghc " <> prettyVer v <> "' first"
pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of
Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <>
Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> 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 9
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9
Config InitConfig -> do
path <- getConfigFilePath
writeFile path $ formatConfig $ fromSettings settings (Just keybindings)
runLogger $ $(logDebug) $ "config.yaml initialized at " <> T.pack path
runLogger $ logDebug $ "config.yaml initialized at " <> T.pack path
pure ExitSuccess
Config ShowConfig -> do
@@ -2105,20 +2091,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Config (SetConfig k v) -> do
case v of
"" -> do
runLogger $ $(logError) "Empty values are not allowed"
runLogger $ logError "Empty values are not allowed"
pure $ ExitFailure 55
_ -> do
r <- runE @'[JSONError] $ do
settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
runLogger $ $(logDebug) $ T.pack $ show settings'
runLogger $ logDebug $ T.pack $ show settings'
pure ()
case r of
VRight _ -> pure ExitSuccess
VLeft (V (JSONDecodeError e)) -> do
runLogger $ $(logError) $ "Error decoding config: " <> T.pack e
runLogger $ logError $ "Error decoding config: " <> T.pack e
pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65
@@ -2134,7 +2120,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
@@ -2150,7 +2136,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStr r
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30
Upgrade uOpts force' -> do
@@ -2167,23 +2153,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight (v', dls) -> do
let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo) $
runLogger $ logInfo $
"Successfully upgraded GHCup to version " <> pretty_v
forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg
runLogger $ logInfo msg
pure ExitSuccess
VLeft (V NoUpdate) -> do
runLogger $ $(logWarn) "No GHCup update available"
runLogger $ logWarn "No GHCup update available"
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 11
ToolRequirements -> do
s' <- appState
flip runReaderT s'
$ runLogger
(runE
$ (runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do
GHCupInfo { .. } <- lift getGHCupInfo
@@ -2194,7 +2179,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case
VRight _ -> pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 12
ChangeLog ChangeLogOptions{..} -> do
@@ -2211,7 +2196,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case muri of
Nothing -> do
runLogger
($(logWarn) $
(logWarn $
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
)
pure ExitSuccess
@@ -2234,7 +2219,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing
>>= \case
Right _ -> pure ExitSuccess
Left e -> runLogger ($(logError) (T.pack $ prettyShow e))
Left e -> logError (T.pack $ prettyShow e)
>> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess
@@ -2242,12 +2227,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
s' <- liftIO appState
void $ liftIO $ evaluate $ force s'
runNuke s' (do
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ $logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
lift $ logWarn "WARNING: This will remove GHCup and all installed components from your system."
lift $ logWarn "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s
lift $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ $logInfo "Nuking in 3...2...1"
lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ logInfo "Nuking in 3...2...1"
lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
@@ -2258,15 +2243,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) >>= \case
VRight leftOverFiles
| null leftOverFiles -> do
runLogger $ $logInfo "Nuclear Annihilation complete!"
runLogger $ logInfo "Nuclear Annihilation complete!"
pure ExitSuccess
| otherwise -> do
runLogger $ $logError "These Files have survived Nuclear Annihilation, you may remove them manually."
runLogger $ logError "These Files have survived Nuclear Annihilation, you may remove them manually."
forM_ leftOverFiles putStrLn
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
Prefetch pfCom ->
runPrefetch (do
@@ -2297,7 +2282,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight _ -> do
pure ExitSuccess
VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15
@@ -2308,7 +2293,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure ()
fromVersion :: ( MonadLogger m
fromVersion :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
@@ -2326,7 +2311,7 @@ fromVersion :: ( MonadLogger m
] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion' :: ( MonadLogger m
fromVersion' :: ( HasLog env
, MonadFail m
, MonadReader env m
, HasGHCupInfo env
@@ -2572,11 +2557,10 @@ checkForUpdates :: ( MonadReader env m
, HasDirs env
, HasPlatformReq env
, MonadCatch m
, MonadLogger m
, HasLog env
, MonadThrow m
, MonadIO m
, MonadFail m
, MonadLogger m
)
=> m ()
checkForUpdates = do
@@ -2587,35 +2571,35 @@ checkForUpdates = do
forM_ (getLatest dls GHCup) $ \(l, _) -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
$ $(logWarn) $
$ logWarn $
"New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
forM_ (getLatest dls GHC) $ \(l, _) -> do
let mghc_ver = latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ $(logWarn) $
$ logWarn $
"New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
forM_ (getLatest dls Cabal) $ \(l, _) -> do
let mcabal_ver = latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ $(logWarn) $
$ logWarn $
"New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
forM_ (getLatest dls HLS) $ \(l, _) -> do
let mhls_ver = latestInstalled HLS
forM mhls_ver $ \hls_ver ->
when (l > hls_ver)
$ $(logWarn) $
$ logWarn $
"New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
forM_ (getLatest dls Stack) $ \(l, _) -> do
let mstack_ver = latestInstalled Stack
forM mstack_ver $ \stack_ver ->
when (l > stack_ver)
$ $(logWarn) $
$ logWarn $
"New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"