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

Drop monad-logger

This commit is contained in:
Julian Ospald 2021-08-30 22:41:58 +02:00
parent 3a7895e5ea
commit 13143b8e4d
Signed by: hasufell
GPG Key ID: 3786C5262ECB4A3F
19 changed files with 541 additions and 590 deletions
Show Stats 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 module Main where
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Errors
import GHCup.Platform
import GHCup.Utils.Dirs
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.Logger
import Control.Monad.Trans.Reader ( runReaderT )
import Control.Monad.IO.Class
import Data.Char ( toLower ) import Data.Char ( toLower )
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Data.Semigroup ( (<>) ) import Data.Semigroup ( (<>) )
#endif #endif
import Options.Applicative hiding ( style ) import Options.Applicative hiding ( style )
import Haskus.Utils.Variant.Excepts
import System.Console.Pretty import System.Console.Pretty
import System.Exit import System.Exit
import System.IO ( stdout ) import System.IO ( stderr )
import Text.Regex.Posix import Text.Regex.Posix
import Validate 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.ByteString as B
import qualified Data.Yaml as Y import qualified Data.Yaml as Y
@ -105,10 +114,27 @@ com = subparser
main :: IO () main :: IO ()
main = do 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) _ <- customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
>>= \Options {..} -> case optCommand of >>= \Options {..} -> case optCommand of
ValidateYAML vopts -> withValidateYamlOpts vopts validate ValidateYAML vopts -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validate dl m)
ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (validateTarballs tarballFilter) ValidateTarballs vopts tarballFilter -> withValidateYamlOpts vopts (\dl m -> flip runReaderT appstate $ validateTarballs tarballFilter dl m)
pure () pure ()
where where
@ -123,5 +149,5 @@ main = do
(GHCupInfo _ av gt) <- case Y.decodeEither' contents of (GHCupInfo _ av gt) <- case Y.decodeEither' contents of
Right r -> pure r Right r -> pure r
Left e -> die (color Red $ show e) Left e -> die (color Red $ show e)
myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av gt) f av gt
>>= exitWith >>= exitWith

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

