ghcup-hs/lib-opt/GHCup/OptParse/Rm.hs

233 lines
5.8 KiB
Haskell
Raw Permalink Normal View History

2021-10-15 20:24:23 +00:00
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.Rm where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Types.Optics
import GHCup.Utils
2022-05-21 20:54:18 +00:00
import GHCup.Prelude.Logger
import GHCup.Prelude.String.QQ
2021-10-15 20:24:23 +00:00
import GHCup.OptParse.Common
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Functor
import Data.Maybe
import Data.Versions
2021-10-15 20:24:23 +00:00
import Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Prelude hiding ( appendFile )
import System.Exit
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
----------------
--[ Commands ]--
----------------
data RmCommand = RmGHC RmOptions
| RmCabal Version
| RmHLS Version
| RmStack Version
2023-07-23 08:30:25 +00:00
deriving (Eq, Show)
2021-10-15 20:24:23 +00:00
---------------
--[ Options ]--
---------------
data RmOptions = RmOptions
{ ghcVer :: GHCTargetVersion
2023-07-23 08:30:25 +00:00
} deriving (Eq, Show)
2021-10-15 20:24:23 +00:00
---------------
--[ Parsers ]--
---------------
2021-10-15 20:24:23 +00:00
rmParser :: Parser (Either RmCommand RmOptions)
rmParser =
(Left <$> subparser
( command
"ghc"
(RmGHC <$> info (rmOpts (Just GHC) <**> helper) (progDesc "Remove GHC version"))
<> command
"cabal"
( RmCabal
<$> info (versionParser' [ListInstalled True] (Just Cabal) <**> helper)
2021-10-15 20:24:23 +00:00
(progDesc "Remove Cabal version")
)
<> command
"hls"
( RmHLS
<$> info (versionParser' [ListInstalled True] (Just HLS) <**> helper)
2021-10-15 20:24:23 +00:00
(progDesc "Remove haskell-language-server version")
)
<> command
"stack"
( RmStack
<$> info (versionParser' [ListInstalled True] (Just Stack) <**> helper)
2021-10-15 20:24:23 +00:00
(progDesc "Remove stack version")
)
)
)
<|> (Right <$> rmOpts Nothing)
rmOpts :: Maybe Tool -> Parser RmOptions
rmOpts tool = RmOptions <$> ghcVersionArgument [ListInstalled True] tool
2021-10-15 20:24:23 +00:00
--------------
--[ Footer ]--
--------------
rmFooter :: String
rmFooter = [s|Discussion:
Remove the given GHC or cabal version. When no command is given,
defaults to removing GHC with the specified version.
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type RmEffects = '[ NotInstalled, UninstallFailed ]
2021-10-15 20:24:23 +00:00
runRm :: (ReaderT env m (VEither RmEffects a) -> m (VEither RmEffects a))
-> Excepts RmEffects (ReaderT env m) a
-> m (VEither RmEffects a)
runRm runAppState =
runAppState
. runE
@RmEffects
------------------
--[ Entrypoint ]--
------------------
rm :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
)
=> Either RmCommand RmOptions
-> (ReaderT AppState m (VEither RmEffects (Maybe VersionInfo))
-> m (VEither RmEffects (Maybe VersionInfo)))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
rm rmCommand runAppState runLogger = case rmCommand of
(Right rmopts) -> do
runLogger (logWarn "This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.")
rmGHC' rmopts
(Left (RmGHC rmopts)) -> rmGHC' rmopts
(Left (RmCabal rmopts)) -> rmCabal' rmopts
(Left (RmHLS rmopts)) -> rmHLS' rmopts
(Left (RmStack rmopts)) -> rmStack' rmopts
where
rmGHC' RmOptions{..} =
runRm runAppState (do
liftE $
rmGHCVer ghcVer
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2023-07-07 08:41:58 +00:00
pure (getVersionInfo ghcVer GHC dls)
2021-10-15 20:24:23 +00:00
)
>>= \case
VRight vi -> do
2022-12-20 13:28:49 +00:00
runLogger $ logGHCPostRm ghcVer
postRmLog vi
2021-10-15 20:24:23 +00:00
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e
2021-10-15 20:24:23 +00:00
pure $ ExitFailure 7
rmCabal' tv =
runRm runAppState (do
liftE $
rmCabalVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2023-07-07 08:41:58 +00:00
pure (getVersionInfo (mkTVer tv) Cabal dls)
2021-10-15 20:24:23 +00:00
)
>>= \case
VRight vi -> do
2022-12-20 13:28:49 +00:00
postRmLog vi
2021-10-15 20:24:23 +00:00
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e
2021-10-15 20:24:23 +00:00
pure $ ExitFailure 15
rmHLS' tv =
runRm runAppState (do
liftE $
rmHLSVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2023-07-07 08:41:58 +00:00
pure (getVersionInfo (mkTVer tv) HLS dls)
2021-10-15 20:24:23 +00:00
)
>>= \case
VRight vi -> do
2022-12-20 13:28:49 +00:00
postRmLog vi
2021-10-15 20:24:23 +00:00
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e
2021-10-15 20:24:23 +00:00
pure $ ExitFailure 15
rmStack' tv =
runRm runAppState (do
liftE $
rmStackVer tv
GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo
2023-07-07 08:41:58 +00:00
pure (getVersionInfo (mkTVer tv) Stack dls)
2021-10-15 20:24:23 +00:00
)
>>= \case
VRight vi -> do
2022-12-20 13:28:49 +00:00
postRmLog vi
2021-10-15 20:24:23 +00:00
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyHFError e
2021-10-15 20:24:23 +00:00
pure $ ExitFailure 15
2022-12-20 13:28:49 +00:00
postRmLog vi =
forM_ (_viPostRemove =<< vi) $ \msg ->
runLogger $ logInfo msg