ghcup-hs/app/ghcup/GHCup/OptParse/UnSet.hs
2021-10-17 19:15:24 +02:00

206 lines
5.2 KiB
Haskell

{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE RankNTypes #-}
module GHCup.OptParse.UnSet where
import GHCup
import GHCup.Errors
import GHCup.Types
import GHCup.Utils.Logger
import GHCup.Utils.String.QQ
#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 Haskus.Utils.Variant.Excepts
import Options.Applicative hiding ( style )
import Options.Applicative.Help.Pretty ( text )
import Prelude hiding ( appendFile )
import System.Exit
import Text.PrettyPrint.HughesPJClass ( prettyShow )
import qualified Data.Text as T
import Control.Exception.Safe (MonadMask)
import GHCup.Types.Optics
----------------
--[ Commands ]--
----------------
data UnsetCommand = UnsetGHC UnsetOptions
| UnsetCabal UnsetOptions
| UnsetHLS UnsetOptions
| UnsetStack UnsetOptions
---------------
--[ Options ]--
---------------
data UnsetOptions = UnsetOptions
{ sToolVer :: Maybe T.Text -- target platform triple
}
---------------
--[ Parsers ]--
---------------
unsetParser :: Parser UnsetCommand
unsetParser =
subparser
( command
"ghc"
( UnsetGHC
<$> info
(unsetOpts <**> helper)
( progDesc "Unset GHC version"
<> footerDoc (Just $ text unsetGHCFooter)
)
)
<> command
"cabal"
( UnsetCabal
<$> info
(unsetOpts <**> helper)
( progDesc "Unset Cabal version"
<> footerDoc (Just $ text unsetCabalFooter)
)
)
<> command
"hls"
( UnsetHLS
<$> info
(unsetOpts <**> helper)
( progDesc "Unset haskell-language-server version"
<> footerDoc (Just $ text unsetHLSFooter)
)
)
<> command
"stack"
( UnsetStack
<$> info
(unsetOpts <**> helper)
( progDesc "Unset stack version"
<> footerDoc (Just $ text unsetStackFooter)
)
)
)
where
unsetGHCFooter :: String
unsetGHCFooter = [s|Discussion:
Unsets the the current GHC version. That means there won't
be a ~/.ghcup/bin/ghc anymore.|]
unsetCabalFooter :: String
unsetCabalFooter = [s|Discussion:
Unsets the the current Cabal version.|]
unsetStackFooter :: String
unsetStackFooter = [s|Discussion:
Unsets the the current Stack version.|]
unsetHLSFooter :: String
unsetHLSFooter = [s|Discussion:
Unsets the the current haskell-language-server version.|]
unsetOpts :: Parser UnsetOptions
unsetOpts = UnsetOptions . fmap T.pack <$> optional (argument str (metavar "TRIPLE"))
--------------
--[ Footer ]--
--------------
unsetFooter :: String
unsetFooter = [s|Discussion:
Unsets the currently active GHC or cabal version.|]
---------------------------
--[ Effect interpreters ]--
---------------------------
type UnsetEffects = '[ NotInstalled ]
runUnsetGHC :: (ReaderT env m (VEither UnsetEffects a) -> m (VEither UnsetEffects a))
-> Excepts UnsetEffects (ReaderT env m) a
-> m (VEither UnsetEffects a)
runUnsetGHC runLeanAppState =
runLeanAppState
. runE
@UnsetEffects
------------------
--[ Entrypoint ]--
------------------
unset :: ( Monad m
, MonadMask m
, MonadUnliftIO m
, MonadFail m
, HasDirs env
, HasLog env
)
=> UnsetCommand
-> (ReaderT env m (VEither UnsetEffects ())
-> m (VEither UnsetEffects ()))
-> (ReaderT LeanAppState m () -> m ())
-> m ExitCode
unset unsetCommand runLeanAppState runLogger = case unsetCommand of
(UnsetGHC (UnsetOptions triple)) -> runUnsetGHC runLeanAppState (unsetGHC triple)
>>= \case
VRight _ -> do
runLogger $ logInfo "GHC successfully unset"
pure ExitSuccess
VLeft e -> do
runLogger $ logError $ T.pack $ prettyShow e
pure $ ExitFailure 14
(UnsetCabal (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetCabal)
runLogger $ logInfo "Cabal successfully unset"
pure ExitSuccess
(UnsetHLS (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetHLS)
runLogger $ logInfo "HLS successfully unset"
pure ExitSuccess
(UnsetStack (UnsetOptions _)) -> do
void $ runLeanAppState (VRight <$> unsetStack)
runLogger $ logInfo "Stack successfully unset"
pure ExitSuccess