@ -12,11 +12,9 @@ module Validate where
import GHCup import GHCup
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Platform import GHCup.Types
import GHCup.Types hiding ( LeanAppState (..) )
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.Logger
import GHCup.Utils.Version.QQ import GHCup.Utils.Version.QQ
import Codec.Archive import Codec.Archive
@ -24,7 +22,6 @@ import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader.Class import Control.Monad.Reader.Class
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Reader ( runReaderT ) import Control.Monad.Trans.Reader ( runReaderT )
@ -39,12 +36,10 @@ import Haskus.Utils.Variant.Excepts
import Optics import Optics
import System.FilePath import System.FilePath
import System.Exit import System.Exit
import System.IO
import Text.ParserCombinators.ReadP import Text.ParserCombinators.ReadP
import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.PrettyPrint.HughesPJClass ( prettyShow )
import Text.Regex.Posix import Text.Regex.Posix
import qualified Data.ByteString as B
import qualified Data.Map.Strict as M import qualified Data.Map.Strict as M
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Version as V import qualified Data.Version as V
@ -62,7 +57,7 @@ addError = do
liftIO $ modifyIORef ref (+ 1) 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 => GHCupDownloads
-> M.Map GlobalTool DownloadInfo -> M.Map GlobalTool DownloadInfo
-> m ExitCode -> m ExitCode
@ -89,23 +84,23 @@ validate dls _ = do
if e > 0 if e > 0
then pure $ ExitFailure e then pure $ ExitFailure e
else do else do
lift $ $(logInfo) "All good" lift $ logInfo "All good"
pure ExitSuccess pure ExitSuccess
where where
checkHasRequiredPlatforms t v tags arch pspecs = do checkHasRequiredPlatforms t v tags arch pspecs = do
let v' = prettyVer v let v' = prettyVer v
arch' = prettyShow arch arch' = prettyShow arch
when (notElem (Linux UnknownLinux) pspecs) $ do when (notElem (Linux UnknownLinux) pspecs) $ do
lift $ $(logError) $ lift $ logError $
"Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch' "Linux UnknownLinux missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError addError
when ((notElem Darwin 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' lift $ logError $ "Darwin missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError 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' "FreeBSD missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
when (notElem Windows 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' lift $ logError $ "Windows missing for for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack arch'
addError addError
-- alpine needs to be set explicitly, because -- alpine needs to be set explicitly, because
@ -113,12 +108,12 @@ validate dls _ = do
-- (although it could be static) -- (although it could be static)
when (notElem (Linux Alpine) pspecs) $ when (notElem (Linux Alpine) pspecs) $
case t of 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|] 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 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)) , 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) _ -> lift $ logWarn $ "Linux Alpine missing for " <> T.pack (prettyShow t) <> " " <> v' <> " " <> T.pack (prettyShow arch)
checkUniqueTags tool = do checkUniqueTags tool = do
let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
@ -138,7 +133,7 @@ validate dls _ = do
case join nonUnique of case join nonUnique of
[] -> pure () [] -> pure ()
xs -> do 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 addError
where where
isUniqueTag Latest = True isUniqueTag Latest = True
@ -154,7 +149,7 @@ validate dls _ = do
case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of case [ x | (x,"") <- readP_to_S V.parseVersion (T.unpack . prettyVer $ v) ] of
[_] -> pure () [_] -> pure ()
_ -> do _ -> do
lift $ $(logError) $ "GHC version " <> prettyVer v <> " is not valid" lift $ logError $ "GHC version " <> prettyVer v <> " is not valid"
addError addError
-- a tool must have at least one of each mandatory tags -- 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 let allTags = join $ fmap _viTags $ M.elems $ availableToolVersions dls tool
forM_ [Latest, Recommended] $ \t -> case elem t allTags of forM_ [Latest, Recommended] $ \t -> case elem t allTags of
False -> do 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 addError
True -> pure () True -> pure ()
@ -171,7 +166,7 @@ validate dls _ = do
let allTags = M.toList $ availableToolVersions dls GHC let allTags = M.toList $ availableToolVersions dls GHC
forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of forM allTags $ \(ver, _viTags -> tags) -> case any isBase tags of
False -> do False -> do
lift $ $(logError) $ "Base tag missing from GHC ver " <> prettyVer ver lift $ logError $ "Base tag missing from GHC ver " <> prettyVer ver
addError addError
True -> pure () True -> pure ()
@ -184,7 +179,10 @@ data TarballFilter = TarballFilter
} }
validateTarballs :: ( Monad m validateTarballs :: ( Monad m
, MonadLogger m , MonadReader env m
, HasLog env
, HasDirs env
, HasSettings env
, MonadThrow m , MonadThrow m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -199,45 +197,37 @@ validateTarballs :: ( Monad m
validateTarballs (TarballFilter etool versionRegex) dls gt = do validateTarballs (TarballFilter etool versionRegex) dls gt = do
ref <- liftIO $ newIORef 0 ref <- liftIO $ newIORef 0
flip runReaderT ref $ do -- download/verify all tarballs
-- 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 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 gdlis = nubOrd $ gt ^.. each let allDls = either (const gdlis) (const dlis) etool
let allDls = either (const gdlis) (const dlis) etool when (null allDls) $ logError "no tarballs selected by filter" *> (flip runReaderT ref addError)
when (null allDls) $ $(logError) "no tarballs selected by filter" *> addError forM_ allDls (downloadAll ref)
forM_ allDls downloadAll
-- exit -- exit
e <- liftIO $ readIORef ref e <- liftIO $ readIORef ref
if e > 0 if e > 0
then pure $ ExitFailure e then pure $ ExitFailure e
else do else do
lift $ $(logInfo) "All good" logInfo "All good"
pure ExitSuccess pure ExitSuccess
where where
runLogger = myLoggerT LoggerConfig { lcPrintDebug = True downloadAll :: ( MonadUnliftIO m
, colorOutter = B.hPut stderr , MonadIO m
, rawOutter = \_ -> pure () , MonadReader env m
} , HasLog env
downloadAll dli = do , HasDirs env
dirs <- liftIO getAllDirs , HasSettings env
, MonadCatch m
pfreq <- ( , MonadMask m
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest , MonadThrow m
) >>= \case )
VRight r -> pure r => IORef Int
VLeft e -> do -> DownloadInfo
lift $ runLogger -> m ()
($(logError) $ T.pack $ prettyShow e) downloadAll ref dli = do
liftIO $ exitWith (ExitFailure 2) r <- runResourceT
let appstate = AppState (Settings True False Never Curl True GHCupURL False) dirs defaultKeyBindings (GHCupInfo mempty mempty mempty) pfreq
r <-
runLogger
. flip runReaderT appstate
. runResourceT
. runE @'[DigestError . runE @'[DigestError
, DownloadFailed , DownloadFailed
, UnknownArchive , UnknownArchive
@ -263,26 +253,26 @@ validateTarballs (TarballFilter etool versionRegex) dls gt = do
VRight (Just basePath) -> do VRight (Just basePath) -> do
case _dlSubdir dli of case _dlSubdir dli of
Just (RealDir prel) -> do Just (RealDir prel) -> do
lift $ $(logInfo) logInfo
$ " verifying subdir: " <> T.pack prel $ " verifying subdir: " <> T.pack prel
when (basePath /= prel) $ do when (basePath /= prel) $ do
lift $ $(logError) $ logError $
"Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath "Subdir doesn't match: expected " <> T.pack prel <> ", got " <> T.pack basePath
addError (flip runReaderT ref addError)
Just (RegexDir regexString) -> do Just (RegexDir regexString) -> do
lift $ $(logInfo) $ logInfo $
"verifying subdir (regex): " <> T.pack regexString "verifying subdir (regex): " <> T.pack regexString
let regex = makeRegexOpts let regex = makeRegexOpts
compIgnoreCase compIgnoreCase
execBlank execBlank
regexString regexString
when (not (match regex basePath)) $ do when (not (match regex basePath)) $ do
lift $ $(logError) $ logError $
"Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath "Subdir doesn't match: expected regex " <> T.pack regexString <> ", got " <> T.pack basePath
addError (flip runReaderT ref addError)
Nothing -> pure () Nothing -> pure ()
VRight Nothing -> pure () VRight Nothing -> pure ()
VLeft e -> do VLeft e -> do
lift $ $(logError) $ logError $
"Could not download (or verify hash) of " <> T.pack (show dli) <> ", Error was: " <> T.pack (prettyShow e) "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
import GHCup.Download import GHCup.Download
import GHCup.Errors import GHCup.Errors
import GHCup.Types.Optics hiding ( getGHCupInfo )
import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Types hiding ( LeanAppState(..) )
import GHCup.Utils import GHCup.Utils
import GHCup.Utils.Prelude ( decUTF8Safe ) import GHCup.Utils.Prelude ( decUTF8Safe )
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Logger
import Brick import Brick
import Brick.Widgets.Border import Brick.Widgets.Border
@ -29,7 +29,6 @@ import Brick.Widgets.List ( listSelectedFocusedAttr
) )
import Codec.Archive import Codec.Archive
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Except import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
@ -417,12 +416,8 @@ install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, Monad
install' _ (_, ListResult {..}) = do install' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
let run = let run =
runLogger runResourceT
. runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
, ArchiveResult , ArchiveResult
@ -462,7 +457,7 @@ install' _ (_, ListResult {..}) = do
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
myLoggerT l $ $(logInfo) msg logInfo msg
pure $ Right () pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right () VLeft (V NoUpdate) -> pure $ Right ()
@ -473,12 +468,9 @@ install' _ (_, ListResult {..}) = do
set' :: BrickState -> (Int, ListResult) -> IO (Either String ()) set' :: BrickState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do set' _ (_, ListResult {..}) = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run = let run =
runLogger flip runReaderT settings
. flip runReaderT settings
. runE @'[FileDoesNotExistError , NotInstalled , TagNotFound] . runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
run (do run (do
@ -501,9 +493,7 @@ del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnlif
del' _ (_, ListResult {..}) = do del' _ (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
l <- liftIO $ readIORef logger' let run = runE @'[NotInstalled]
let runLogger = myLoggerT l
let run = myLoggerT l . runE @'[NotInstalled]
run (do run (do
let vi = getVersionInfo lVer lTool dls let vi = getVersionInfo lVer lTool dls
@ -517,7 +507,7 @@ del' _ (_, ListResult {..}) = do
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (join $ fmap _viPostRemove vi) $ \msg -> forM_ (join $ fmap _viPostRemove vi) $ \msg ->
runLogger $ $(logInfo) msg logInfo msg
pure $ Right () pure $ Right ()
VLeft e -> pure $ Left (prettyShow e) VLeft e -> pure $ Left (prettyShow e)
@ -546,6 +536,10 @@ settings' :: IORef AppState
{-# NOINLINE settings' #-} {-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do settings' = unsafePerformIO $ do
dirs <- getAllDirs dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
newIORef $ AppState (Settings { cache = True newIORef $ AppState (Settings { cache = True
, noVerify = False , noVerify = False
, keepDirs = Never , keepDirs = Never
@ -559,27 +553,14 @@ settings' = unsafePerformIO $ do
defaultKeyBindings defaultKeyBindings
(GHCupInfo mempty mempty mempty) (GHCupInfo mempty mempty mempty)
(PlatformRequest A_64 Darwin Nothing) (PlatformRequest A_64 Darwin Nothing)
loggerConfig
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: AppState brickMain :: AppState
-> LoggerConfig
-> IO () -> IO ()
brickMain s l = do brickMain s = do
writeIORef settings' s writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
no_color <- isJust <$> lookupEnv "NO_COLOR" no_color <- isJust <$> lookupEnv "NO_COLOR"
@ -596,7 +577,7 @@ brickMain s l = do
) )
$> () $> ()
Left e -> 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 exitWith $ ExitFailure 2
@ -607,12 +588,9 @@ defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = Fal
getGHCupInfo :: IO (Either String GHCupInfo) getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do getGHCupInfo = do
settings <- readIORef settings' settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <- r <-
runLogger flip runReaderT settings
. flip runReaderT settings
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError] . runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
$ liftE $ liftE
$ getDownloadsF $ getDownloadsF
@ -625,14 +603,11 @@ getGHCupInfo = do
getAppData :: Maybe GHCupInfo getAppData :: Maybe GHCupInfo
-> IO (Either String BrickData) -> IO (Either String BrickData)
getAppData mgi = runExceptT $ do getAppData mgi = runExceptT $ do
l <- liftIO $ readIORef logger'
let runLogger = myLoggerT l
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r }) liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings' settings <- liftIO $ readIORef settings'
runLogger . flip runReaderT settings $ do flip runReaderT settings $ do
lV <- listVersions Nothing Nothing lV <- listVersions Nothing Nothing
pure $ BrickData (reverse lV) 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) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Data.Aeson ( decodeStrict', Value ) import Data.Aeson ( decodeStrict', Value )
@ -1099,19 +1098,18 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
tagCompleter :: Tool -> [String] -> Completer tagCompleter :: Tool -> [String] -> Completer
tagCompleter tool add = listIOCompleter $ do tagCompleter tool add = listIOCompleter $ do
dirs' <- liftIO getAllDirs dirs' <- liftIO getAllDirs
let appState = LeanAppState
(Settings True False Never Curl False GHCupURL True)
dirs'
defaultKeyBindings
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = False { lcPrintDebug = False
, colorOutter = mempty , colorOutter = mempty
, rawOutter = 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 case mGhcUpInfo of
VRight ghcupInfo -> do VRight ghcupInfo -> do
let allTags = filter (\t -> t /= Old) let allTags = filter (\t -> t /= Old)
@ -1131,14 +1129,14 @@ versionCompleter criteria tool = listIOCompleter $ do
, colorOutter = mempty , colorOutter = mempty
, rawOutter = mempty , rawOutter = mempty
} }
let runLogger = myLoggerT loggerConfig let settings = Settings True False Never Curl False GHCupURL True
settings = Settings True False Never Curl False GHCupURL True
let leanAppState = LeanAppState let leanAppState = LeanAppState
settings settings
dirs' dirs'
defaultKeyBindings defaultKeyBindings
mpFreq <- runLogger . flip runReaderT leanAppState . runE $ platformRequest loggerConfig
mGhcUpInfo <- runLogger . flip runReaderT leanAppState . runE $ getDownloadsF mpFreq <- flip runReaderT leanAppState . runE $ platformRequest
mGhcUpInfo <- flip runReaderT leanAppState . runE $ getDownloadsF
forFold mpFreq $ \pfreq -> do forFold mpFreq $ \pfreq -> do
forFold mGhcUpInfo $ \ghcupInfo -> do forFold mGhcUpInfo $ \ghcupInfo -> do
let appState = AppState let appState = AppState
@ -1147,8 +1145,9 @@ versionCompleter criteria tool = listIOCompleter $ do
defaultKeyBindings defaultKeyBindings
ghcupInfo ghcupInfo
pfreq pfreq
loggerConfig
runEnv = runLogger . flip runReaderT appState runEnv = flip runReaderT appState
installedVersions <- runEnv $ listVersions (Just tool) criteria installedVersions <- runEnv $ listVersions (Just tool) criteria
return $ T.unpack . prettyVer . lVer <$> installedVersions 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 (settings, keybindings) <- toSettings opt
-- logger interpreter -- logger interpreter
logfile <- flip runReaderT dirs $ initGHCupFileLogging logfile <- flip runReaderT dirs initGHCupFileLogging
let loggerConfig = LoggerConfig let loggerConfig = LoggerConfig
{ lcPrintDebug = verbose settings { lcPrintDebug = verbose settings
, colorOutter = B.hPut stderr , colorOutter = T.hPutStr stderr
, rawOutter = , rawOutter =
case optCommand of case optCommand of
Nuke -> \_ -> pure () Nuke -> \_ -> pure ()
_ -> B.appendFile logfile _ -> T.appendFile logfile
} }
let runLogger = myLoggerT loggerConfig let leanAppstate = LeanAppState settings dirs keybindings loggerConfig
let siletRunLogger = myLoggerT loggerConfig { colorOutter = \_ -> pure () } 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 appState = do
pfreq <- ( pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest 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 VRight r -> pure r
VLeft e -> do VLeft e -> do
runLogger runLogger
($(logError) $ T.pack $ prettyShow e) (logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2) exitWith (ExitFailure 2)
ghcupInfo <- ghcupInfo <-
( runLogger ( flip runReaderT leanAppstate
. flip runReaderT leanAppstate
. runE @'[JSONError , DownloadFailed, FileDoesNotExistError] . runE @'[JSONError , DownloadFailed, FileDoesNotExistError]
$ liftE $ liftE
$ getDownloadsF $ getDownloadsF
@ -1476,12 +1475,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight r -> pure r VRight r -> pure r
VLeft e -> do VLeft e -> do
runLogger runLogger
($(logError) $ T.pack $ prettyShow e) (logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 2) 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) 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")) (threadDelay 5000000 >> runLogger (logWarn $ "Killing cleanup thread (exceeded 5s timeout)... please remove leftover files in " <> T.pack recycleDir <> " manually"))
case optCommand of case optCommand of
Nuke -> pure () Nuke -> pure ()
@ -1493,7 +1492,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Interactive -> pure () Interactive -> pure ()
#endif #endif
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case _ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
Nothing -> runLogger $ flip runReaderT s' $ checkForUpdates Nothing -> flip runReaderT s' checkForUpdates
Just _ -> pure () Just _ -> pure ()
-- TODO: always run for windows -- TODO: always run for windows
@ -1501,7 +1500,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight _ -> pure () VRight _ -> pure ()
VLeft e -> do VLeft e -> do
runLogger runLogger
($(logError) $ T.pack $ prettyShow e) (logError $ T.pack $ prettyShow e)
exitWith (ExitFailure 30) exitWith (ExitFailure 30)
pure s' pure s'
@ -1526,8 +1525,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runInstTool' appstate' mInstPlatform = 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 . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -1555,8 +1553,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runLeanSetGHC = runLeanSetGHC =
runLogger runLeanAppState
. runLeanAppState
. runE . runE
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
@ -1566,8 +1563,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
runSetGHC = runSetGHC =
runLogger runAppState
. runAppState
. runE . runE
@'[ FileDoesNotExistError @'[ FileDoesNotExistError
, NotInstalled , NotInstalled
@ -1578,8 +1574,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runLeanSetCabal = runLeanSetCabal =
runLogger runLeanAppState
. runLeanAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1588,8 +1583,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
runSetCabal = runSetCabal =
runLogger runAppState
. runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1599,8 +1593,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runSetHLS = runSetHLS =
runLogger runAppState
. runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1609,8 +1602,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
runLeanSetHLS = runLeanSetHLS =
runLogger runLeanAppState
. runLeanAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, TagNotFound , TagNotFound
@ -1618,23 +1610,21 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, NoToolVersionSet , NoToolVersionSet
] ]
let runListGHC = runLogger . runAppState let runListGHC = runAppState
let runRm = let runRm =
runLogger . runAppState . runE @'[NotInstalled] runAppState . runE @'[NotInstalled]
let runNuke s' = let runNuke s' =
runLogger . flip runReaderT s' . runE @'[NotInstalled] flip runReaderT s' . runE @'[NotInstalled]
let runDebugInfo = let runDebugInfo =
runLogger runAppState
. runAppState
. runE . runE
@'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound] @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
let runCompileGHC = let runCompileGHC =
runLogger runAppState
. runAppState
. runResourceT . runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
@ -1654,10 +1644,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let let
runLeanWhereIs = runLeanWhereIs =
runLogger
-- Don't use runLeanAppState here, which is disabled on windows. -- Don't use runLeanAppState here, which is disabled on windows.
-- This is the only command on all platforms that doesn't need full appstate. -- This is the only command on all platforms that doesn't need full appstate.
. flip runReaderT leanAppstate flip runReaderT leanAppstate
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, NoToolVersionSet , NoToolVersionSet
@ -1666,8 +1655,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
runWhereIs = runWhereIs =
runLogger runAppState
. runAppState
. runE . runE
@'[ NotInstalled @'[ NotInstalled
, NoToolVersionSet , NoToolVersionSet
@ -1676,8 +1664,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
let runUpgrade = let runUpgrade =
runLogger runAppState
. runAppState
. runResourceT . runResourceT
. runE . runE
@'[ DigestError @'[ DigestError
@ -1689,8 +1676,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
] ]
let runPrefetch = let runPrefetch =
runLogger runAppState
. runAppState
. runResourceT . runResourceT
. runE . runE
@'[ TagNotFound @'[ TagNotFound
@ -1728,25 +1714,25 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ $(logInfo) "GHC installation successful" runLogger $ logInfo "GHC installation successful"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do 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" "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 pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of case keepDirs settings of
Never -> myLoggerT loggerConfig $ ($(logError) $ T.pack $ prettyShow err) Never -> runLogger $ (logError $ T.pack $ prettyShow err)
_ -> myLoggerT loggerConfig $ ($(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" <> "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.") "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 3 pure $ ExitFailure 3
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 3 pure $ ExitFailure 3
@ -1768,18 +1754,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ $(logInfo) "Cabal installation successful" runLogger $ logInfo "Cabal installation successful"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do 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" "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 pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4 pure $ ExitFailure 4
let installHLS InstallOptions{..} = let installHLS InstallOptions{..} =
@ -1800,12 +1786,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ $(logInfo) "HLS installation successful" runLogger $ logInfo "HLS installation successful"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do VLeft (V (AlreadyInstalled _ v)) -> do
runLogger $ $(logWarn) $ runLogger $ logWarn $
"HLS ver " "HLS ver "
<> prettyVer v <> prettyVer v
<> " already installed; if you really want to reinstall it, you may want to run 'ghcup rm hls " <> " 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 pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4 pure $ ExitFailure 4
let installStack InstallOptions{..} = let installStack InstallOptions{..} =
@ -1836,18 +1822,18 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) )
>>= \case >>= \case
VRight vi -> do VRight vi -> do
runLogger $ $(logInfo) "Stack installation successful" runLogger $ logInfo "Stack installation successful"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do 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" "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 pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ do runLogger $ do
$(logError) $ T.pack $ prettyShow e logError $ T.pack $ prettyShow e
$(logError) $ "Also check the logs in " <> T.pack logsDir logError $ "Also check the logs in " <> T.pack logsDir
pure $ ExitFailure 4 pure $ ExitFailure 4
@ -1861,11 +1847,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ $(logInfo) $ $ logInfo $
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget "GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 5 pure $ ExitFailure 5
let setCabal' SetOptions{ sToolVer } = let setCabal' SetOptions{ sToolVer } =
@ -1879,11 +1865,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ $(logInfo) $ $ logInfo $
"Cabal " <> prettyVer _tvVersion <> " successfully set as default version" "Cabal " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let setHLS' SetOptions{ sToolVer } = let setHLS' SetOptions{ sToolVer } =
@ -1897,11 +1883,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ $(logInfo) $ $ logInfo $
"HLS " <> prettyVer _tvVersion <> " successfully set as default version" "HLS " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let setStack' SetOptions{ sToolVer } = let setStack' SetOptions{ sToolVer } =
@ -1915,11 +1901,11 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight GHCTargetVersion{..} -> do VRight GHCTargetVersion{..} -> do
runLogger runLogger
$ $(logInfo) $ $ logInfo $
"Stack " <> prettyVer _tvVersion <> " successfully set as default version" "Stack " <> prettyVer _tvVersion <> " successfully set as default version"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14 pure $ ExitFailure 14
let rmGHC' RmOptions{..} = let rmGHC' RmOptions{..} =
@ -1932,10 +1918,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg -> forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 7 pure $ ExitFailure 7
let rmCabal' tv = let rmCabal' tv =
@ -1948,10 +1934,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg -> forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15 pure $ ExitFailure 15
let rmHLS' tv = let rmHLS' tv =
@ -1964,10 +1950,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg -> forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15 pure $ ExitFailure 15
let rmStack' tv = let rmStack' tv =
@ -1980,31 +1966,31 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight vi -> do VRight vi -> do
forM_ (_viPostRemove =<< vi) $ \msg -> forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15 pure $ ExitFailure 15
res <- case optCommand of res <- case optCommand of
#if defined(BRICK) #if defined(BRICK)
Interactive -> do Interactive -> do
s' <- appState s' <- appState
liftIO $ brickMain s' loggerConfig >> pure ExitSuccess liftIO $ brickMain s' >> pure ExitSuccess
#endif #endif
Install (Right iopts) -> do 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 installGHC iopts
Install (Left (InstallGHC iopts)) -> installGHC iopts Install (Left (InstallGHC iopts)) -> installGHC iopts
Install (Left (InstallCabal iopts)) -> installCabal iopts Install (Left (InstallCabal iopts)) -> installCabal iopts
Install (Left (InstallHLS iopts)) -> installHLS iopts Install (Left (InstallHLS iopts)) -> installHLS iopts
Install (Left (InstallStack iopts)) -> installStack iopts Install (Left (InstallStack iopts)) -> installStack iopts
InstallCabalLegacy iopts -> do 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 installCabal iopts
Set (Right sopts) -> do 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 setGHC' sopts
Set (Left (SetGHC sopts)) -> setGHC' sopts Set (Left (SetGHC sopts)) -> setGHC' sopts
Set (Left (SetCabal sopts)) -> setCabal' 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 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 rmGHC' rmopts
Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
Rm (Left (RmCabal rmopts)) -> rmCabal' 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 putStrLn $ prettyDebugInfo dinfo
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 8 pure $ ExitFailure 8
Compile (CompileGHC GHCCompileOptions { hadrian = True, crossTarget = Just _ }) -> do 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 pure $ ExitFailure 9
Compile (CompileGHC GHCCompileOptions {..}) -> Compile (CompileGHC GHCCompileOptions {..}) ->
runCompileGHC (do runCompileGHC (do
@ -2046,8 +2032,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
let vi = getVersionInfo targetVer GHC dls let vi = getVersionInfo targetVer GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do forM_ (_viPreCompile =<< vi) $ \msg -> do
lift $ $(logInfo) msg lift $ logInfo msg
lift $ $(logInfo) lift $ logInfo
"...waiting for 5 seconds, you can still abort..." "...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
Right _ -> pure () Right _ -> pure ()
@ -2070,32 +2056,32 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) )
>>= \case >>= \case
VRight (vi, tv) -> do VRight (vi, tv) -> do
runLogger $ $(logInfo) runLogger $ logInfo
"GHC successfully compiled and installed" "GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg -> forM_ (_viPostInstall =<< vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
putStr (T.unpack $ tVerToText tv) putStr (T.unpack $ tVerToText tv)
pure ExitSuccess pure ExitSuccess
VLeft (V (AlreadyInstalled _ v)) -> do 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" "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 pure ExitSuccess
VLeft err@(V (BuildFailed tmpdir _)) -> do VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs settings of case keepDirs settings of
Never -> myLoggerT loggerConfig $ $(logError) $ T.pack $ prettyShow err Never -> runLogger $ logError $ T.pack $ prettyShow err
_ -> myLoggerT loggerConfig $ ($(logError) $ T.pack (prettyShow err) <> "\n" <> _ -> runLogger $ (logError $ T.pack (prettyShow err) <> "\n" <>
"Check the logs at " <> T.pack logsDir <> " and the build directory " "Check the logs at " <> T.pack logsDir <> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n" <> <> T.pack tmpdir <> " for more clues." <> "\n" <>
"Make sure to clean up " <> T.pack tmpdir <> " afterwards.") "Make sure to clean up " <> T.pack tmpdir <> " afterwards.")
pure $ ExitFailure 9 pure $ ExitFailure 9
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 9 pure $ ExitFailure 9
Config InitConfig -> do Config InitConfig -> do
path <- getConfigFilePath path <- getConfigFilePath
writeFile path $ formatConfig $ fromSettings settings (Just keybindings) 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 pure ExitSuccess
Config ShowConfig -> do Config ShowConfig -> do
@ -2105,20 +2091,20 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Config (SetConfig k v) -> do Config (SetConfig k v) -> do
case v of case v of
"" -> do "" -> do
runLogger $ $(logError) "Empty values are not allowed" runLogger $ logError "Empty values are not allowed"
pure $ ExitFailure 55 pure $ ExitFailure 55
_ -> do _ -> do
r <- runE @'[JSONError] $ do r <- runE @'[JSONError] $ do
settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings settings' <- updateSettings (UTF8.fromString (k <> ": " <> v <> "\n")) settings
path <- liftIO getConfigFilePath path <- liftIO getConfigFilePath
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings) liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
runLogger $ $(logDebug) $ T.pack $ show settings' runLogger $ logDebug $ T.pack $ show settings'
pure () pure ()
case r of case r of
VRight _ -> pure ExitSuccess VRight _ -> pure ExitSuccess
VLeft (V (JSONDecodeError e)) -> do VLeft (V (JSONDecodeError e)) -> do
runLogger $ $(logError) $ "Error decoding config: " <> T.pack e runLogger $ logError $ "Error decoding config: " <> T.pack e
pure $ ExitFailure 65 pure $ ExitFailure 65
VLeft _ -> pure $ ExitFailure 65 VLeft _ -> pure $ ExitFailure 65
@ -2134,7 +2120,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStr r putStr r
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30 pure $ ExitFailure 30
Whereis WhereisOptions{..} (WhereisTool tool whereVer) -> Whereis WhereisOptions{..} (WhereisTool tool whereVer) ->
@ -2150,7 +2136,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
putStr r putStr r
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 30 pure $ ExitFailure 30
Upgrade uOpts force' -> do Upgrade uOpts force' -> do
@ -2167,23 +2153,22 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight (v', dls) -> do VRight (v', dls) -> do
let pretty_v = prettyVer v' let pretty_v = prettyVer v'
let vi = fromJust $ snd <$> getLatest dls GHCup let vi = fromJust $ snd <$> getLatest dls GHCup
runLogger $ $(logInfo) $ runLogger $ logInfo $
"Successfully upgraded GHCup to version " <> pretty_v "Successfully upgraded GHCup to version " <> pretty_v
forM_ (_viPostInstall vi) $ \msg -> forM_ (_viPostInstall vi) $ \msg ->
runLogger $ $(logInfo) msg runLogger $ logInfo msg
pure ExitSuccess pure ExitSuccess
VLeft (V NoUpdate) -> do VLeft (V NoUpdate) -> do
runLogger $ $(logWarn) "No GHCup update available" runLogger $ logWarn "No GHCup update available"
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 11 pure $ ExitFailure 11
ToolRequirements -> do ToolRequirements -> do
s' <- appState s' <- appState
flip runReaderT s' flip runReaderT s'
$ runLogger $ (runE
(runE
@'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements] @'[NoCompatiblePlatform , DistroNotFound , NoToolRequirements]
$ do $ do
GHCupInfo { .. } <- lift getGHCupInfo GHCupInfo { .. } <- lift getGHCupInfo
@ -2194,7 +2179,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
>>= \case >>= \case
VRight _ -> pure ExitSuccess VRight _ -> pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 12 pure $ ExitFailure 12
ChangeLog ChangeLogOptions{..} -> do ChangeLog ChangeLogOptions{..} -> do
@ -2211,7 +2196,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
case muri of case muri of
Nothing -> do Nothing -> do
runLogger runLogger
($(logWarn) $ (logWarn $
"Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver' "Could not find ChangeLog for " <> T.pack (prettyShow tool) <> ", version " <> either prettyVer (T.pack . show) ver'
) )
pure ExitSuccess pure ExitSuccess
@ -2234,7 +2219,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
Nothing Nothing
>>= \case >>= \case
Right _ -> pure ExitSuccess Right _ -> pure ExitSuccess
Left e -> runLogger ($(logError) (T.pack $ prettyShow e)) Left e -> logError (T.pack $ prettyShow e)
>> pure (ExitFailure 13) >> pure (ExitFailure 13)
else putStrLn uri' >> pure ExitSuccess else putStrLn uri' >> pure ExitSuccess
@ -2242,12 +2227,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
s' <- liftIO appState s' <- liftIO appState
void $ liftIO $ evaluate $ force s' void $ liftIO $ evaluate $ force s'
runNuke s' (do runNuke s' (do
lift $ $logWarn "WARNING: This will remove GHCup and all installed components from your system." 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 "Waiting 10 seconds before commencing, if you want to cancel it, now would be the time."
liftIO $ threadDelay 10000000 -- wait 10s liftIO $ threadDelay 10000000 -- wait 10s
lift $ $logInfo "Initiating Nuclear Sequence 🚀🚀🚀" lift $ logInfo "Initiating Nuclear Sequence 🚀🚀🚀"
lift $ $logInfo "Nuking in 3...2...1" lift $ logInfo "Nuking in 3...2...1"
lInstalled <- lift $ listVersions Nothing (Just ListInstalled) lInstalled <- lift $ listVersions Nothing (Just ListInstalled)
@ -2258,15 +2243,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
) >>= \case ) >>= \case
VRight leftOverFiles VRight leftOverFiles
| null leftOverFiles -> do | null leftOverFiles -> do
runLogger $ $logInfo "Nuclear Annihilation complete!" runLogger $ logInfo "Nuclear Annihilation complete!"
pure ExitSuccess pure ExitSuccess
| otherwise -> do | 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 forM_ leftOverFiles putStrLn
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15 pure $ ExitFailure 15
Prefetch pfCom -> Prefetch pfCom ->
runPrefetch (do runPrefetch (do
@ -2297,7 +2282,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
VRight _ -> do VRight _ -> do
pure ExitSuccess pure ExitSuccess
VLeft e -> do VLeft e -> do
runLogger $ $(logError) $ T.pack $ prettyShow e runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 15 pure $ ExitFailure 15
@ -2308,7 +2293,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure () pure ()
fromVersion :: ( MonadLogger m fromVersion :: ( HasLog env
, MonadFail m , MonadFail m
, MonadReader env m , MonadReader env m
, HasGHCupInfo env , HasGHCupInfo env
@ -2326,7 +2311,7 @@ fromVersion :: ( MonadLogger m
] m (GHCTargetVersion, Maybe VersionInfo) ] m (GHCTargetVersion, Maybe VersionInfo)
fromVersion tv = fromVersion' (toSetToolVer tv) fromVersion tv = fromVersion' (toSetToolVer tv)
fromVersion' :: ( MonadLogger m fromVersion' :: ( HasLog env
, MonadFail m , MonadFail m
, MonadReader env m , MonadReader env m
, HasGHCupInfo env , HasGHCupInfo env
@ -2572,11 +2557,10 @@ checkForUpdates :: ( MonadReader env m
, HasDirs env , HasDirs env
, HasPlatformReq env , HasPlatformReq env
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
, MonadLogger m
) )
=> m () => m ()
checkForUpdates = do checkForUpdates = do
@ -2587,35 +2571,35 @@ checkForUpdates = do
forM_ (getLatest dls GHCup) $ \(l, _) -> do forM_ (getLatest dls GHCup) $ \(l, _) -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver) when (l > ghc_ver)
$ $(logWarn) $ $ logWarn $
"New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'" "New GHCup version available: " <> prettyVer l <> ". To upgrade, run 'ghcup upgrade'"
forM_ (getLatest dls GHC) $ \(l, _) -> do forM_ (getLatest dls GHC) $ \(l, _) -> do
let mghc_ver = latestInstalled GHC let mghc_ver = latestInstalled GHC
forM mghc_ver $ \ghc_ver -> forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver) when (l > ghc_ver)
$ $(logWarn) $ $ logWarn $
"New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'" "New GHC version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install ghc " <> prettyVer l <> "'"
forM_ (getLatest dls Cabal) $ \(l, _) -> do forM_ (getLatest dls Cabal) $ \(l, _) -> do
let mcabal_ver = latestInstalled Cabal let mcabal_ver = latestInstalled Cabal
forM mcabal_ver $ \cabal_ver -> forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver) when (l > cabal_ver)
$ $(logWarn) $ $ logWarn $
"New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'" "New Cabal version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install cabal " <> prettyVer l <> "'"
forM_ (getLatest dls HLS) $ \(l, _) -> do forM_ (getLatest dls HLS) $ \(l, _) -> do
let mhls_ver = latestInstalled HLS let mhls_ver = latestInstalled HLS
forM mhls_ver $ \hls_ver -> forM mhls_ver $ \hls_ver ->
when (l > hls_ver) when (l > hls_ver)
$ $(logWarn) $ $ logWarn $
"New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'" "New HLS version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install hls " <> prettyVer l <> "'"
forM_ (getLatest dls Stack) $ \(l, _) -> do forM_ (getLatest dls Stack) $ \(l, _) -> do
let mstack_ver = latestInstalled Stack let mstack_ver = latestInstalled Stack
forM mstack_ver $ \stack_ver -> forM mstack_ver $ \stack_ver ->
when (l > stack_ver) when (l > stack_ver)
$ $(logWarn) $ $ logWarn $
"New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'" "New Stack version available: " <> prettyVer l <> ". To upgrade, run 'ghcup install stack " <> prettyVer l <> "'"

2
cabal.ghc8107.project
View File

@ -16,7 +16,7 @@ source-repository-package
source-repository-package source-repository-package
type: git type: git
location: https://github.com/hasufell/libarchive location: https://github.com/hasufell/libarchive
tag: 024a7e8ab7b4d3848dc64dca1e70a04831eedc99 tag: 8587aab78dd515928024ecd82c8f215e06db85cd
constraints: http-io-streams -brotli constraints: http-io-streams -brotli

34
cabal.ghc8107.project.freeze
View File

@ -22,7 +22,6 @@ constraints: any.Cabal ==3.2.1.0,
async -bench, async -bench,
any.attoparsec ==0.13.2.5, any.attoparsec ==0.13.2.5,
attoparsec -developer, attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.14.3.0, any.base ==4.14.3.0,
any.base-compat ==0.11.2, any.base-compat ==0.11.2,
any.base-compat-batteries ==0.11.2, any.base-compat-batteries ==0.11.2,
@ -32,14 +31,12 @@ constraints: any.Cabal ==3.2.1.0,
any.bifunctors ==5.5.11, any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged, bifunctors +semigroups +tagged,
any.binary ==0.8.8.0, any.binary ==0.8.8.0,
any.bindings-DSL ==1.0.25,
any.blaze-builder ==0.4.2.1, any.blaze-builder ==0.4.2.1,
any.brick ==0.64, any.brick ==0.64,
brick -demos, brick -demos,
any.bytestring ==0.10.12.0, any.bytestring ==0.10.12.0,
any.bz2 ==1.0.1.0, any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib, bz2 -cross +with-bzlib,
any.bzlib-conduit ==0.3.0.2,
any.c2hs ==0.28.8, any.c2hs ==0.28.8,
c2hs +base3 -regression, c2hs +base3 -regression,
any.cabal-plan ==0.7.2.0, any.cabal-plan ==0.7.2.0,
@ -47,8 +44,6 @@ constraints: any.Cabal ==3.2.1.0,
any.call-stack ==0.4.0, any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0, any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1, any.casing ==0.1.4.1,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.chs-cabal ==0.1.1.0, any.chs-cabal ==0.1.1.0,
any.chs-deps ==0.1.0.0, any.chs-deps ==0.1.0.0,
chs-deps -cross, chs-deps -cross,
@ -61,8 +56,6 @@ constraints: any.Cabal ==3.2.1.0,
composition-prelude -development, composition-prelude -development,
any.concurrent-output ==1.10.12, any.concurrent-output ==1.10.12,
any.conduit ==1.3.4.1, any.conduit ==1.3.4.1,
any.conduit-extra ==1.3.5,
any.conduit-zstd ==0.0.2.0,
any.config-ini ==0.2.4.0, any.config-ini ==0.2.4.0,
config-ini -enable-doctests, config-ini -enable-doctests,
any.containers ==0.6.5.1, any.containers ==0.6.5.1,
@ -74,21 +67,15 @@ constraints: any.Cabal ==3.2.1.0,
any.cryptohash-sha256 ==0.11.102.0, any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits, cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.1.2.3, any.data-clist ==0.1.2.3,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.2, any.data-fix ==0.3.2,
any.deepseq ==1.4.4.0, any.deepseq ==1.4.4.0,
any.digest ==0.0.1.3,
digest -bytestring-in-base,
any.directory ==1.3.6.0, any.directory ==1.3.6.0,
any.disk-free-space ==0.1.0.1, any.disk-free-space ==0.1.0.1,
any.distributive ==0.6.2.1, any.distributive ==0.6.2.1,
distributive +semigroups +tagged, distributive +semigroups +tagged,
any.dlist ==1.0, any.dlist ==1.0,
dlist -werror, dlist -werror,
any.easy-file ==0.2.2,
any.exceptions ==0.10.4, any.exceptions ==0.10.4,
any.extra ==1.7.9,
any.fast-logger ==3.0.5,
any.filepath ==1.4.2.1, any.filepath ==1.4.2.1,
any.free ==5.1.7, any.free ==5.1.7,
any.generic-arbitrary ==0.1.0, any.generic-arbitrary ==0.1.0,
@ -124,25 +111,17 @@ constraints: any.Cabal ==3.2.1.0,
libarchive -cross -low-memory -system-libarchive, libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2, any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml, libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.lzma-static ==5.2.5.4, any.lzma-static ==5.2.5.4,
any.megaparsec ==9.0.1, any.megaparsec ==9.0.1,
megaparsec -dev, megaparsec -dev,
any.microlens ==0.4.12.0, any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.1, any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.10, any.microlens-th ==0.4.3.10,
any.monad-control ==1.0.3.1,
any.monad-logger ==0.3.36,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1, any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2, any.mtl ==2.2.2,
any.network ==3.1.2.2, any.network ==3.1.2.2,
network -devel, network -devel,
any.network-uri ==2.6.4.1, any.network-uri ==2.6.4.1,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.3.0, any.openssl-streams ==1.2.3.0,
any.optics ==0.4, any.optics ==0.4,
any.optics-core ==0.4, any.optics-core ==0.4,
@ -184,9 +163,6 @@ constraints: any.Cabal ==3.2.1.0,
any.splitmix ==0.1.0.3, any.splitmix ==0.1.0.3,
splitmix -optimised-mixer, splitmix -optimised-mixer,
any.stm ==2.5.0.1, any.stm ==2.5.0.1,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.strict ==0.4.0.1, any.strict ==0.4.0.1,
strict +assoc, strict +assoc,
any.strict-base ==0.4.0.0, any.strict-base ==0.4.0.0,
@ -214,12 +190,10 @@ constraints: any.Cabal ==3.2.1.0,
transformers-base +orphaninstances, transformers-base +orphaninstances,
any.transformers-compat ==0.7, any.transformers-compat ==0.7,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.1,
any.unix ==2.7.2.2, any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3, any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.3, any.unix-compat ==0.5.3,
unix-compat -old-time, unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1, any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.14.0, any.unordered-containers ==0.2.14.0,
unordered-containers -debug, unordered-containers -debug,
@ -238,11 +212,7 @@ constraints: any.Cabal ==3.2.1.0,
any.xor ==0.0.1.0, any.xor ==0.0.1.0,
any.yaml ==0.11.5.0, any.yaml ==0.11.5.0,
yaml +no-examples +no-exe, yaml +no-examples +no-exe,
any.zip ==1.7.1,
zip -dev -disable-bzip2 -disable-zstd,
any.zlib ==0.6.2.3, any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5, any.zlib-bindings ==0.1.1.5
any.zstd ==0.1.2.0, index-state: hackage.haskell.org 2021-08-29T16:24:29Z
zstd +standalone
index-state: hackage.haskell.org 2021-08-24T16:50:39Z

2
cabal.ghc901.project
View File

@ -16,7 +16,7 @@ source-repository-package
source-repository-package source-repository-package
type: git type: git
location: https://github.com/hasufell/libarchive location: https://github.com/hasufell/libarchive
tag: 024a7e8ab7b4d3848dc64dca1e70a04831eedc99 tag: 8587aab78dd515928024ecd82c8f215e06db85cd
constraints: http-io-streams -brotli constraints: http-io-streams -brotli

34
cabal.ghc901.project.freeze
View File

@ -22,7 +22,6 @@ constraints: any.Cabal ==3.4.0.0,
async -bench, async -bench,
any.attoparsec ==0.13.2.5, any.attoparsec ==0.13.2.5,
attoparsec -developer, attoparsec -developer,
any.auto-update ==0.1.6,
any.base ==4.15.0.0, any.base ==4.15.0.0,
any.base-compat ==0.11.2, any.base-compat ==0.11.2,
any.base-compat-batteries ==0.11.2, any.base-compat-batteries ==0.11.2,
@ -32,14 +31,12 @@ constraints: any.Cabal ==3.4.0.0,
any.bifunctors ==5.5.11, any.bifunctors ==5.5.11,
bifunctors +semigroups +tagged, bifunctors +semigroups +tagged,
any.binary ==0.8.8.0, any.binary ==0.8.8.0,
any.bindings-DSL ==1.0.25,
any.blaze-builder ==0.4.2.1, any.blaze-builder ==0.4.2.1,
any.brick ==0.64, any.brick ==0.64,
brick -demos, brick -demos,
any.bytestring ==0.10.12.1, any.bytestring ==0.10.12.1,
any.bz2 ==1.0.1.0, any.bz2 ==1.0.1.0,
bz2 -cross +with-bzlib, bz2 -cross +with-bzlib,
any.bzlib-conduit ==0.3.0.2,
any.c2hs ==0.28.8, any.c2hs ==0.28.8,
c2hs +base3 -regression, c2hs +base3 -regression,
any.cabal-plan ==0.7.2.0, any.cabal-plan ==0.7.2.0,
@ -47,8 +44,6 @@ constraints: any.Cabal ==3.4.0.0,
any.call-stack ==0.4.0, any.call-stack ==0.4.0,
any.case-insensitive ==1.2.1.0, any.case-insensitive ==1.2.1.0,
any.casing ==0.1.4.1, any.casing ==0.1.4.1,
any.cereal ==0.5.8.1,
cereal -bytestring-builder,
any.chs-cabal ==0.1.1.0, any.chs-cabal ==0.1.1.0,
any.chs-deps ==0.1.0.0, any.chs-deps ==0.1.0.0,
chs-deps -cross, chs-deps -cross,
@ -61,8 +56,6 @@ constraints: any.Cabal ==3.4.0.0,
composition-prelude -development, composition-prelude -development,
any.concurrent-output ==1.10.12, any.concurrent-output ==1.10.12,
any.conduit ==1.3.4.1, any.conduit ==1.3.4.1,
any.conduit-extra ==1.3.5,
any.conduit-zstd ==0.0.2.0,
any.config-ini ==0.2.4.0, any.config-ini ==0.2.4.0,
config-ini -enable-doctests, config-ini -enable-doctests,
any.containers ==0.6.4.1, any.containers ==0.6.4.1,
@ -74,21 +67,15 @@ constraints: any.Cabal ==3.4.0.0,
any.cryptohash-sha256 ==0.11.102.0, any.cryptohash-sha256 ==0.11.102.0,
cryptohash-sha256 -exe +use-cbits, cryptohash-sha256 -exe +use-cbits,
any.data-clist ==0.1.2.3, any.data-clist ==0.1.2.3,
any.data-default-class ==0.1.2.0,
any.data-fix ==0.3.2, any.data-fix ==0.3.2,
any.deepseq ==1.4.5.0, any.deepseq ==1.4.5.0,
any.digest ==0.0.1.3,
digest -bytestring-in-base,
any.directory ==1.3.6.1, any.directory ==1.3.6.1,
any.disk-free-space ==0.1.0.1, any.disk-free-space ==0.1.0.1,
any.distributive ==0.6.2.1, any.distributive ==0.6.2.1,
distributive +semigroups +tagged, distributive +semigroups +tagged,
any.dlist ==1.0, any.dlist ==1.0,
dlist -werror, dlist -werror,
any.easy-file ==0.2.2,
any.exceptions ==0.10.4, any.exceptions ==0.10.4,
any.extra ==1.7.9,
any.fast-logger ==3.0.5,
any.filepath ==1.4.2.1, any.filepath ==1.4.2.1,
any.free ==5.1.7, any.free ==5.1.7,
any.generic-arbitrary ==0.1.0, any.generic-arbitrary ==0.1.0,
@ -124,25 +111,17 @@ constraints: any.Cabal ==3.4.0.0,
libarchive -cross -low-memory -system-libarchive, libarchive -cross -low-memory -system-libarchive,
any.libyaml ==0.1.2, any.libyaml ==0.1.2,
libyaml -no-unicode -system-libyaml, libyaml -no-unicode -system-libyaml,
any.lifted-base ==0.2.3.12,
any.lzma-static ==5.2.5.4, any.lzma-static ==5.2.5.4,
any.megaparsec ==9.0.1, any.megaparsec ==9.0.1,
megaparsec -dev, megaparsec -dev,
any.microlens ==0.4.12.0, any.microlens ==0.4.12.0,
any.microlens-mtl ==0.2.0.1, any.microlens-mtl ==0.2.0.1,
any.microlens-th ==0.4.3.10, any.microlens-th ==0.4.3.10,
any.monad-control ==1.0.3.1,
any.monad-logger ==0.3.36,
monad-logger +template_haskell,
any.monad-loops ==0.4.3,
monad-loops +base4,
any.mono-traversable ==1.0.15.1, any.mono-traversable ==1.0.15.1,
any.mtl ==2.2.2, any.mtl ==2.2.2,
any.network ==3.1.2.2, any.network ==3.1.2.2,
network -devel, network -devel,
any.network-uri ==2.6.4.1, any.network-uri ==2.6.4.1,
any.old-locale ==1.0.0.7,
any.old-time ==1.1.0.3,
any.openssl-streams ==1.2.3.0, any.openssl-streams ==1.2.3.0,
any.optics ==0.4, any.optics ==0.4,
any.optics-core ==0.4, any.optics-core ==0.4,
@ -184,9 +163,6 @@ constraints: any.Cabal ==3.4.0.0,
any.splitmix ==0.1.0.3, any.splitmix ==0.1.0.3,
splitmix -optimised-mixer, splitmix -optimised-mixer,
any.stm ==2.5.0.0, any.stm ==2.5.0.0,
any.stm-chans ==3.0.0.4,
any.streaming-commons ==0.2.2.1,
streaming-commons -use-bytestring-builder,
any.strict ==0.4.0.1, any.strict ==0.4.0.1,
strict +assoc, strict +assoc,
any.strict-base ==0.4.0.0, any.strict-base ==0.4.0.0,
@ -214,12 +190,10 @@ constraints: any.Cabal ==3.4.0.0,
transformers-base +orphaninstances, transformers-base +orphaninstances,
any.transformers-compat ==0.7, any.transformers-compat ==0.7,
transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, transformers-compat -five +five-three -four +generic-deriving +mtl -three -two,
any.typed-process ==0.2.6.1,
any.unix ==2.7.2.2, any.unix ==2.7.2.2,
any.unix-bytestring ==0.3.7.3, any.unix-bytestring ==0.3.7.3,
any.unix-compat ==0.5.3, any.unix-compat ==0.5.3,
unix-compat -old-time, unix-compat -old-time,
any.unix-time ==0.4.7,
any.unliftio-core ==0.2.0.1, any.unliftio-core ==0.2.0.1,
any.unordered-containers ==0.2.14.0, any.unordered-containers ==0.2.14.0,
unordered-containers -debug, unordered-containers -debug,
@ -238,11 +212,7 @@ constraints: any.Cabal ==3.4.0.0,
any.xor ==0.0.1.0, any.xor ==0.0.1.0,
any.yaml ==0.11.5.0, any.yaml ==0.11.5.0,
yaml +no-examples +no-exe, yaml +no-examples +no-exe,
any.zip ==1.7.1,
zip -dev -disable-bzip2 -disable-zstd,
any.zlib ==0.6.2.3, any.zlib ==0.6.2.3,
zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, zlib -bundled-c-zlib -non-blocking-ffi -pkg-config,
any.zlib-bindings ==0.1.1.5, any.zlib-bindings ==0.1.1.5
any.zstd ==0.1.2.0, index-state: hackage.haskell.org 2021-08-29T16:24:29Z
zstd +standalone
index-state: hackage.haskell.org 2021-08-24T16:50:39Z

3
ghcup.cabal
View File

@ -110,7 +110,6 @@ library
, libarchive ^>=3.0.0.0 , libarchive ^>=3.0.0.0
, lzma-static ^>=5.2.5.3 , lzma-static ^>=5.2.5.3
, megaparsec >=8.0.0 && <9.1 , megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2 , mtl ^>=2.2
, optics ^>=0.4 , optics ^>=0.4
, os-release ^>=1.0.0 , os-release ^>=1.0.0
@ -197,7 +196,6 @@ executable ghcup
, haskus-utils-variant >=3.0 && <3.2 , haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.0.0 , libarchive ^>=3.0.0.0
, megaparsec >=8.0.0 && <9.1 , megaparsec >=8.0.0 && <9.1
, monad-logger ^>=0.3.31
, mtl ^>=2.2 , mtl ^>=2.2
, optparse-applicative >=0.15.1.0 && <0.17 , optparse-applicative >=0.15.1.0 && <0.17
, pretty ^>=1.1.3.1 , pretty ^>=1.1.3.1
@ -259,7 +257,6 @@ executable ghcup-gen
, ghcup , ghcup
, haskus-utils-variant >=3.0 && <3.2 , haskus-utils-variant >=3.0 && <3.2
, libarchive ^>=3.0.0.0 , libarchive ^>=3.0.0.0
, monad-logger ^>=0.3.31
, mtl ^>=2.2 , mtl ^>=2.2
, optics ^>=0.4 , optics ^>=0.4
, optparse-applicative >=0.15.1.0 && <0.17 , optparse-applicative >=0.15.1.0 && <0.17

213
lib/GHCup.hs
View File

@ -48,7 +48,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
@ -111,7 +110,7 @@ fetchToolBindist :: ( MonadFail m
, HasSettings env , HasSettings env
, HasPlatformReq env , HasPlatformReq env
, HasGHCupInfo env , HasGHCupInfo env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -139,7 +138,7 @@ fetchGHCSrc :: ( MonadFail m
, HasSettings env , HasSettings env
, HasPlatformReq env , HasPlatformReq env
, HasGHCupInfo env , HasGHCupInfo env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -176,7 +175,7 @@ installGHCBindist :: ( MonadFail m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, HasPlatformReq env , HasPlatformReq env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -201,7 +200,7 @@ installGHCBindist :: ( MonadFail m
installGHCBindist dlinfo ver isoFilepath = do installGHCBindist dlinfo ver isoFilepath = do
let tver = mkTVer ver let tver = mkTVer ver
lift $ $(logDebug) $ "Requested to install GHC with " <> prettyVer ver lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver
case isoFilepath of case isoFilepath of
-- we only care for already installed errors in regular (non-isolated) installs -- we only care for already installed errors in regular (non-isolated) installs
@ -218,7 +217,7 @@ installGHCBindist dlinfo ver isoFilepath = do
case isoFilepath of case isoFilepath of
Just isoDir -> do -- isolated install Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing GHC to " <> T.pack isoDir lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir
liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver liftE $ installPackedGHC dl (view dlSubdir dlinfo) isoDir ver
Nothing -> do -- regular install Nothing -> do -- regular install
liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver liftE $ installPackedGHC dl (view dlSubdir dlinfo) ghcdir ver
@ -232,9 +231,9 @@ installGHCBindist dlinfo ver isoFilepath = do
case catMaybes r of case catMaybes r of
[] -> pure () [] -> pure ()
_ -> do _ -> do
lift $ $(logWarn) "CC/LD environment variable is set. This will change the compiler/linker" lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker"
lift $ $(logWarn) "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda" <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda"
lift $ $(logWarn) "environments). If you encounter problems, unset CC and LD and reinstall." <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall."
-- | Install a packed GHC distribution. This only deals with unpacking and the GHC -- | Install a packed GHC distribution. This only deals with unpacking and the GHC
@ -246,7 +245,7 @@ installPackedGHC :: ( MonadMask m
, HasPlatformReq env , HasPlatformReq env
, HasSettings env , HasSettings env
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
@ -304,7 +303,7 @@ installUnpackedGHC :: ( MonadReader env m
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
, MonadMask m , MonadMask m
@ -315,7 +314,7 @@ installUnpackedGHC :: ( MonadReader env m
-> Excepts '[ProcessError] m () -> Excepts '[ProcessError] m ()
installUnpackedGHC path inst ver = do installUnpackedGHC path inst ver = do
#if defined(IS_WINDOWS) #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.
@ -332,7 +331,7 @@ installUnpackedGHC path inst ver = do
| 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
@ -358,7 +357,7 @@ installGHCBin :: ( MonadFail m
, HasGHCupInfo env , HasGHCupInfo env
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -392,7 +391,7 @@ installCabalBindist :: ( MonadMask m
, HasPlatformReq env , HasPlatformReq env
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -416,7 +415,7 @@ installCabalBindist :: ( MonadMask m
m m
() ()
installCabalBindist dlinfo ver isoFilepath = do installCabalBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install cabal version " <> prettyVer ver lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
@ -447,7 +446,7 @@ installCabalBindist dlinfo ver isoFilepath = do
case isoFilepath of case isoFilepath of
Just isoDir -> do -- isolated install Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing Cabal to " <> T.pack isoDir lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir
liftE $ installCabalUnpacked workdir isoDir Nothing liftE $ installCabalUnpacked workdir isoDir Nothing
Nothing -> do -- regular install Nothing -> do -- regular install
@ -459,13 +458,13 @@ installCabalBindist dlinfo ver isoFilepath = do
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
-- | Install an unpacked cabal distribution. -- | Install an unpacked cabal distribution.
installCabalUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) installCabalUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install -> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installCabalUnpacked path inst mver' = do installCabalUnpacked path inst mver' = do
lift $ $(logInfo) "Installing cabal" lift $ logInfo "Installing cabal"
let cabalFile = "cabal" let cabalFile = "cabal"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
let destFileName = cabalFile let destFileName = cabalFile
@ -490,7 +489,7 @@ installCabalBin :: ( MonadMask m
, HasGHCupInfo env , HasGHCupInfo env
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -525,7 +524,7 @@ installHLSBindist :: ( MonadMask m
, HasPlatformReq env , HasPlatformReq env
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -549,7 +548,7 @@ installHLSBindist :: ( MonadMask m
m m
() ()
installHLSBindist dlinfo ver isoFilepath = do installHLSBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install hls version " <> prettyVer ver lift $ logDebug $ "Requested to install hls version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
@ -575,7 +574,7 @@ installHLSBindist dlinfo ver isoFilepath = do
case isoFilepath of case isoFilepath of
Just isoDir -> do Just isoDir -> do
lift $ $(logInfo) $ "isolated installing HLS to " <> T.pack isoDir lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir
liftE $ installHLSUnpacked workdir isoDir Nothing liftE $ installHLSUnpacked workdir isoDir Nothing
Nothing -> do Nothing -> do
@ -588,13 +587,13 @@ installHLSBindist dlinfo ver isoFilepath = do
-- | Install an unpacked hls distribution. -- | Install an unpacked hls distribution.
installHLSUnpacked :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) installHLSUnpacked :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated install -> Maybe Version -- ^ Nothing for isolated install
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installHLSUnpacked path inst mver' = do installHLSUnpacked path inst mver' = do
lift $ $(logInfo) "Installing HLS" lift $ logInfo "Installing HLS"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
-- install haskell-language-server-<ghcver> -- install haskell-language-server-<ghcver>
@ -644,7 +643,7 @@ installHLSBin :: ( MonadMask m
, HasGHCupInfo env , HasGHCupInfo env
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -681,7 +680,7 @@ installStackBin :: ( MonadMask m
, HasSettings env , HasSettings env
, HasPlatformReq env , HasPlatformReq env
, HasGHCupInfo env , HasGHCupInfo env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -716,7 +715,7 @@ installStackBindist :: ( MonadMask m
, HasPlatformReq env , HasPlatformReq env
, HasDirs env , HasDirs env
, HasSettings env , HasSettings env
, MonadLogger m , HasLog env
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
@ -740,7 +739,7 @@ installStackBindist :: ( MonadMask m
m m
() ()
installStackBindist dlinfo ver isoFilepath = do installStackBindist dlinfo ver isoFilepath = do
lift $ $(logDebug) $ "Requested to install stack version " <> prettyVer ver lift $ logDebug $ "Requested to install stack version " <> prettyVer ver
PlatformRequest {..} <- lift getPlatformReq PlatformRequest {..} <- lift getPlatformReq
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
@ -765,7 +764,7 @@ installStackBindist dlinfo ver isoFilepath = do
case isoFilepath of case isoFilepath of
Just isoDir -> do -- isolated install Just isoDir -> do -- isolated install
lift $ $(logInfo) $ "isolated installing Stack to " <> T.pack isoDir lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir
liftE $ installStackUnpacked workdir isoDir Nothing liftE $ installStackUnpacked workdir isoDir Nothing
Nothing -> do -- regular install Nothing -> do -- regular install
liftE $ installStackUnpacked workdir binDir (Just ver) liftE $ installStackUnpacked workdir binDir (Just ver)
@ -777,13 +776,13 @@ installStackBindist dlinfo ver isoFilepath = do
-- | Install an unpacked stack distribution. -- | Install an unpacked stack distribution.
installStackUnpacked :: (MonadLogger m, MonadCatch m, MonadIO m) installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
=> FilePath -- ^ Path to the unpacked stack bindist (where the executable resides) => FilePath -- ^ Path to the unpacked stack bindist (where the executable resides)
-> FilePath -- ^ Path to install to -> FilePath -- ^ Path to install to
-> Maybe Version -- ^ Nothing for isolated installs -> Maybe Version -- ^ Nothing for isolated installs
-> Excepts '[CopyError, FileAlreadyExistsError] m () -> Excepts '[CopyError, FileAlreadyExistsError] m ()
installStackUnpacked path inst mver' = do installStackUnpacked path inst mver' = do
lift $ $(logInfo) "Installing stack" lift $ logInfo "Installing stack"
let stackFile = "stack" let stackFile = "stack"
liftIO $ createDirRecursive' inst liftIO $ createDirRecursive' inst
let destFileName = stackFile let destFileName = stackFile
@ -816,7 +815,7 @@ installStackUnpacked path inst mver' = do
-- for 'SetGHCOnly' constructor. -- for 'SetGHCOnly' constructor.
setGHC :: ( MonadReader env m setGHC :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m
@ -850,7 +849,7 @@ setGHC ver sghc = do
SetGHCOnly -> pure $ Just file SetGHCOnly -> pure $ Just file
SetGHC_XY -> do SetGHC_XY -> do
handle handle
(\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing) (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ do $ do
(mj, mi) <- getMajorMinorV (_tvVersion ver) (mj, mi) <- getMajorMinorV (_tvVersion ver)
let major' = intToText mj <> "." <> intToText mi let major' = intToText mj <> "." <> intToText mi
@ -875,7 +874,7 @@ setGHC ver sghc = do
symlinkShareDir :: ( MonadReader env m symlinkShareDir :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , HasLog env
, MonadCatch m , MonadCatch m
, MonadMask m , MonadMask m
) )
@ -892,9 +891,9 @@ setGHC ver sghc = do
whenM (liftIO $ doesDirectoryExist fullsharedir) $ do whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
let fullF = destdir </> sharedir let fullF = destdir </> sharedir
let targetF = "." </> "ghc" </> ver' </> sharedir let targetF = "." </> "ghc" </> ver' </> sharedir
$(logDebug) $ "rm -f " <> T.pack fullF logDebug $ "rm -f " <> T.pack fullF
hideError doesNotExistErrorType $ rmDirectoryLink fullF hideError doesNotExistErrorType $ rmDirectoryLink fullF
$(logDebug) $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF
liftIO liftIO
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
-- On windows we need to be more permissive -- On windows we need to be more permissive
@ -912,7 +911,7 @@ setGHC ver sghc = do
setCabal :: ( MonadMask m setCabal :: ( MonadMask m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m
@ -944,7 +943,7 @@ setCabal ver = do
setHLS :: ( MonadCatch m setHLS :: ( MonadCatch m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m
@ -960,7 +959,7 @@ setHLS ver = do
-- selected version, so we could end up with stray or incorrect symlinks. -- selected version, so we could end up with stray or incorrect symlinks.
oldSyms <- lift hlsSymlinks oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do forM_ oldSyms $ \f -> do
lift $ $(logDebug) $ "rm " <> T.pack (binDir </> f) lift $ logDebug $ "rm " <> T.pack (binDir </> f)
lift $ rmLink (binDir </> f) lift $ rmLink (binDir </> f)
-- set haskell-language-server-<ghcver> symlinks -- set haskell-language-server-<ghcver> symlinks
@ -985,7 +984,7 @@ setHLS ver = do
setStack :: ( MonadMask m setStack :: ( MonadMask m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m
@ -1048,9 +1047,9 @@ availableToolVersions av tool = view
-- | List all versions from the download info, as well as stray -- | List all versions from the download info, as well as stray
-- versions. -- versions.
listVersions :: ( MonadCatch m listVersions :: ( MonadCatch m
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
@ -1106,7 +1105,7 @@ listVersions lt' criteria = do
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
) )
=> Map.Map Version VersionInfo => Map.Map Version VersionInfo
@ -1146,7 +1145,7 @@ listVersions lt' criteria = do
, .. , ..
} }
Left e -> do Left e -> do
$(logWarn) logWarn
$ "Could not parse version of stray directory" <> T.pack e $ "Could not parse version of stray directory" <> T.pack e
pure Nothing pure Nothing
@ -1154,7 +1153,7 @@ listVersions lt' criteria = do
, HasDirs env , HasDirs env
, MonadCatch m , MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
) )
=> Map.Map Version VersionInfo => Map.Map Version VersionInfo
@ -1181,7 +1180,7 @@ listVersions lt' criteria = do
, .. , ..
} }
Left e -> do Left e -> do
$(logWarn) logWarn
$ "Could not parse version of stray directory" <> T.pack e $ "Could not parse version of stray directory" <> T.pack e
pure Nothing pure Nothing
@ -1189,7 +1188,7 @@ listVersions lt' criteria = do
, HasDirs env , HasDirs env
, MonadCatch m , MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m) , MonadIO m)
=> Map.Map Version VersionInfo => Map.Map Version VersionInfo
-> Maybe Version -> Maybe Version
@ -1215,7 +1214,7 @@ listVersions lt' criteria = do
, .. , ..
} }
Left e -> do Left e -> do
$(logWarn) logWarn
$ "Could not parse version of stray directory" <> T.pack e $ "Could not parse version of stray directory" <> T.pack e
pure Nothing pure Nothing
@ -1223,7 +1222,7 @@ listVersions lt' criteria = do
, HasDirs env , HasDirs env
, MonadCatch m , MonadCatch m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
) )
=> Map.Map Version VersionInfo => Map.Map Version VersionInfo
@ -1250,7 +1249,7 @@ listVersions lt' criteria = do
, .. , ..
} }
Left e -> do Left e -> do
$(logWarn) logWarn
$ "Could not parse version of stray directory" <> T.pack e $ "Could not parse version of stray directory" <> T.pack e
pure Nothing pure Nothing
@ -1275,7 +1274,7 @@ listVersions lt' criteria = do
} }
-- NOTE: this are not cross ones, because no bindists -- NOTE: this are not cross ones, because no bindists
toListResult :: ( MonadLogger m toListResult :: ( HasLog env
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, HasGHCupInfo env , HasGHCupInfo env
@ -1377,7 +1376,7 @@ listVersions lt' criteria = do
rmGHCVer :: ( MonadReader env m rmGHCVer :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
, MonadCatch m , MonadCatch m
@ -1394,23 +1393,23 @@ rmGHCVer ver = do
-- this isn't atomic, order matters -- this isn't atomic, order matters
when isSetGHC $ do when isSetGHC $ do
lift $ $(logInfo) "Removing ghc symlinks" lift $ logInfo "Removing ghc symlinks"
liftE $ rmPlain (_tvTarget ver) liftE $ rmPlain (_tvTarget ver)
lift $ $(logInfo) "Removing ghc-x.y.z symlinks" lift $ logInfo "Removing ghc-x.y.z symlinks"
liftE $ rmMinorSymlinks ver liftE $ rmMinorSymlinks ver
lift $ $(logInfo) "Removing/rewiring ghc-x.y symlinks" lift $ logInfo "Removing/rewiring ghc-x.y symlinks"
-- first remove -- first remove
handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
-- then fix them (e.g. with an earlier version) -- then fix them (e.g. with an earlier version)
lift $ $(logInfo) $ "Removing directory recursively: " <> T.pack dir lift $ logInfo $ "Removing directory recursively: " <> T.pack dir
lift $ recyclePathForcibly dir lift $ recyclePathForcibly dir
v' <- v' <-
handle handle
(\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing) (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ fmap Just $ fmap Just
$ getMajorMinorV (_tvVersion ver) $ getMajorMinorV (_tvVersion ver)
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver)) forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi (_tvTarget ver))
@ -1427,7 +1426,7 @@ rmCabalVer :: ( MonadMask m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
, MonadCatch m , MonadCatch m
@ -1458,7 +1457,7 @@ rmHLSVer :: ( MonadMask m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
, MonadCatch m , MonadCatch m
@ -1481,7 +1480,7 @@ rmHLSVer ver = do
oldSyms <- lift hlsSymlinks oldSyms <- lift hlsSymlinks
forM_ oldSyms $ \f -> do forM_ oldSyms $ \f -> do
let fullF = binDir </> f let fullF = binDir </> f
lift $ $(logDebug) $ "rm " <> T.pack fullF lift $ logDebug $ "rm " <> T.pack fullF
lift $ rmLink fullF lift $ rmLink fullF
-- set latest hls -- set latest hls
hlsVers <- lift $ fmap rights getInstalledHLSs hlsVers <- lift $ fmap rights getInstalledHLSs
@ -1496,7 +1495,7 @@ rmStackVer :: ( MonadMask m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
, MonadCatch m , MonadCatch m
@ -1526,7 +1525,7 @@ rmGhcup :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
, MonadMask m , MonadMask m
, MonadUnliftIO m , MonadUnliftIO m
) )
@ -1551,7 +1550,7 @@ rmGhcup = do
let areEqualPaths = equalFilePath p1 p2 let areEqualPaths = equalFilePath p1 p2
unless areEqualPaths $ $logWarn $ nonStandardInstallLocationMsg currentRunningExecPath unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath
#if defined(IS_WINDOWS) #if defined(IS_WINDOWS)
-- 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
@ -1567,7 +1566,7 @@ rmGhcup = do
where where
handlePathNotPresent fp _err = do handlePathNotPresent fp _err = do
$logDebug $ "Error: The path does not exist, " <> T.pack fp logDebug $ "Error: The path does not exist, " <> T.pack fp
pure fp pure fp
nonStandardInstallLocationMsg path = T.pack $ nonStandardInstallLocationMsg path = T.pack $
@ -1577,7 +1576,7 @@ rmGhcup = do
rmTool :: ( MonadReader env m rmTool :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadFail m , MonadFail m
, MonadMask m , MonadMask m
, MonadUnliftIO m) , MonadUnliftIO m)
@ -1597,7 +1596,7 @@ rmTool ListResult {lVer, lTool, lCross} = do
rmGhcupDirs :: ( MonadReader env m rmGhcupDirs :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , HasLog env
, MonadCatch m , MonadCatch m
, MonadMask m ) , MonadMask m )
=> m [FilePath] => m [FilePath]
@ -1624,7 +1623,7 @@ rmGhcupDirs = do
handleRm $ rmBinDir binDir handleRm $ rmBinDir binDir
handleRm $ rmDir recycleDir handleRm $ rmDir recycleDir
#if defined(IS_WINDOWS) #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 #endif
@ -1635,27 +1634,27 @@ rmGhcupDirs = do
hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir hideErrorDef [doesNotExistErrorType] [] $ reportRemainingFiles baseDir
where where
handleRm :: (MonadCatch m, MonadLogger m) => m () -> m () handleRm :: (MonadReader env m, MonadCatch m, HasLog env, MonadIO m) => m () -> m ()
handleRm = handleIO (\e -> $logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n" handleRm = handleIO (\e -> logDebug $ "Part of the cleanup action failed with error: " <> T.pack (displayException e) <> "\n"
<> "continuing regardless...") <> "continuing regardless...")
rmEnvFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmEnvFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmEnvFile enFilePath = do rmEnvFile enFilePath = do
$logInfo "Removing Ghcup Environment File" logInfo "Removing Ghcup Environment File"
hideErrorDef [permissionErrorType] () $ deleteFile enFilePath hideErrorDef [permissionErrorType] () $ deleteFile enFilePath
rmConfFile :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmConfFile :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmConfFile confFilePath = do rmConfFile confFilePath = do
$logInfo "removing Ghcup Config File" logInfo "removing Ghcup Config File"
hideErrorDef [permissionErrorType] () $ deleteFile confFilePath hideErrorDef [permissionErrorType] () $ deleteFile confFilePath
rmDir :: (MonadLogger m, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m () rmDir :: (HasLog env, MonadReader env m, HasDirs env, MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
rmDir dir = rmDir dir =
-- 'getDirectoryContentsRecursive' is lazy IO. In case -- 'getDirectoryContentsRecursive' is lazy IO. In case
-- an error leaks through, we catch it here as well, -- an error leaks through, we catch it here as well,
-- althought 'deleteFile' should already handle it. -- althought 'deleteFile' should already handle it.
hideErrorDef [doesNotExistErrorType] () $ do hideErrorDef [doesNotExistErrorType] () $ do
$logInfo $ "removing " <> T.pack dir logInfo $ "removing " <> T.pack dir
contents <- liftIO $ getDirectoryContentsRecursive dir contents <- liftIO $ getDirectoryContentsRecursive dir
forM_ contents (deleteFile . (dir </>)) forM_ contents (deleteFile . (dir </>))
@ -1728,7 +1727,7 @@ getDebugInfo :: ( Alternative m
, MonadFail m , MonadFail m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadCatch m , MonadCatch m
, MonadIO m , MonadIO m
) )
@ -1764,7 +1763,7 @@ compileGHC :: ( MonadMask m
, HasSettings env , HasSettings env
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
, MonadFail m , MonadFail m
@ -1804,7 +1803,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
(workdir, tmpUnpack, tver) <- case targetGhc of (workdir, tmpUnpack, tver) <- case targetGhc of
-- unpack from version tarball -- unpack from version tarball
Left tver -> do Left tver -> do
lift $ $(logDebug) $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap
-- download source tarball -- download source tarball
dlInfo <- dlInfo <-
@ -1829,7 +1828,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
lift $ $(logInfo) $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)"
lEM $ git [ "init" ] lEM $ git [ "init" ]
lEM $ git [ "remote" lEM $ git [ "remote"
, "add" , "add"
@ -1856,7 +1855,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
lift $ $(logInfo) $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver
pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
-- the version that's installed may differ from the -- the version that's installed may differ from the
@ -1868,10 +1867,10 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
when alreadyInstalled $ do when alreadyInstalled $ do
case isolateDir of case isolateDir of
Just isoDir -> Just isoDir ->
lift $ $(logWarn) $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Isolate installing to " <> T.pack isoDir lift $ logWarn $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Isolate installing to " <> T.pack isoDir
Nothing -> Nothing ->
lift $ $(logWarn) $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Will overwrite existing version." lift $ logWarn $ "GHC " <> T.pack (prettyShow tver) <> " already installed. Will overwrite existing version."
lift $ $(logWarn) lift $ logWarn
"...waiting for 10 seconds before continuing, you can still abort..." "...waiting for 10 seconds before continuing, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene liftIO $ threadDelay 10000000 -- give the user a sec to intervene
@ -1898,7 +1897,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
Nothing -> Nothing ->
-- only remove old ghc in regular installs -- only remove old ghc in regular installs
when alreadyInstalled $ do when alreadyInstalled $ do
lift $ $(logInfo) "Deleting existing installation" lift $ logInfo "Deleting existing installation"
liftE $ rmGHCVer tver liftE $ rmGHCVer tver
_ -> pure () _ -> pure ()
@ -1950,7 +1949,7 @@ endif|]
, HasPlatformReq env , HasPlatformReq env
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
@ -1973,7 +1972,7 @@ endif|]
liftE $ configureBindist bghc tver workdir ghcdir liftE $ configureBindist bghc tver workdir ghcdir
lift $ $(logInfo) "Building (this may take a while)..." lift $ logInfo "Building (this may take a while)..."
hadrian_build <- liftE $ findHadrianFile workdir hadrian_build <- liftE $ findHadrianFile workdir
lEM $ execLogged hadrian_build lEM $ execLogged hadrian_build
( maybe [] (\j -> ["-j" <> show j] ) jobs ( maybe [] (\j -> ["-j" <> show j] ) jobs
@ -2012,7 +2011,7 @@ endif|]
, HasPlatformReq env , HasPlatformReq env
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
@ -2043,15 +2042,15 @@ endif|]
liftE $ checkBuildConfig (build_mk workdir) liftE $ checkBuildConfig (build_mk workdir)
lift $ $(logInfo) "Building (this may take a while)..." lift $ logInfo "Building (this may take a while)..."
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
if | isCross tver -> do if | isCross tver -> do
lift $ $(logInfo) "Installing cross toolchain..." lift $ logInfo "Installing cross toolchain..."
lEM $ make ["install"] (Just workdir) lEM $ make ["install"] (Just workdir)
pure Nothing pure Nothing
| otherwise -> do | otherwise -> do
lift $ $(logInfo) "Creating bindist..." lift $ logInfo "Creating bindist..."
lEM $ make ["binary-dist"] (Just workdir) lEM $ make ["binary-dist"] (Just workdir)
[tar] <- liftIO $ findFiles [tar] <- liftIO $ findFiles
workdir workdir
@ -2070,7 +2069,7 @@ endif|]
, MonadIO m , MonadIO m
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
) )
=> GHCTargetVersion => GHCTargetVersion
-> FilePath -- ^ tar file -> FilePath -- ^ tar file
@ -2105,10 +2104,10 @@ endif|]
let tarPath = cacheDir </> tarName let tarPath = cacheDir </> tarName
handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar) handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
tarPath tarPath
lift $ $(logInfo) $ "Copied bindist to " <> T.pack tarPath lift $ logInfo $ "Copied bindist to " <> T.pack tarPath
pure tarPath pure tarPath
checkBuildConfig :: (MonadCatch m, MonadIO m, MonadLogger m) checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env)
=> FilePath => FilePath
-> Excepts -> Excepts
'[FileDoesNotExistError, InvalidBuildConfig] '[FileDoesNotExistError, InvalidBuildConfig]
@ -2131,7 +2130,7 @@ endif|]
forM_ buildFlavour $ \bf -> forM_ buildFlavour $ \bf ->
when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do
lift $ $(logWarn) $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..." lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..."
liftIO $ threadDelay 5000000 liftIO $ threadDelay 5000000
addBuildFlavourToConf bc = case buildFlavour of addBuildFlavourToConf bc = case buildFlavour of
@ -2148,7 +2147,7 @@ endif|]
, HasPlatformReq env , HasPlatformReq env
, MonadThrow m , MonadThrow m
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) )
@ -2167,7 +2166,7 @@ endif|]
m m
() ()
configureBindist bghc tver workdir ghcdir = do configureBindist bghc tver workdir ghcdir = do
lift $ $(logInfo) [s|configuring build|] lift $ logInfo [s|configuring build|]
forM_ patchdir (\dir -> liftE $ applyPatches dir workdir) forM_ patchdir (\dir -> liftE $ applyPatches dir workdir)
@ -2231,7 +2230,7 @@ upgradeGHCup :: ( MonadMask m
, HasGHCupInfo env , HasGHCupInfo env
, HasSettings env , HasSettings env
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadResource m , MonadResource m
, MonadIO m , MonadIO m
@ -2253,7 +2252,7 @@ upgradeGHCup mtarget force' = do
Dirs {..} <- lift getDirs Dirs {..} <- lift getDirs
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
lift $ $(logInfo) "Upgrading GHCup..." lift $ logInfo "Upgrading GHCup..."
let latestVer = fromJust $ fst <$> getLatest dls GHCup let latestVer = fromJust $ fst <$> getLatest dls GHCup
when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate when (not force' && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
dli <- liftE $ getDownloadInfo GHCup latestVer dli <- liftE $ getDownloadInfo GHCup latestVer
@ -2262,20 +2261,20 @@ upgradeGHCup mtarget force' = do
p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False p <- liftE $ download (_dlUri dli) (Just (_dlHash dli)) tmp (Just fn) False
let destDir = takeDirectory destFile let destDir = takeDirectory destFile
destFile = fromMaybe (binDir </> fn) mtarget destFile = fromMaybe (binDir </> fn) mtarget
lift $ $(logDebug) $ "mkdir -p " <> T.pack destDir lift $ logDebug $ "mkdir -p " <> T.pack destDir
liftIO $ createDirRecursive' destDir liftIO $ createDirRecursive' destDir
lift $ $(logDebug) $ "rm -f " <> T.pack destFile lift $ logDebug $ "rm -f " <> T.pack destFile
lift $ hideError NoSuchThing $ recycleFile destFile lift $ hideError NoSuchThing $ recycleFile destFile
lift $ $(logDebug) $ "cp " <> T.pack p <> " " <> T.pack destFile lift $ logDebug $ "cp " <> T.pack p <> " " <> T.pack destFile
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
destFile destFile
lift $ chmod_755 destFile lift $ chmod_755 destFile
liftIO (isInPath destFile) >>= \b -> unless b $ liftIO (isInPath destFile) >>= \b -> unless b $
lift $ $(logWarn) $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup." lift $ logWarn $ T.pack (takeFileName destFile) <> " is not in PATH! You have to add it in order to use ghcup."
liftIO (isShadowed destFile) >>= \case liftIO (isShadowed destFile) >>= \case
Nothing -> pure () Nothing -> pure ()
Just pa -> lift $ $(logWarn) $ "ghcup is shadowed by " Just pa -> lift $ logWarn $ "ghcup is shadowed by "
<> T.pack pa <> T.pack pa
<> ". The upgrade will not be in effect, unless you remove " <> ". The upgrade will not be in effect, unless you remove "
<> T.pack pa <> T.pack pa
@ -2299,7 +2298,7 @@ upgradeGHCup mtarget force' = do
-- both installing from source and bindist. -- both installing from source and bindist.
postGHCInstall :: ( MonadReader env m postGHCInstall :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m
@ -2315,7 +2314,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- Create ghc-x.y symlinks. This may not be the current -- Create ghc-x.y symlinks. This may not be the current
-- version, create it regardless. -- version, create it regardless.
v' <- v' <-
handle (\(e :: ParseError) -> lift $ $(logWarn) (T.pack $ displayException e) >> pure Nothing) handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing)
$ fmap Just $ fmap Just
$ getMajorMinorV _tvVersion $ getMajorMinorV _tvVersion
forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget) forM_ v' $ \(mj, mi) -> lift (getGHCForMajor mj mi _tvTarget)
@ -2331,7 +2330,7 @@ postGHCInstall ver@GHCTargetVersion {..} = do
-- * for ghcup, this reports the location of the currently running executable -- * for ghcup, this reports the location of the currently running executable
whereIsTool :: ( MonadReader env m whereIsTool :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m

80
lib/GHCup/Download.hs
View File

@ -1,10 +1,7 @@
{-# LANGUAGE CPP #-} {-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -34,8 +31,8 @@ import GHCup.Download.Utils
#endif #endif
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.JSON ( )
import GHCup.Types.Optics import GHCup.Types.Optics
import GHCup.Types.JSON ( )
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
@ -47,7 +44,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
@ -112,7 +108,7 @@ getDownloadsF :: ( FromJSONKey Tool
, HasDirs env , HasDirs env
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadMask m , MonadMask m
@ -165,7 +161,7 @@ getBase :: ( MonadReader env m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
, MonadLogger m , HasLog env
, MonadMask m , MonadMask m
) )
=> URI => URI
@ -187,7 +183,7 @@ getBase uri = do
-- if we didn't get a filepath from the download, use the cached yaml -- if we didn't get a filepath from the download, use the cached yaml
actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml actualYaml <- maybe (lift $ yamlFromCache uri) pure mYaml
lift $ $(logDebug) $ "Decoding yaml at: " <> T.pack actualYaml lift $ logDebug $ "Decoding yaml at: " <> T.pack actualYaml
liftE liftE
. onE_ (onError actualYaml) . onE_ (onError actualYaml)
@ -200,15 +196,15 @@ getBase uri = do
where where
-- On error, remove the etags file and set access time to 0. This should ensure the next invocation -- On error, remove the etags file and set access time to 0. This should ensure the next invocation
-- may re-download and succeed. -- may re-download and succeed.
onError :: (MonadLogger m, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m () onError :: (MonadReader env m, HasLog env, MonadMask m, MonadCatch m, MonadIO m) => FilePath -> m ()
onError fp = do onError fp = do
let efp = etagsFile fp let efp = etagsFile fp
handleIO (\e -> $(logWarn) $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e)) handleIO (\e -> logWarn $ "Couldn't remove file " <> T.pack efp <> ", error was: " <> T.pack (displayException e))
(hideError doesNotExistErrorType $ rmFile efp) (hideError doesNotExistErrorType $ rmFile efp)
liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0)) liftIO $ hideError doesNotExistErrorType $ setAccessTime fp (posixSecondsToUTCTime (fromIntegral @Int 0))
warnCache s = do warnCache s = do
lift $ $(logWarn) "Could not get download info, trying cached version (this may not be recent!)" lift $ logWarn "Could not get download info, trying cached version (this may not be recent!)"
lift $ $(logDebug) $ "Error was: " <> T.pack s lift $ logDebug $ "Error was: " <> T.pack s
-- First check if the json file is in the ~/.ghcup/cache dir -- First check if the json file is in the ~/.ghcup/cache dir
-- and check it's access time. If it has been accessed within the -- and check it's access time. If it has been accessed within the
@ -222,7 +218,7 @@ getBase uri = do
, MonadCatch m1 , MonadCatch m1
, MonadIO m1 , MonadIO m1
, MonadFail m1 , MonadFail m1
, MonadLogger m1 , HasLog env1
, MonadMask m1 , MonadMask m1
) )
=> URI => URI
@ -313,7 +309,7 @@ download :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadMask m , MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
) )
=> URI => URI
@ -327,7 +323,7 @@ download uri eDigest dest mfn etags
| scheme == "http" = dl | scheme == "http" = dl
| scheme == "file" = do | scheme == "file" = do
let destFile' = T.unpack . decUTF8Safe $ path let destFile' = T.unpack . decUTF8Safe $ path
lift $ $(logDebug) $ "using local file: " <> T.pack destFile' lift $ logDebug $ "using local file: " <> T.pack destFile'
forM_ eDigest (liftE . flip checkDigest destFile') forM_ eDigest (liftE . flip checkDigest destFile')
pure destFile' pure destFile'
| otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme) | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
@ -336,7 +332,7 @@ download uri eDigest dest mfn etags
scheme = view (uriSchemeL' % schemeBSL') uri scheme = view (uriSchemeL' % schemeBSL') uri
dl = do dl = do
destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile destFile <- liftE . reThrowAll @_ @_ @'[DownloadFailed] DownloadFailed $ getDestFile
lift $ $(logInfo) $ "downloading: " <> uri' <> " as file " <> T.pack destFile lift $ logInfo $ "downloading: " <> uri' <> " as file " <> T.pack destFile
-- destination dir must exist -- destination dir must exist
liftIO $ createDirRecursive' dest liftIO $ createDirRecursive' dest
@ -359,7 +355,7 @@ download uri eDigest dest mfn etags
dh <- liftIO $ emptySystemTempFile "curl-header" dh <- liftIO $ emptySystemTempFile "curl-header"
flip finally (try @_ @SomeException $ rmFile dh) $ flip finally (try @_ @SomeException $ rmFile dh) $
flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do flip finally (try @_ @SomeException $ rmFile (destFile <.> "tmp")) $ do
metag <- readETag destFile metag <- lift $ readETag destFile
liftE $ lEM @_ @'[ProcessError] $ exec "curl" liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ (if etags then ["--dump-header", dh] else []) (o' ++ (if etags then ["--dump-header", dh] else [])
++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag ++ maybe [] (\t -> ["-H", "If-None-Match: " <> T.unpack t]) metag
@ -371,14 +367,14 @@ download uri eDigest dest mfn etags
case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
Just (http':sc:_) Just (http':sc:_)
| sc == "304" | sc == "304"
, T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug "Status code was 304, not overwriting" , T.pack "HTTP" `T.isPrefixOf` http' -> lift $ logDebug "Status code was 304, not overwriting"
| T.pack "HTTP" `T.isPrefixOf` http' -> do | T.pack "HTTP" `T.isPrefixOf` http' -> do
$logDebug $ "Status code was " <> sc <> ", overwriting" lift $ logDebug $ "Status code was " <> sc <> ", overwriting"
liftIO $ copyFile (destFile <.> "tmp") destFile liftIO $ copyFile (destFile <.> "tmp") destFile
_ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers) _ -> liftE $ throwE @_ @'[DownloadFailed] (DownloadFailed (toVariantAt @0 (MalformedHeaders headers)
:: V '[MalformedHeaders])) :: V '[MalformedHeaders]))
writeEtags destFile (parseEtags headers) lift $ writeEtags destFile (parseEtags headers)
else else
liftE $ lEM @_ @'[ProcessError] $ exec "curl" liftE $ lEM @_ @'[ProcessError] $ exec "curl"
(o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing (o' ++ ["-fL", "-o", destFile, T.unpack uri']) Nothing Nothing
@ -388,20 +384,20 @@ download uri eDigest dest mfn etags
o' <- liftIO getWgetOpts o' <- liftIO getWgetOpts
if etags if etags
then do then do
metag <- readETag destFile metag <- lift $ readETag destFile
let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag let opts = o' ++ maybe [] (\t -> ["--header", "If-None-Match: " <> T.unpack t]) metag
++ ["-q", "-S", "-O", destFileTemp , T.unpack uri'] ++ ["-q", "-S", "-O", destFileTemp , T.unpack uri']
CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing CapturedProcess {_exitCode, _stdErr} <- lift $ executeOut "wget" opts Nothing
case _exitCode of case _exitCode of
ExitSuccess -> do ExitSuccess -> do
liftIO $ copyFile destFileTemp destFile liftIO $ copyFile destFileTemp destFile
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr)) lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
ExitFailure i' ExitFailure i'
| i' == 8 | i' == 8
, Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr , Just _ <- find (T.pack "304 Not Modified" `T.isInfixOf`) . T.lines . decUTF8Safe' $ _stdErr
-> do -> do
$logDebug "Not modified, skipping download" lift $ logDebug "Not modified, skipping download"
writeEtags destFile (parseEtags (decUTF8Safe' _stdErr)) lift $ writeEtags destFile (parseEtags (decUTF8Safe' _stdErr))
| otherwise -> throwE (NonZeroExit i' "wget" opts) | otherwise -> throwE (NonZeroExit i' "wget" opts)
else do else do
let opts = o' ++ ["-O", destFileTemp , T.unpack uri'] let opts = o' ++ ["-O", destFileTemp , T.unpack uri']
@ -412,14 +408,14 @@ download uri eDigest dest mfn etags
(https, host, fullPath, port) <- liftE $ uriToQuadruple uri (https, host, fullPath, port) <- liftE $ uriToQuadruple uri
if etags if etags
then do then do
metag <- readETag destFile metag <- lift $ readETag destFile
let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match" let addHeaders = maybe mempty (\etag -> M.fromList [ (mk . E.encodeUtf8 . T.pack $ "If-None-Match"
, E.encodeUtf8 etag)]) metag , E.encodeUtf8 etag)]) metag
liftE liftE
$ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag)) $ catchE @HTTPNotModified @'[DownloadFailed] @'[] (\(HTTPNotModified etag) -> lift $ writeEtags destFile (pure $ Just etag))
$ do $ do
r <- downloadToFile https host fullPath port destFile addHeaders r <- downloadToFile https host fullPath port destFile addHeaders
writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag") lift $ writeEtags destFile (pure $ decUTF8Safe <$> getHeader r "etag")
else void $ liftE $ catchE @HTTPNotModified else void $ liftE $ catchE @HTTPNotModified
@'[DownloadFailed] @'[DownloadFailed]
(\e@(HTTPNotModified _) -> (\e@(HTTPNotModified _) ->
@ -445,33 +441,33 @@ download uri eDigest dest mfn etags
path = view pathL' uri path = view pathL' uri
uri' = decUTF8Safe (serializeURIRef' uri) uri' = decUTF8Safe (serializeURIRef' uri)
parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text) parseEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
parseEtags stderr = do parseEtags stderr = do
let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr
case T.words <$> mEtag of case T.words <$> mEtag of
(Just []) -> do (Just []) -> do
$logDebug "Couldn't parse etags, no input: " logDebug "Couldn't parse etags, no input: "
pure Nothing pure Nothing
(Just [_, etag']) -> do (Just [_, etag']) -> do
$logDebug $ "Parsed etag: " <> etag' logDebug $ "Parsed etag: " <> etag'
pure (Just etag') pure (Just etag')
(Just xs) -> do (Just xs) -> do
$logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs) logDebug ("Couldn't parse etags, unexpected input: " <> T.unwords xs)
pure Nothing pure Nothing
Nothing -> do Nothing -> do
$logDebug "No etags header found" logDebug "No etags header found"
pure Nothing pure Nothing
writeEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m () writeEtags :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m) => FilePath -> m (Maybe T.Text) -> m ()
writeEtags destFile getTags = do writeEtags destFile getTags = do
getTags >>= \case getTags >>= \case
Just t -> do Just t -> do
$logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile) logDebug $ "Writing etagsFile " <> T.pack (etagsFile destFile)
liftIO $ T.writeFile (etagsFile destFile) t liftIO $ T.writeFile (etagsFile destFile) t
Nothing -> Nothing ->
$logDebug "No etags files written" logDebug "No etags files written"
readETag :: (MonadLogger m, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text) readETag :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) => FilePath -> m (Maybe T.Text)
readETag fp = do readETag fp = do
e <- liftIO $ doesFileExist fp e <- liftIO $ doesFileExist fp
if e if e
@ -479,13 +475,13 @@ download uri eDigest dest mfn etags
rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp) rE <- try @_ @SomeException $ liftIO $ fmap stripNewline' $ T.readFile (etagsFile fp)
case rE of case rE of
(Right et) -> do (Right et) -> do
$logDebug $ "Read etag: " <> et logDebug $ "Read etag: " <> et
pure (Just et) pure (Just et)
(Left _) -> do (Left _) -> do
$logDebug "Etag file doesn't exist (yet)" logDebug "Etag file doesn't exist (yet)"
pure Nothing pure Nothing
else do else do
$logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist" logDebug $ "Skipping and deleting etags file because destination file " <> T.pack fp <> " doesn't exist"
liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp) liftIO $ hideError doesNotExistErrorType $ rmFile (etagsFile fp)
pure Nothing pure Nothing
@ -498,7 +494,7 @@ downloadCached :: ( MonadReader env m
, MonadMask m , MonadMask m
, MonadResource m , MonadResource m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
@ -519,7 +515,7 @@ downloadCached' :: ( MonadReader env m
, HasSettings env , HasSettings env
, MonadMask m , MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadUnliftIO m , MonadUnliftIO m
) )
@ -553,7 +549,7 @@ checkDigest :: ( MonadReader env m
, HasSettings env , HasSettings env
, MonadIO m , MonadIO m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
) )
=> T.Text -- ^ the hash => T.Text -- ^ the hash
-> FilePath -> FilePath
@ -563,7 +559,7 @@ checkDigest eDigest file = do
let verify = not noVerify let verify = not noVerify
when verify $ do when verify $ do
let p' = takeFileName file let p' = takeFileName file
lift $ $(logInfo) $ "verifying digest of: " <> T.pack p' lift $ logInfo $ "verifying digest of: " <> T.pack p'
c <- liftIO $ L.readFile file c <- liftIO $ L.readFile file
cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest) when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

