Julian Ospald
7a2a5074fa
This is a major refactor of some CLI code. We try to distinguish GHC versions from other versions, so that we can use distinct parsers. Hopefully this doesn't introduce new bugs. This also forces ghcup run to use the new internal ~/.ghcup/tmp dir.
353 lines
10 KiB
Haskell
353 lines
10 KiB
Haskell
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE DataKinds #-}
|
|
{-# LANGUAGE TypeApplications #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE DuplicateRecordFields #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module GHCup.OptParse.Set where
|
|
|
|
|
|
|
|
|
|
import GHCup.OptParse.Common
|
|
|
|
import GHCup
|
|
import GHCup.Errors
|
|
import GHCup.Types
|
|
import GHCup.Prelude.Logger
|
|
import GHCup.Prelude.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.Either
|
|
import Data.Functor
|
|
import Data.Maybe
|
|
import Data.Versions hiding ( str )
|
|
import GHC.Unicode
|
|
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 Data.Bifunctor (second)
|
|
import Control.Exception.Safe (MonadMask)
|
|
import GHCup.Types.Optics
|
|
|
|
|
|
|
|
|
|
----------------
|
|
--[ Commands ]--
|
|
----------------
|
|
|
|
|
|
data SetCommand = SetGHC SetOptions
|
|
| SetCabal SetOptions
|
|
| SetHLS SetOptions
|
|
| SetStack SetOptions
|
|
|
|
|
|
|
|
|
|
---------------
|
|
--[ Options ]--
|
|
---------------
|
|
|
|
|
|
data SetOptions = SetOptions
|
|
{ sToolVer :: SetToolVersion
|
|
}
|
|
|
|
|
|
|
|
|
|
---------------
|
|
--[ Parsers ]--
|
|
---------------
|
|
|
|
|
|
setParser :: Parser (Either SetCommand SetOptions)
|
|
setParser =
|
|
(Left <$> subparser
|
|
( command
|
|
"ghc"
|
|
( SetGHC
|
|
<$> info
|
|
(setOpts GHC <**> helper)
|
|
( progDesc "Set GHC version"
|
|
<> footerDoc (Just $ text setGHCFooter)
|
|
)
|
|
)
|
|
<> command
|
|
"cabal"
|
|
( SetCabal
|
|
<$> info
|
|
(setOpts Cabal <**> helper)
|
|
( progDesc "Set Cabal version"
|
|
<> footerDoc (Just $ text setCabalFooter)
|
|
)
|
|
)
|
|
<> command
|
|
"hls"
|
|
( SetHLS
|
|
<$> info
|
|
(setOpts HLS <**> helper)
|
|
( progDesc "Set haskell-language-server version"
|
|
<> footerDoc (Just $ text setHLSFooter)
|
|
)
|
|
)
|
|
<> command
|
|
"stack"
|
|
( SetStack
|
|
<$> info
|
|
(setOpts Stack <**> helper)
|
|
( progDesc "Set stack version"
|
|
<> footerDoc (Just $ text setStackFooter)
|
|
)
|
|
)
|
|
)
|
|
)
|
|
<|> (Right <$> setOpts GHC)
|
|
where
|
|
setGHCFooter :: String
|
|
setGHCFooter = [s|Discussion:
|
|
Sets the the current GHC version by creating non-versioned
|
|
symlinks for all ghc binaries of the specified version in
|
|
"~/.ghcup/bin/<binary>".|]
|
|
|
|
setCabalFooter :: String
|
|
setCabalFooter = [s|Discussion:
|
|
Sets the the current Cabal version.|]
|
|
|
|
setStackFooter :: String
|
|
setStackFooter = [s|Discussion:
|
|
Sets the the current Stack version.|]
|
|
|
|
setHLSFooter :: String
|
|
setHLSFooter = [s|Discussion:
|
|
Sets the the current haskell-language-server version.|]
|
|
|
|
|
|
setOpts :: Tool -> Parser SetOptions
|
|
setOpts tool = SetOptions <$>
|
|
(fromMaybe SetRecommended <$>
|
|
optional (setVersionArgument (Just ListInstalled) tool))
|
|
|
|
setVersionArgument :: Maybe ListCriteria -> Tool -> Parser SetToolVersion
|
|
setVersionArgument criteria tool =
|
|
argument (eitherReader setEither)
|
|
(metavar "VERSION|TAG|next"
|
|
<> completer (tagCompleter tool ["next"])
|
|
<> (completer . versionCompleter criteria) tool)
|
|
where
|
|
setEither s' =
|
|
parseSet s'
|
|
<|> second SetToolTag (tagEither s')
|
|
<|> se s'
|
|
se s' = case tool of
|
|
GHC -> second SetGHCVersion (ghcVersionEither s')
|
|
_ -> second SetToolVersion (toolVersionEither s')
|
|
parseSet s' = case fmap toLower s' of
|
|
"next" -> Right SetNext
|
|
other -> Left $ "Unknown tag/version " <> other
|
|
|
|
|
|
|
|
|
|
--------------
|
|
--[ Footer ]--
|
|
--------------
|
|
|
|
|
|
setFooter :: String
|
|
setFooter = [s|Discussion:
|
|
Sets the currently active GHC or cabal version. When no command is given,
|
|
defaults to setting GHC with the specified version/tag (if no tag
|
|
is given, sets GHC to 'recommended' version).
|
|
It is recommended to always specify a subcommand (ghc/cabal/hls/stack).|]
|
|
|
|
|
|
|
|
---------------------------
|
|
--[ Effect interpreters ]--
|
|
---------------------------
|
|
|
|
|
|
type SetGHCEffects = '[ FileDoesNotExistError
|
|
, NotInstalled
|
|
, TagNotFound
|
|
, NextVerNotFound
|
|
, NoToolVersionSet]
|
|
|
|
runSetGHC :: (ReaderT env m (VEither SetGHCEffects a) -> m (VEither SetGHCEffects a))
|
|
-> Excepts SetGHCEffects (ReaderT env m) a
|
|
-> m (VEither SetGHCEffects a)
|
|
runSetGHC runAppState =
|
|
runAppState
|
|
. runE
|
|
@SetGHCEffects
|
|
|
|
|
|
type SetCabalEffects = '[ NotInstalled
|
|
, TagNotFound
|
|
, NextVerNotFound
|
|
, NoToolVersionSet]
|
|
|
|
runSetCabal :: (ReaderT env m (VEither SetCabalEffects a) -> m (VEither SetCabalEffects a))
|
|
-> Excepts SetCabalEffects (ReaderT env m) a
|
|
-> m (VEither SetCabalEffects a)
|
|
runSetCabal runAppState =
|
|
runAppState
|
|
. runE
|
|
@SetCabalEffects
|
|
|
|
|
|
type SetHLSEffects = '[ NotInstalled
|
|
, TagNotFound
|
|
, NextVerNotFound
|
|
, NoToolVersionSet]
|
|
|
|
runSetHLS :: (ReaderT env m (VEither SetHLSEffects a) -> m (VEither SetHLSEffects a))
|
|
-> Excepts SetHLSEffects (ReaderT env m) a
|
|
-> m (VEither SetHLSEffects a)
|
|
runSetHLS runAppState =
|
|
runAppState
|
|
. runE
|
|
@SetHLSEffects
|
|
|
|
|
|
type SetStackEffects = '[ NotInstalled
|
|
, TagNotFound
|
|
, NextVerNotFound
|
|
, NoToolVersionSet]
|
|
|
|
runSetStack :: (ReaderT env m (VEither SetStackEffects a) -> m (VEither SetStackEffects a))
|
|
-> Excepts SetStackEffects (ReaderT env m) a
|
|
-> m (VEither SetStackEffects a)
|
|
runSetStack runAppState =
|
|
runAppState
|
|
. runE
|
|
@SetStackEffects
|
|
|
|
|
|
|
|
-------------------
|
|
--[ Entrypoints ]--
|
|
-------------------
|
|
|
|
|
|
set :: forall m env.
|
|
( Monad m
|
|
, MonadMask m
|
|
, MonadUnliftIO m
|
|
, MonadFail m
|
|
, HasDirs env
|
|
, HasLog env
|
|
)
|
|
=> Either SetCommand SetOptions
|
|
-> (forall eff . ReaderT AppState m (VEither eff GHCTargetVersion)
|
|
-> m (VEither eff GHCTargetVersion))
|
|
-> (forall eff. ReaderT env m (VEither eff GHCTargetVersion)
|
|
-> m (VEither eff GHCTargetVersion))
|
|
-> (ReaderT LeanAppState m () -> m ())
|
|
-> m ExitCode
|
|
set setCommand runAppState runLeanAppState runLogger = case setCommand of
|
|
(Right sopts) -> do
|
|
runLogger (logWarn "This is an old-style command for setting GHC. Use 'ghcup set ghc' instead.")
|
|
setGHC' sopts
|
|
(Left (SetGHC sopts)) -> setGHC' sopts
|
|
(Left (SetCabal sopts)) -> setCabal' sopts
|
|
(Left (SetHLS sopts)) -> setHLS' sopts
|
|
(Left (SetStack sopts)) -> setStack' sopts
|
|
|
|
where
|
|
setGHC' :: SetOptions
|
|
-> m ExitCode
|
|
setGHC' SetOptions{ sToolVer } =
|
|
case sToolVer of
|
|
(SetGHCVersion v) -> runSetGHC runLeanAppState (liftE $ setGHC v SetGHCOnly Nothing >> pure v)
|
|
_ -> runSetGHC runAppState (do
|
|
v <- liftE $ fst <$> fromVersion' sToolVer GHC
|
|
liftE $ setGHC v SetGHCOnly Nothing
|
|
)
|
|
>>= \case
|
|
VRight GHCTargetVersion{..} -> do
|
|
runLogger
|
|
$ logInfo $
|
|
"GHC " <> prettyVer _tvVersion <> " successfully set as default version" <> maybe "" (" for cross target " <>) _tvTarget
|
|
pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 5
|
|
|
|
|
|
setCabal' :: SetOptions
|
|
-> m ExitCode
|
|
setCabal' SetOptions{ sToolVer } =
|
|
case sToolVer of
|
|
(SetToolVersion v) -> runSetCabal runLeanAppState (liftE $ setCabal v >> pure (mkTVer v))
|
|
_ -> runSetCabal runAppState (do
|
|
v <- liftE $ fst <$> fromVersion' sToolVer Cabal
|
|
liftE $ setCabal (_tvVersion v)
|
|
pure v
|
|
)
|
|
>>= \case
|
|
VRight v -> do
|
|
runLogger
|
|
$ logInfo $
|
|
"Cabal " <> prettyVer (_tvVersion v) <> " successfully set as default version"
|
|
pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 14
|
|
|
|
setHLS' :: SetOptions
|
|
-> m ExitCode
|
|
setHLS' SetOptions{ sToolVer } =
|
|
case sToolVer of
|
|
(SetToolVersion v) -> runSetHLS runLeanAppState (liftE $ setHLS v SetHLSOnly Nothing >> pure (mkTVer v))
|
|
_ -> runSetHLS runAppState (do
|
|
v <- liftE $ fst <$> fromVersion' sToolVer HLS
|
|
liftE $ setHLS (_tvVersion v) SetHLSOnly Nothing
|
|
pure v
|
|
)
|
|
>>= \case
|
|
VRight v -> do
|
|
runLogger
|
|
$ logInfo $
|
|
"HLS " <> prettyVer (_tvVersion v) <> " successfully set as default version"
|
|
pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 14
|
|
|
|
|
|
setStack' :: SetOptions
|
|
-> m ExitCode
|
|
setStack' SetOptions{ sToolVer } =
|
|
case sToolVer of
|
|
(SetToolVersion v) -> runSetStack runLeanAppState (liftE $ setStack v >> pure (mkTVer v))
|
|
_ -> runSetStack runAppState (do
|
|
v <- liftE $ fst <$> fromVersion' sToolVer Stack
|
|
liftE $ setStack (_tvVersion v)
|
|
pure v
|
|
)
|
|
>>= \case
|
|
VRight v -> do
|
|
runLogger
|
|
$ logInfo $
|
|
"Stack " <> prettyVer (_tvVersion v) <> " successfully set as default version"
|
|
pure ExitSuccess
|
|
VLeft e -> do
|
|
runLogger $ logError $ T.pack $ prettyShow e
|
|
pure $ ExitFailure 14
|