8
lib/GHCup/Platform.hs
View File

@ -20,6 +20,7 @@ module GHCup.Platform where
import GHCup.Errors import GHCup.Errors
import GHCup.Types import GHCup.Types
import GHCup.Types.Optics
import GHCup.Types.JSON ( ) import GHCup.Types.JSON ( )
import GHCup.Utils.File import GHCup.Utils.File
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
@ -28,7 +29,6 @@ import GHCup.Utils.String.QQ
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Foldable import Data.Foldable
@ -57,7 +57,7 @@ import qualified Data.Text.IO as T
-- | Get the full platform request, consisting of architecture, distro, ... -- | Get the full platform request, consisting of architecture, distro, ...
platformRequest :: (Alternative m, MonadFail m, MonadLogger m, MonadCatch m, MonadIO m) platformRequest :: (MonadReader env m, Alternative m, MonadFail m, HasLog env, MonadCatch m, MonadIO m)
=> Excepts => Excepts
'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] '[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
m m
@ -82,7 +82,7 @@ getArchitecture = case arch of
what -> Left (NoCompatibleArch what) what -> Left (NoCompatibleArch what)
getPlatform :: (Alternative m, MonadLogger m, MonadCatch m, MonadIO m, MonadFail m) getPlatform :: (Alternative m, MonadReader env m, HasLog env, MonadCatch m, MonadIO m, MonadFail m)
=> Excepts => Excepts
'[NoCompatiblePlatform, DistroNotFound] '[NoCompatiblePlatform, DistroNotFound]
m m
@ -107,7 +107,7 @@ getPlatform = do
pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver } pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
"mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing } "mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
what -> throwE $ NoCompatiblePlatform what what -> throwE $ NoCompatiblePlatform what
lift $ $(logDebug) $ "Identified Platform as: " <> T.pack (prettyShow pfr) lift $ logDebug $ "Identified Platform as: " <> T.pack (prettyShow pfr)
pure pfr pure pfr
where where
getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing getFreeBSDVersion = lift $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing

31
lib/GHCup/Types.hs
View File

@ -25,21 +25,17 @@ module GHCup.Types
) )
where where
import Control.Applicative
import Control.DeepSeq ( NFData, rnf ) import Control.DeepSeq ( NFData, rnf )
import Control.Monad.Logger
import Data.Map.Strict ( Map ) import Data.Map.Strict ( Map )
import Data.List.NonEmpty ( NonEmpty (..) ) import Data.List.NonEmpty ( NonEmpty (..) )
import Data.Text ( Text ) import Data.Text ( Text )
import Data.Versions import Data.Versions
import Haskus.Utils.Variant.Excepts
import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text) import Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
import URI.ByteString import URI.ByteString
#if defined(BRICK) #if defined(BRICK)
import Graphics.Vty ( Key(..) ) import Graphics.Vty ( Key(..) )
#endif #endif
import qualified Control.Monad.Trans.Class as Trans
import qualified Data.Text as T import qualified Data.Text as T
import qualified GHC.Generics as GHC import qualified GHC.Generics as GHC
@ -396,6 +392,7 @@ data AppState = AppState
, keyBindings :: KeyBindings , keyBindings :: KeyBindings
, ghcupInfo :: GHCupInfo , ghcupInfo :: GHCupInfo
, pfreq :: PlatformRequest , pfreq :: PlatformRequest
, loggerConfig :: LoggerConfig
} deriving (Show, GHC.Generic) } deriving (Show, GHC.Generic)
instance NFData AppState instance NFData AppState
@ -404,6 +401,7 @@ data LeanAppState = LeanAppState
{ settings :: Settings { settings :: Settings
, dirs :: Dirs , dirs :: Dirs
, keyBindings :: KeyBindings , keyBindings :: KeyBindings
, loggerConfig :: LoggerConfig
} deriving (Show, GHC.Generic) } deriving (Show, GHC.Generic)
instance NFData LeanAppState instance NFData LeanAppState
@ -555,14 +553,25 @@ instance Pretty Versioning where
instance Pretty Version where instance Pretty Version where
pPrint = text . T.unpack . prettyVer pPrint = text . T.unpack . prettyVer
instance Show (a -> b) where
show _ = "<function>"
instance (Monad m, Alternative m) => Alternative (LoggingT m) where instance Show (IO ()) where
empty = Trans.lift empty show _ = "<io>"
{-# INLINE empty #-}
m <|> n = LoggingT $ \ r -> runLoggingT m r <|> runLoggingT n r
{-# INLINE (<|>) #-}
instance MonadLogger m => MonadLogger (Excepts e m) where data LogLevel = Warn
monadLoggerLog a b c d = Trans.lift $ monadLoggerLog a b c d | Info
| Debug
| Error
deriving (Eq, Ord, Show)
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: T.Text -> IO () -- ^ how to write the color output
, rawOutter :: T.Text -> IO () -- ^ how to write the full raw output
}
deriving Show
instance NFData LoggerConfig where
rnf (LoggerConfig !lcPrintDebug !_ !_) = rnf lcPrintDebug

93
lib/GHCup/Types/Optics.hs
View File

@ -6,6 +6,7 @@
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-| {-|
Module : GHCup.Types.Optics Module : GHCup.Types.Optics
@ -21,9 +22,13 @@ module GHCup.Types.Optics where
import GHCup.Types import GHCup.Types
import Control.Monad.Reader import Control.Monad.Reader
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Text ( Text )
import Optics import Optics
import URI.ByteString import URI.ByteString
import System.Console.Pretty
import qualified Data.Text as T
makePrisms ''Tool makePrisms ''Tool
makePrisms ''Architecture makePrisms ''Architecture
@ -87,13 +92,15 @@ getLeanAppState :: ( MonadReader env m
, LabelOptic' "settings" A_Lens env Settings , LabelOptic' "settings" A_Lens env Settings
, LabelOptic' "dirs" A_Lens env Dirs , LabelOptic' "dirs" A_Lens env Dirs
, LabelOptic' "keyBindings" A_Lens env KeyBindings , LabelOptic' "keyBindings" A_Lens env KeyBindings
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
) )
=> m LeanAppState => m LeanAppState
getLeanAppState = do getLeanAppState = do
s <- gets @"settings" s <- gets @"settings"
d <- gets @"dirs" d <- gets @"dirs"
k <- gets @"keyBindings" k <- gets @"keyBindings"
pure (LeanAppState s d k) l <- gets @"loggerConfig"
pure (LeanAppState s d k l)
getSettings :: ( MonadReader env m getSettings :: ( MonadReader env m
@ -110,6 +117,87 @@ getDirs :: ( MonadReader env m
getDirs = gets @"dirs" getDirs = gets @"dirs"
logInfo :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logInfo = logInternal Info
logWarn :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logWarn = logInternal Warn
logDebug :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logDebug = logInternal Debug
logError :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
)
=> Text
-> m ()
logError = logInternal Error
logInternal :: ( MonadReader env m
, LabelOptic' "loggerConfig" A_Lens env LoggerConfig
, MonadIO m
) => LogLevel
-> Text
-> m ()
logInternal logLevel msg = do
LoggerConfig {..} <- gets @"loggerConfig"
let style' = case logLevel of
Debug -> style Bold . color Blue
Info -> style Bold . color Green
Warn -> style Bold . color Yellow
Error -> style Bold . color Red
let l = case logLevel of
Debug -> style' "[ Debug ]"
Info -> style' "[ Info ]"
Warn -> style' "[ Warn ]"
Error -> style' "[ Error ]"
let strs = T.split (== '\n') msg
let out = case strs of
[] -> T.empty
(x:xs) ->
foldr (\a b -> a <> "\n" <> b) mempty
. ((l <> " " <> x) :)
. fmap (\line' -> style' "[ ... ] " <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (logLevel /= Debug)))
$ liftIO $ colorOutter out
-- raw output
let lr = case logLevel of
Debug -> "Debug:"
Info -> "Info:"
Warn -> "Warn:"
Error -> "Error:"
let outr = lr <> " " <> msg <> "\n"
liftIO $ rawOutter outr
getLogCleanup :: ( MonadReader env m
, LabelOptic' "logCleanup" A_Lens env (IO ())
)
=> m (IO ())
getLogCleanup = gets @"logCleanup"
getKeyBindings :: ( MonadReader env m getKeyBindings :: ( MonadReader env m
, LabelOptic' "keyBindings" A_Lens env KeyBindings , LabelOptic' "keyBindings" A_Lens env KeyBindings
) )
@ -136,6 +224,7 @@ type HasDirs env = (LabelOptic' "dirs" A_Lens env Dirs)
type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings) type HasKeyBindings env = (LabelOptic' "keyBindings" A_Lens env KeyBindings)
type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo) type HasGHCupInfo env = (LabelOptic' "ghcupInfo" A_Lens env GHCupInfo)
type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest) type HasPlatformReq env = (LabelOptic' "pfreq" A_Lens env PlatformRequest)
type HasLog env = (LabelOptic' "loggerConfig" A_Lens env LoggerConfig)
getCache :: (MonadReader env m, HasSettings env) => m Bool getCache :: (MonadReader env m, HasSettings env) => m Bool

63
lib/GHCup/Utils.hs
View File

@ -46,7 +46,6 @@ import Control.Monad
#if !MIN_VERSION_base(4,13,0) #if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail ) import Control.Monad.Fail ( MonadFail )
#endif #endif
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
hiding ( throwM ) hiding ( throwM )
@ -113,7 +112,7 @@ ghcLinkDestination tool ver = do
rmMinorSymlinks :: ( MonadReader env m rmMinorSymlinks :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadMask m , MonadMask m
@ -127,14 +126,14 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do forM_ files $ \f -> do
let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
let fullF = binDir </> f_xyz let fullF = binDir </> f_xyz
lift $ $(logDebug) ("rm -f " <> T.pack fullF) lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF lift $ hideError doesNotExistErrorType $ rmLink fullF
-- | Removes the set ghc version for the given target, if any. -- | Removes the set ghc version for the given target, if any.
rmPlain :: ( MonadReader env m rmPlain :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadIO m , MonadIO m
@ -149,11 +148,11 @@ rmPlain target = do
files <- liftE $ ghcToolFiles tv files <- liftE $ ghcToolFiles tv
forM_ files $ \f -> do forM_ files $ \f -> do
let fullF = binDir </> f <> exeExt let fullF = binDir </> f <> exeExt
lift $ $(logDebug) ("rm -f " <> T.pack fullF) lift $ logDebug ("rm -f " <> T.pack fullF)
lift $ hideError doesNotExistErrorType $ rmLink fullF lift $ hideError doesNotExistErrorType $ rmLink fullF
-- old ghcup -- old ghcup
let hdc_file = binDir </> "haddock-ghc" <> exeExt let hdc_file = binDir </> "haddock-ghc" <> exeExt
lift $ $(logDebug) ("rm -f " <> T.pack hdc_file) lift $ logDebug ("rm -f " <> T.pack hdc_file)
lift $ hideError doesNotExistErrorType $ rmLink hdc_file lift $ hideError doesNotExistErrorType $ rmLink hdc_file
@ -161,7 +160,7 @@ rmPlain target = do
rmMajorSymlinks :: ( MonadReader env m rmMajorSymlinks :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadIO m , MonadIO m
, MonadLogger m , HasLog env
, MonadThrow m , MonadThrow m
, MonadFail m , MonadFail m
, MonadMask m , MonadMask m
@ -177,7 +176,7 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
forM_ files $ \f -> do forM_ files $ \f -> do
let f_xy = f <> "-" <> T.unpack v' <> exeExt let f_xy = f <> "-" <> T.unpack v' <> exeExt
let fullF = binDir </> f_xy let fullF = binDir </> f_xy
lift $ $(logDebug) "rm -f #{fullF}" lift $ logDebug "rm -f #{fullF}"
lift $ hideError doesNotExistErrorType $ rmLink fullF lift $ hideError doesNotExistErrorType $ rmLink fullF
@ -249,9 +248,9 @@ getInstalledGHCs = do
-- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@. -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
getInstalledCabals :: ( MonadLogger m getInstalledCabals :: ( MonadReader env m
, MonadReader env m
, HasDirs env , HasDirs env
, HasLog env
, MonadIO m , MonadIO m
, MonadCatch m , MonadCatch m
) )
@ -269,14 +268,14 @@ getInstalledCabals = do
-- | Whether the given cabal version is installed. -- | Whether the given cabal version is installed.
cabalInstalled :: (MonadLogger m, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool cabalInstalled :: (HasLog env, MonadIO m, MonadReader env m, HasDirs env, MonadCatch m) => Version -> m Bool
cabalInstalled ver = do cabalInstalled ver = do
vers <- fmap rights getInstalledCabals vers <- fmap rights getInstalledCabals
pure $ elem ver vers pure $ elem ver vers
-- Return the currently set cabal version, if any. -- Return the currently set cabal version, if any.
cabalSet :: (MonadLogger m, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version) cabalSet :: (HasLog env, MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
cabalSet = do cabalSet = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
let cabalbin = binDir </> "cabal" <> exeExt let cabalbin = binDir </> "cabal" <> exeExt
@ -293,7 +292,7 @@ cabalSet = do
case linkVersion =<< link of case linkVersion =<< link of
Right v -> pure $ Just v Right v -> pure $ Just v
Left err -> do Left err -> do
$(logWarn) $ "Failed to parse cabal symlink target with: " logWarn $ "Failed to parse cabal symlink target with: "
<> T.pack (displayException err) <> T.pack (displayException err)
<> ". The symlink " <> ". The symlink "
<> T.pack cabalbin <> T.pack cabalbin
@ -364,7 +363,7 @@ getInstalledStacks = do
-- Return the currently set stack version, if any. -- Return the currently set stack version, if any.
-- TODO: there's a lot of code duplication here :> -- TODO: there's a lot of code duplication here :>
stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, MonadLogger m) => m (Maybe Version) stackSet :: (MonadReader env m, HasDirs env, MonadIO m, MonadThrow m, MonadCatch m, HasLog env) => m (Maybe Version)
stackSet = do stackSet = do
Dirs {..} <- getDirs Dirs {..} <- getDirs
let stackBin = binDir </> "stack" <> exeExt let stackBin = binDir </> "stack" <> exeExt
@ -381,7 +380,7 @@ stackSet = do
case linkVersion =<< link of case linkVersion =<< link of
Right v -> pure $ Just v Right v -> pure $ Just v
Left err -> do Left err -> do
$(logWarn) $ "Failed to parse stack symlink target with: " logWarn $ "Failed to parse stack symlink target with: "
<> T.pack (displayException err) <> T.pack (displayException err)
<> ". The symlink " <> ". The symlink "
<> T.pack stackBin <> T.pack stackBin
@ -599,7 +598,7 @@ getLatestGHCFor major' minor' dls =
-- | Unpack an archive to a temporary directory and return that path. -- | Unpack an archive to a temporary directory and return that path.
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m) unpackToDir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath -- ^ destination dir => FilePath -- ^ destination dir
-> FilePath -- ^ archive path -> FilePath -- ^ archive path
-> Excepts '[UnknownArchive -> Excepts '[UnknownArchive
@ -607,7 +606,7 @@ unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
] m () ] m ()
unpackToDir dfp av = do unpackToDir dfp av = do
let fn = takeFileName av let fn = takeFileName av
lift $ $(logInfo) $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp lift $ logInfo $ "Unpacking: " <> T.pack fn <> " to " <> T.pack dfp
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m () let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
@ -630,7 +629,7 @@ unpackToDir dfp av = do
| otherwise -> throwE $ UnknownArchive fn | otherwise -> throwE $ UnknownArchive fn
getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m) getArchiveFiles :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m)
=> FilePath -- ^ archive path => FilePath -- ^ archive path
-> Excepts '[UnknownArchive -> Excepts '[UnknownArchive
, ArchiveResult , ArchiveResult
@ -659,7 +658,7 @@ getArchiveFiles av = do
| otherwise -> throwE $ UnknownArchive fn | otherwise -> throwE $ UnknownArchive fn
intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m) intoSubdir :: (MonadReader env m, HasLog env, MonadIO m, MonadThrow m, MonadCatch m)
=> FilePath -- ^ unpacked tar dir => FilePath -- ^ unpacked tar dir
-> TarDir -- ^ how to descend -> TarDir -- ^ how to descend
-> Excepts '[TarDirDoesNotExist] m FilePath -> Excepts '[TarDirDoesNotExist] m FilePath
@ -787,14 +786,14 @@ makeOut args workdir = do
-- | Try to apply patches in order. Fails with 'PatchFailed' -- | Try to apply patches in order. Fails with 'PatchFailed'
-- on first failure. -- on first failure.
applyPatches :: (MonadReader env m, HasDirs env, MonadLogger m, MonadIO m) applyPatches :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m)
=> FilePath -- ^ dir containing patches => FilePath -- ^ dir containing patches
-> FilePath -- ^ dir to apply patches in -> FilePath -- ^ dir to apply patches in
-> Excepts '[PatchFailed] m () -> Excepts '[PatchFailed] m ()
applyPatches pdir ddir = do applyPatches pdir ddir = do
patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
forM_ (sort patches) $ \patch' -> do forM_ (sort patches) $ \patch' -> do
lift $ $(logInfo) $ "Applying patch " <> T.pack patch' lift $ logInfo $ "Applying patch " <> T.pack patch'
fmap (either (const Nothing) Just) fmap (either (const Nothing) Just)
(exec (exec
"patch" "patch"
@ -835,7 +834,7 @@ runBuildAction :: ( Pretty (V e)
, HasSettings env , HasSettings env
, MonadIO m , MonadIO m
, MonadMask m , MonadMask m
, MonadLogger m , HasLog env
, MonadUnliftIO m , MonadUnliftIO m
) )
=> FilePath -- ^ build directory (cleaned up depending on Settings) => FilePath -- ^ build directory (cleaned up depending on Settings)
@ -863,9 +862,9 @@ runBuildAction bdir instdir action = do
-- | Remove a build directory, ignoring if it doesn't exist and gracefully -- | Remove a build directory, ignoring if it doesn't exist and gracefully
-- printing other errors without crashing. -- printing other errors without crashing.
rmBDir :: (MonadLogger m, MonadUnliftIO m, MonadIO m) => FilePath -> m () rmBDir :: (MonadReader env m, HasLog env, MonadUnliftIO m, MonadIO m) => FilePath -> m ()
rmBDir dir = withRunInIO (\run -> run $ rmBDir dir = withRunInIO (\run -> run $
liftIO $ handleIO (\e -> run $ $(logWarn) $ liftIO $ handleIO (\e -> run $ logWarn $
"Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e)) "Couldn't remove build dir " <> T.pack dir <> ", error was: " <> T.pack (displayException e))
$ hideError doesNotExistErrorType $ hideError doesNotExistErrorType
$ rmPathForcibly dir) $ rmPathForcibly dir)
@ -978,7 +977,7 @@ rmLink = hideError doesNotExistErrorType . recycleFile
-- On windows, this requires that 'ensureGlobalTools' was run beforehand. -- On windows, this requires that 'ensureGlobalTools' was run beforehand.
createLink :: ( MonadMask m createLink :: ( MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
@ -1000,24 +999,24 @@ createLink link exe = do
fullLink = takeDirectory exe </> link fullLink = takeDirectory exe </> link
shimContents = "path = " <> fullLink shimContents = "path = " <> fullLink
$(logDebug) $ "rm -f " <> T.pack exe logDebug $ "rm -f " <> T.pack exe
rmLink exe rmLink exe
$(logDebug) $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe
liftIO $ copyFile shimGen exe liftIO $ copyFile shimGen exe
liftIO $ writeFile shim shimContents liftIO $ writeFile shim shimContents
#else #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 #endif
ensureGlobalTools :: ( MonadMask m ensureGlobalTools :: ( MonadMask m
, MonadThrow m , MonadThrow m
, MonadLogger m , HasLog env
, MonadIO m , MonadIO m
, MonadReader env m , MonadReader env m
, HasDirs env , HasDirs env
@ -1035,8 +1034,8 @@ ensureGlobalTools = do
$ 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 #{shimDownload}" lift $ logDebug "rm -f #{shimDownload}"
lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe") lift $ hideError doesNotExistErrorType $ recycleFile (cacheDir dirs </> "gs.exe")
liftE @'[DigestError , DownloadFailed] $ dl liftE @'[DigestError , DownloadFailed] $ dl
) `catchE` (liftE @'[DigestError , DownloadFailed] dl) ) `catchE` (liftE @'[DigestError , DownloadFailed] dl)

21
lib/GHCup/Utils/Dirs.hs
View File

@ -2,9 +2,7 @@
{-# LANGUAGE DataKinds #-} {-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
{-| {-|
Module : GHCup.Utils.Dirs Module : GHCup.Utils.Dirs
@ -45,7 +43,6 @@ import GHCup.Utils.Prelude
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Unlift import Control.Monad.IO.Unlift
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource hiding (throwM) import Control.Monad.Trans.Resource hiding (throwM)
import Data.Bifunctor import Data.Bifunctor
@ -261,7 +258,7 @@ parseGHCupGHCDir (T.pack -> fp) =
mkGhcupTmpDir :: ( MonadReader env m mkGhcupTmpDir :: ( MonadReader env m
, HasDirs env , HasDirs env
, MonadUnliftIO m , MonadUnliftIO m
, MonadLogger m , HasLog env
, MonadCatch m , MonadCatch m
, MonadThrow m , MonadThrow m
, MonadMask m , MonadMask m
@ -273,14 +270,14 @@ mkGhcupTmpDir = do
let minSpace = 5000 -- a rough guess, aight? let minSpace = 5000 -- a rough guess, aight?
space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
when (maybe False (toBytes minSpace >) space) $ do when (maybe False (toBytes minSpace >) space) $ do
$(logWarn) ("Possibly insufficient disk space on " logWarn ("Possibly insufficient disk space on "
<> T.pack tmpdir <> T.pack tmpdir
<> ". At least " <> ". At least "
<> T.pack (show minSpace) <> T.pack (show minSpace)
<> " MB are recommended, but only " <> " MB are recommended, but only "
<> toMB (fromJust space) <> toMB (fromJust space)
<> " are free. Consider freeing up disk space or setting TMPDIR env variable.") <> " are free. Consider freeing up disk space or setting TMPDIR env variable.")
$(logWarn) logWarn
"...waiting for 10 seconds before continuing anyway, you can still abort..." "...waiting for 10 seconds before continuing anyway, you can still abort..."
liftIO $ threadDelay 10000000 -- give the user a sec to intervene liftIO $ threadDelay 10000000 -- give the user a sec to intervene
@ -295,8 +292,9 @@ mkGhcupTmpDir = do
withGHCupTmpDir :: ( MonadReader env m withGHCupTmpDir :: ( MonadReader env m
, HasDirs env , HasDirs env
, HasLog env
, HasSettings env
, MonadUnliftIO m , MonadUnliftIO m
, MonadLogger m
, MonadCatch m , MonadCatch m
, MonadResource m , MonadResource m
, MonadThrow m , MonadThrow m
@ -309,7 +307,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
(run mkGhcupTmpDir) (run mkGhcupTmpDir)
(\fp -> (\fp ->
handleIO (\e -> run handleIO (\e -> run
$ $(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))) $ logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)))
. rmPathForcibly . rmPathForcibly
$ fp)) $ fp))
@ -341,9 +339,10 @@ relativeSymlink p1 p2 =
cleanupTrash :: ( MonadIO m cleanupTrash :: ( MonadIO m
, MonadMask m , MonadMask m
, MonadLogger m
, MonadReader env m , MonadReader env m
, HasLog env
, HasDirs env , HasDirs env
, HasSettings env
) )
=> m () => m ()
cleanupTrash = do cleanupTrash = do
@ -352,8 +351,8 @@ cleanupTrash = do
if null contents if null contents
then pure () then pure ()
else do else do
$(logWarn) ("Removing leftover files in " <> T.pack recycleDir) logWarn ("Removing leftover files in " <> T.pack recycleDir)
forM_ contents (\fp -> handleIO (\e -> forM_ contents (\fp -> handleIO (\e ->
$(logDebug) ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e)) logDebug ("Resource cleanup failed for " <> T.pack fp <> ", error was: " <> T.pack (displayException e))
) $ liftIO $ removePathForcibly (recycleDir </> fp)) ) $ liftIO $ removePathForcibly (recycleDir </> fp))

8
lib/GHCup/Utils/File/Posix.hs
View File

@ -1,8 +1,5 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns #-}
{-| {-|
Module : GHCup.Utils.File.Posix Module : GHCup.Utils.File.Posix
@ -28,7 +25,6 @@ import Control.Concurrent.Async
import Control.Exception ( evaluate ) import Control.Exception ( evaluate )
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.State.Strict import Control.Monad.Trans.State.Strict
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
@ -350,7 +346,7 @@ toProcessError exe args mps = case mps of
chmod_755 :: (MonadLogger m, MonadIO m) => FilePath -> m () chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m ()
chmod_755 fp = do chmod_755 fp = do
let exe_mode = let exe_mode =
nullFileMode nullFileMode
@ -361,7 +357,7 @@ chmod_755 fp = do
`unionFileModes` groupReadMode `unionFileModes` groupReadMode
`unionFileModes` otherExecuteMode `unionFileModes` otherExecuteMode
`unionFileModes` otherReadMode `unionFileModes` otherReadMode
$(logDebug) ("chmod 755 " <> T.pack fp) logDebug ("chmod 755 " <> T.pack fp)
liftIO $ setFileMode fp exe_mode liftIO $ setFileMode fp exe_mode

50
lib/GHCup/Utils/Logger.hs
View File

@ -22,11 +22,8 @@ import GHCup.Utils.String.QQ
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Data.Char ( ord )
import Prelude hiding ( appendFile ) import Prelude hiding ( appendFile )
import System.Console.Pretty
import System.FilePath import System.FilePath
import System.IO.Error import System.IO.Error
import Text.Regex.Posix import Text.Regex.Posix
@ -35,53 +32,6 @@ import qualified Data.ByteString as B
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
data LoggerConfig = LoggerConfig
{ lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter
, colorOutter :: B.ByteString -> IO () -- ^ how to write the color output
, rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output
}
myLoggerT :: LoggerConfig -> LoggingT m a -> m a
myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
where
mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
mylogger _ _ level str' = do
-- color output
let style' = case level of
LevelDebug -> style Bold . color Blue
LevelInfo -> style Bold . color Green
LevelWarn -> style Bold . color Yellow
LevelError -> style Bold . color Red
LevelOther _ -> id
let l = case level of
LevelDebug -> toLogStr (style' "[ Debug ]")
LevelInfo -> toLogStr (style' "[ Info ]")
LevelWarn -> toLogStr (style' "[ Warn ]")
LevelError -> toLogStr (style' "[ Error ]")
LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
let strs = fmap toLogStr . B.split (fromIntegral $ ord '\n') . fromLogStr $ str'
let out = case strs of
[] -> B.empty
(x:xs) -> fromLogStr
. foldr (\a b -> a <> toLogStr "\n" <> b) mempty
. ((l <> toLogStr " " <> x) :)
. fmap (\line' -> toLogStr (style' "[ ... ] ") <> line' )
$ xs
when (lcPrintDebug || (not lcPrintDebug && (level /= LevelDebug)))
$ colorOutter out
-- raw output
let lr = case level of
LevelDebug -> toLogStr "Debug:"
LevelInfo -> toLogStr "Info:"
LevelWarn -> toLogStr "Warn:"
LevelError -> toLogStr "Error:"
LevelOther t -> toLogStr t <> toLogStr ":"
let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
rawOutter outr
initGHCupFileLogging :: ( MonadReader env m initGHCupFileLogging :: ( MonadReader env m
, HasDirs env , HasDirs env

10
lib/GHCup/Utils/Prelude.hs
View File

@ -5,7 +5,6 @@
{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TemplateHaskell #-}
{-| {-|
Module : GHCup.Utils.Prelude Module : GHCup.Utils.Prelude
@ -30,7 +29,6 @@ import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Logger
import Data.Bifunctor import Data.Bifunctor
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.List ( nub, intercalate, stripPrefix, isPrefixOf ) import Data.List ( nub, intercalate, stripPrefix, isPrefixOf )
@ -176,8 +174,12 @@ lEM' :: forall e' e es a m
lEM' f em = lift em >>= lE . first f lEM' f em = lift em >>= lE . first f
-- for some obscure reason... this won't type-check if we move it to a different module -- for some obscure reason... this won't type-check if we move it to a different module
catchWarn :: forall es m . (Pretty (V es), MonadLogger m, Monad m) => Excepts es m () -> Excepts '[] m () catchWarn :: forall es m env . ( Pretty (V es)
catchWarn = catchAllE @_ @es (\v -> lift $ $(logWarn) (T.pack . prettyShow $ v)) , MonadReader env m
, HasLog env
, MonadIO m
, Monad m) => Excepts es m () -> Excepts '[] m ()
catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v))
fromEither :: Either a b -> VEither '[a] b fromEither :: Either a b -> VEither '[a] b
fromEither = either (VLeft . V) VRight fromEither = either (VLeft . V) VRight