Compare commits
1 Commits
| Author | SHA1 | Date | |
|---|---|---|---|
|
2b6d970723
|
@@ -113,8 +113,8 @@ data Command
|
|||||||
opts :: Parser Options
|
opts :: Parser Options
|
||||||
opts =
|
opts =
|
||||||
Options
|
Options
|
||||||
<$> invertableSwitch "verbose" (Just 'v') False (help "Enable verbosity (default: disabled)")
|
<$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)")
|
||||||
<*> invertableSwitch "cache" (Just 'c') False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
|
<*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)")
|
||||||
<*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal))
|
<*> optional (option auto (long "metadata-caching" <> help "How long the yaml metadata caching interval is (in seconds), 0 to disable" <> internal))
|
||||||
<*> optional
|
<*> optional
|
||||||
(option
|
(option
|
||||||
@@ -127,7 +127,7 @@ opts =
|
|||||||
<> completer fileUri
|
<> completer fileUri
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
<*> (fmap . fmap) not (invertableSwitch "verify" (Just 'n') True (help "Disable tarball checksum verification (default: enabled)"))
|
<*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)"))
|
||||||
<*> optional (option
|
<*> optional (option
|
||||||
(eitherReader keepOnParser)
|
(eitherReader keepOnParser)
|
||||||
( long "keep"
|
( long "keep"
|
||||||
@@ -153,7 +153,7 @@ opts =
|
|||||||
#endif
|
#endif
|
||||||
<> hidden
|
<> hidden
|
||||||
))
|
))
|
||||||
<*> invertableSwitch "offline" (Just 'o') False (help "Don't do any network calls, trying cached assets and failing if missing.")
|
<*> invertableSwitch "offline" 'o' False (help "Don't do any network calls, trying cached assets and failing if missing.")
|
||||||
<*> optional (option
|
<*> optional (option
|
||||||
(eitherReader gpgParser)
|
(eitherReader gpgParser)
|
||||||
( long "gpg"
|
( long "gpg"
|
||||||
|
|||||||
@@ -138,7 +138,7 @@ versionArgument criteria tool = argument (eitherReader tVersionEither) (metavar
|
|||||||
-- the help is shown only for --no-recursive.
|
-- the help is shown only for --no-recursive.
|
||||||
invertableSwitch
|
invertableSwitch
|
||||||
:: String -- ^ long option
|
:: String -- ^ long option
|
||||||
-> Maybe Char -- ^ short option for the non-default option
|
-> Char -- ^ short option for the non-default option
|
||||||
-> Bool -- ^ is switch enabled by default?
|
-> Bool -- ^ is switch enabled by default?
|
||||||
-> Mod FlagFields Bool -- ^ option modifier
|
-> Mod FlagFields Bool -- ^ option modifier
|
||||||
-> Parser (Maybe Bool)
|
-> Parser (Maybe Bool)
|
||||||
@@ -149,14 +149,14 @@ invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shorto
|
|||||||
-- | Allows providing option modifiers for both --foo and --no-foo.
|
-- | Allows providing option modifiers for both --foo and --no-foo.
|
||||||
invertableSwitch'
|
invertableSwitch'
|
||||||
:: String -- ^ long option (eg "foo")
|
:: String -- ^ long option (eg "foo")
|
||||||
-> Maybe Char -- ^ short option for the non-default option
|
-> Char -- ^ short option for the non-default option
|
||||||
-> Bool -- ^ is switch enabled by default?
|
-> Bool -- ^ is switch enabled by default?
|
||||||
-> Mod FlagFields Bool -- ^ option modifier for --foo
|
-> Mod FlagFields Bool -- ^ option modifier for --foo
|
||||||
-> Mod FlagFields Bool -- ^ option modifier for --no-foo
|
-> Mod FlagFields Bool -- ^ option modifier for --no-foo
|
||||||
-> Parser (Maybe Bool)
|
-> Parser (Maybe Bool)
|
||||||
invertableSwitch' longopt shortopt defv enmod dismod = optional
|
invertableSwitch' longopt shortopt defv enmod dismod = optional
|
||||||
( flag' True ( enmod <> long longopt <> if defv then mempty else maybe mempty short shortopt)
|
( flag' True ( enmod <> long longopt <> if defv then mempty else short shortopt)
|
||||||
<|> flag' False (dismod <> long nolongopt <> if defv then maybe mempty short shortopt else mempty)
|
<|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
nolongopt = "no-" ++ longopt
|
nolongopt = "no-" ++ longopt
|
||||||
|
|||||||
@@ -234,7 +234,12 @@ ghcCompileOpts =
|
|||||||
)
|
)
|
||||||
)
|
)
|
||||||
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
|
<*> many (argument str (metavar "CONFIGURE_ARGS" <> help "Additional arguments to configure, prefix with '-- ' (longopts)"))
|
||||||
<*> fmap (fromMaybe False) (invertableSwitch "set" Nothing False (help "Set as active version after install"))
|
<*> flag
|
||||||
|
False
|
||||||
|
True
|
||||||
|
(long "set" <> help
|
||||||
|
"Set as active version after install"
|
||||||
|
)
|
||||||
<*> optional
|
<*> optional
|
||||||
(option
|
(option
|
||||||
(eitherReader
|
(eitherReader
|
||||||
@@ -295,7 +300,12 @@ hlsCompileOpts =
|
|||||||
<> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
|
<> (completer $ listCompleter $ fmap show ([1..12] :: [Int]))
|
||||||
)
|
)
|
||||||
)
|
)
|
||||||
<*> fmap (fromMaybe True) (invertableSwitch "set" Nothing True (help "Don't set as active version after install"))
|
<*> flag
|
||||||
|
False
|
||||||
|
True
|
||||||
|
(long "set" <> help
|
||||||
|
"Set as active version after install"
|
||||||
|
)
|
||||||
<*> optional
|
<*> optional
|
||||||
(option
|
(option
|
||||||
(eitherReader
|
(eitherReader
|
||||||
|
|||||||
@@ -7,6 +7,7 @@
|
|||||||
{-# LANGUAGE OverloadedStrings #-}
|
{-# LANGUAGE OverloadedStrings #-}
|
||||||
{-# LANGUAGE DuplicateRecordFields #-}
|
{-# LANGUAGE DuplicateRecordFields #-}
|
||||||
{-# LANGUAGE RankNTypes #-}
|
{-# LANGUAGE RankNTypes #-}
|
||||||
|
{-# LANGUAGE ExplicitForAll #-}
|
||||||
|
|
||||||
module GHCup.OptParse.Config where
|
module GHCup.OptParse.Config where
|
||||||
|
|
||||||
@@ -17,6 +18,7 @@ import GHCup.Utils
|
|||||||
import GHCup.Utils.Prelude
|
import GHCup.Utils.Prelude
|
||||||
import GHCup.Utils.Logger
|
import GHCup.Utils.Logger
|
||||||
import GHCup.Utils.String.QQ
|
import GHCup.Utils.String.QQ
|
||||||
|
import GHCup.OptParse.Common
|
||||||
|
|
||||||
#if !MIN_VERSION_base(4,13,0)
|
#if !MIN_VERSION_base(4,13,0)
|
||||||
import Control.Monad.Fail ( MonadFail )
|
import Control.Monad.Fail ( MonadFail )
|
||||||
@@ -27,10 +29,11 @@ import Control.Monad.Trans.Resource
|
|||||||
import Data.Functor
|
import Data.Functor
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Options.Applicative hiding ( style )
|
import Options.Applicative hiding ( style, ParseError )
|
||||||
import Options.Applicative.Help.Pretty ( text )
|
import Options.Applicative.Help.Pretty ( text )
|
||||||
import Prelude hiding ( appendFile )
|
import Prelude hiding ( appendFile )
|
||||||
import System.Exit
|
import System.Exit
|
||||||
|
import URI.ByteString hiding ( uriParser )
|
||||||
|
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import qualified Data.ByteString.UTF8 as UTF8
|
import qualified Data.ByteString.UTF8 as UTF8
|
||||||
@@ -49,6 +52,7 @@ data ConfigCommand
|
|||||||
= ShowConfig
|
= ShowConfig
|
||||||
| SetConfig String (Maybe String)
|
| SetConfig String (Maybe String)
|
||||||
| InitConfig
|
| InitConfig
|
||||||
|
| AddReleaseChannel URI
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -62,6 +66,7 @@ configP = subparser
|
|||||||
( command "init" initP
|
( command "init" initP
|
||||||
<> command "set" setP -- [set] KEY VALUE at help lhs
|
<> command "set" setP -- [set] KEY VALUE at help lhs
|
||||||
<> command "show" showP
|
<> command "show" showP
|
||||||
|
<> command "add-release-channel" addP
|
||||||
)
|
)
|
||||||
<|> argsP -- add show for a single option
|
<|> argsP -- add show for a single option
|
||||||
<|> pure ShowConfig
|
<|> pure ShowConfig
|
||||||
@@ -70,6 +75,8 @@ configP = subparser
|
|||||||
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
|
showP = info (pure ShowConfig) (progDesc "Show current config (default)")
|
||||||
setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
|
setP = info argsP (progDesc "Set config KEY to VALUE (or specify as single json value)" <> footerDoc (Just $ text configSetFooter))
|
||||||
argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
|
argsP = SetConfig <$> argument str (metavar "<JSON_VALUE | YAML_KEY>") <*> optional (argument str (metavar "YAML_VALUE"))
|
||||||
|
addP = info (AddReleaseChannel <$> argument (eitherReader uriParser) (metavar "URI" <> completer fileUri))
|
||||||
|
(progDesc "Add a release channel from a URI")
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -114,23 +121,18 @@ formatConfig :: UserSettings -> String
|
|||||||
formatConfig = UTF8.toString . Y.encode
|
formatConfig = UTF8.toString . Y.encode
|
||||||
|
|
||||||
|
|
||||||
updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
|
updateSettings :: UserSettings -> Settings -> Settings
|
||||||
updateSettings config' settings = do
|
updateSettings UserSettings{..} Settings{..} =
|
||||||
settings' <- lE' (JSONDecodeError . displayException) . Y.decodeEither' $ config'
|
let cache' = fromMaybe cache uCache
|
||||||
pure $ mergeConf settings' settings
|
metaCache' = fromMaybe metaCache uMetaCache
|
||||||
where
|
noVerify' = fromMaybe noVerify uNoVerify
|
||||||
mergeConf :: UserSettings -> Settings -> Settings
|
keepDirs' = fromMaybe keepDirs uKeepDirs
|
||||||
mergeConf UserSettings{..} Settings{..} =
|
downloader' = fromMaybe downloader uDownloader
|
||||||
let cache' = fromMaybe cache uCache
|
verbose' = fromMaybe verbose uVerbose
|
||||||
metaCache' = fromMaybe metaCache uMetaCache
|
urlSource' = fromMaybe urlSource uUrlSource
|
||||||
noVerify' = fromMaybe noVerify uNoVerify
|
noNetwork' = fromMaybe noNetwork uNoNetwork
|
||||||
keepDirs' = fromMaybe keepDirs uKeepDirs
|
gpgSetting' = fromMaybe gpgSetting uGPGSetting
|
||||||
downloader' = fromMaybe downloader uDownloader
|
in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
|
||||||
verbose' = fromMaybe verbose uVerbose
|
|
||||||
urlSource' = fromMaybe urlSource uUrlSource
|
|
||||||
noNetwork' = fromMaybe noNetwork uNoNetwork
|
|
||||||
gpgSetting' = fromMaybe gpgSetting uGPGSetting
|
|
||||||
in Settings cache' metaCache' noVerify' keepDirs' downloader' verbose' urlSource' noNetwork' gpgSetting' noColor
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -140,7 +142,7 @@ updateSettings config' settings = do
|
|||||||
|
|
||||||
|
|
||||||
|
|
||||||
config :: ( Monad m
|
config :: forall m. ( Monad m
|
||||||
, MonadMask m
|
, MonadMask m
|
||||||
, MonadUnliftIO m
|
, MonadUnliftIO m
|
||||||
, MonadFail m
|
, MonadFail m
|
||||||
@@ -161,27 +163,42 @@ config configCommand settings keybindings runLogger = case configCommand of
|
|||||||
liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
|
liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
|
||||||
pure ExitSuccess
|
pure ExitSuccess
|
||||||
|
|
||||||
(SetConfig k (Just v)) ->
|
(SetConfig k mv) -> do
|
||||||
case v of
|
r <- runE @'[JSONError, ParseError] $ do
|
||||||
"" -> do
|
case mv of
|
||||||
runLogger $ logError "Empty values are not allowed"
|
Just "" ->
|
||||||
pure $ ExitFailure 55
|
throwE $ ParseError "Empty values are not allowed"
|
||||||
_ -> doConfig (k <> ": " <> v <> "\n")
|
Nothing -> do
|
||||||
|
usersettings <- decodeSettings k
|
||||||
|
lift $ doConfig usersettings
|
||||||
|
pure ()
|
||||||
|
Just v -> do
|
||||||
|
usersettings <- decodeSettings (k <> ": " <> v <> "\n")
|
||||||
|
lift $ doConfig usersettings
|
||||||
|
pure ()
|
||||||
|
case r of
|
||||||
|
VRight _ -> pure ExitSuccess
|
||||||
|
VLeft (V (JSONDecodeError e)) -> do
|
||||||
|
runLogger $ logError $ "Error decoding config: " <> T.pack e
|
||||||
|
pure $ ExitFailure 65
|
||||||
|
VLeft _ -> pure $ ExitFailure 65
|
||||||
|
|
||||||
(SetConfig json Nothing) -> doConfig json
|
AddReleaseChannel uri -> do
|
||||||
|
case urlSource settings of
|
||||||
|
AddSource xs -> do
|
||||||
|
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource (xs <> [Right uri]) })
|
||||||
|
pure ExitSuccess
|
||||||
|
_ -> do
|
||||||
|
doConfig (defaultUserSettings { uUrlSource = Just $ AddSource [Right uri] })
|
||||||
|
pure ExitSuccess
|
||||||
|
|
||||||
where
|
where
|
||||||
doConfig val = do
|
doConfig :: MonadIO m => UserSettings -> m ()
|
||||||
r <- runE @'[JSONError] $ do
|
doConfig usersettings = do
|
||||||
settings' <- updateSettings (UTF8.fromString val) settings
|
let settings' = updateSettings usersettings settings
|
||||||
path <- liftIO getConfigFilePath
|
path <- liftIO getConfigFilePath
|
||||||
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
|
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
|
||||||
lift $ runLogger $ logDebug $ T.pack $ show settings'
|
runLogger $ logDebug $ T.pack $ show settings'
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
case r of
|
decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString
|
||||||
VRight _ -> pure ExitSuccess
|
|
||||||
VLeft (V (JSONDecodeError e)) -> do
|
|
||||||
runLogger $ logError $ "Error decoding config: " <> T.pack e
|
|
||||||
pure $ ExitFailure 65
|
|
||||||
VLeft _ -> pure $ ExitFailure 65
|
|
||||||
|
|||||||
@@ -197,8 +197,12 @@ installOpts tool =
|
|||||||
)
|
)
|
||||||
<|> pure (Nothing, Nothing)
|
<|> pure (Nothing, Nothing)
|
||||||
)
|
)
|
||||||
<*> fmap (fromMaybe setDefault) (invertableSwitch "set" Nothing setDefault
|
<*> flag
|
||||||
(help $ if not setDefault then "Set as active version after install" else "Don't set as active version after install"))
|
False
|
||||||
|
True
|
||||||
|
(long "set" <> help
|
||||||
|
"Set as active version after install"
|
||||||
|
)
|
||||||
<*> optional
|
<*> optional
|
||||||
(option
|
(option
|
||||||
(eitherReader isolateParser)
|
(eitherReader isolateParser)
|
||||||
@@ -211,11 +215,6 @@ installOpts tool =
|
|||||||
)
|
)
|
||||||
<*> switch
|
<*> switch
|
||||||
(short 'f' <> long "force" <> help "Force install")
|
(short 'f' <> long "force" <> help "Force install")
|
||||||
where
|
|
||||||
setDefault = case tool of
|
|
||||||
Nothing -> False
|
|
||||||
Just GHC -> False
|
|
||||||
Just _ -> True
|
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
@@ -398,7 +397,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
isolateDir
|
isolateDir
|
||||||
forceInstall
|
forceInstall
|
||||||
)
|
)
|
||||||
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
|
$ when instSet $ void $ setGHC v SetGHCOnly Nothing
|
||||||
pure vi
|
pure vi
|
||||||
Just uri -> do
|
Just uri -> do
|
||||||
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
|
runInstGHC s'{ settings = settings {noVerify = True}} instPlatform $ do
|
||||||
@@ -409,7 +408,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
isolateDir
|
isolateDir
|
||||||
forceInstall
|
forceInstall
|
||||||
)
|
)
|
||||||
$ when instSet $ when (isNothing isolateDir) $ void $ setGHC v SetGHCOnly Nothing
|
$ when instSet $ void $ setGHC v SetGHCOnly Nothing
|
||||||
pure vi
|
pure vi
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
@@ -469,7 +468,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
v
|
v
|
||||||
isolateDir
|
isolateDir
|
||||||
forceInstall
|
forceInstall
|
||||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
|
) $ when instSet $ void $ setCabal v
|
||||||
pure vi
|
pure vi
|
||||||
Just uri -> do
|
Just uri -> do
|
||||||
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||||
@@ -479,7 +478,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
v
|
v
|
||||||
isolateDir
|
isolateDir
|
||||||
forceInstall
|
forceInstall
|
||||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setCabal v
|
) $ when instSet $ void $ setCabal v
|
||||||
pure vi
|
pure vi
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
@@ -520,7 +519,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
v
|
v
|
||||||
isolateDir
|
isolateDir
|
||||||
forceInstall
|
forceInstall
|
||||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
|
) $ when instSet $ void $ setHLS v SetHLSOnly Nothing
|
||||||
pure vi
|
pure vi
|
||||||
Just uri -> do
|
Just uri -> do
|
||||||
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||||
@@ -531,7 +530,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
v
|
v
|
||||||
isolateDir
|
isolateDir
|
||||||
forceInstall
|
forceInstall
|
||||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setHLS v SetHLSOnly Nothing
|
) $ when instSet $ void $ setHLS v SetHLSOnly Nothing
|
||||||
pure vi
|
pure vi
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
@@ -580,7 +579,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
v
|
v
|
||||||
isolateDir
|
isolateDir
|
||||||
forceInstall
|
forceInstall
|
||||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
|
) $ when instSet $ void $ setStack v
|
||||||
pure vi
|
pure vi
|
||||||
Just uri -> do
|
Just uri -> do
|
||||||
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
runInstTool s'{ settings = settings { noVerify = True}} instPlatform $ do
|
||||||
@@ -590,7 +589,7 @@ install installCommand settings getAppState' runLogger = case installCommand of
|
|||||||
v
|
v
|
||||||
isolateDir
|
isolateDir
|
||||||
forceInstall
|
forceInstall
|
||||||
) $ when instSet $ when (isNothing isolateDir) $ void $ setStack v
|
) $ when instSet $ void $ setStack v
|
||||||
pure vi
|
pure vi
|
||||||
)
|
)
|
||||||
>>= \case
|
>>= \case
|
||||||
|
|||||||
@@ -82,7 +82,7 @@ toSettings options = do
|
|||||||
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
|
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
|
||||||
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
||||||
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
|
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings
|
||||||
urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) OwnSource optUrlSource
|
urlSource = maybe (fromMaybe (Types.urlSource defaultSettings) uUrlSource) (OwnSource . (:[]) . Right) optUrlSource
|
||||||
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
|
noNetwork = fromMaybe (fromMaybe (Types.noNetwork defaultSettings) uNoNetwork) optNoNetwork
|
||||||
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
|
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
|
||||||
in (Settings {..}, keyBindings)
|
in (Settings {..}, keyBindings)
|
||||||
|
|||||||
@@ -48,12 +48,16 @@ url-source:
|
|||||||
|
|
||||||
## Example 1: Read download info from this location instead
|
## Example 1: Read download info from this location instead
|
||||||
## Accepts file/http/https scheme
|
## Accepts file/http/https scheme
|
||||||
|
## Can also be an array of URLs or an array of 'Either GHCupInfo URL', in
|
||||||
|
## which case they are merged right-biased (overwriting duplicate versions).
|
||||||
# OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
|
# OwnSource: "file:///home/jule/git/ghcup-hs/ghcup-0.0.3.yaml"
|
||||||
|
|
||||||
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions
|
## Example 2: Add custom tarballs to the default downloads, overwriting duplicate versions.
|
||||||
|
## Can also be an array of 'Either GHCupInfo URL', also see Example 3.
|
||||||
# AddSource:
|
# AddSource:
|
||||||
# Left:
|
# Left:
|
||||||
# toolRequirements: {} # this is ignored
|
# globalTools: {}
|
||||||
|
# toolRequirements: {}
|
||||||
# ghcupDownloads:
|
# ghcupDownloads:
|
||||||
# GHC:
|
# GHC:
|
||||||
# 9.10.2:
|
# 9.10.2:
|
||||||
@@ -66,6 +70,8 @@ url-source:
|
|||||||
# dlSubdir: ghc-7.10.3
|
# dlSubdir: ghc-7.10.3
|
||||||
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
|
# dlHash: 01cfbad8dff1e8b34a5fdca8caeaf843b56e36af919e29cd68870d2588563db5
|
||||||
|
|
||||||
## Example 3: Add a custom download file to the default downloads, overwriting duplicate versions
|
## Example 3: Add multiple custom download files to the default downloads via right-biased merge (overwriting duplicate
|
||||||
|
## versions).
|
||||||
# AddSource:
|
# AddSource:
|
||||||
# Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
|
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-prereleases.yaml"
|
||||||
|
# - Right: "file:///home/jule/git/ghcup-hs/ghcup-custom.yaml"
|
||||||
|
|||||||
25
lib/GHCup.hs
25
lib/GHCup.hs
@@ -468,6 +468,10 @@ installCabalBindist dlinfo ver isoFilepath forceInstall = do
|
|||||||
Nothing -> do -- regular install
|
Nothing -> do -- regular install
|
||||||
liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall
|
liftE $ installCabalUnpacked workdir binDir (Just ver) forceInstall
|
||||||
|
|
||||||
|
-- create symlink if this is the latest version for regular installs
|
||||||
|
cVers <- lift $ fmap rights getInstalledCabals
|
||||||
|
let lInstCabal = headMay . reverse . sort $ cVers
|
||||||
|
when (maybe True (ver >=) lInstCabal) $ liftE $ setCabal ver
|
||||||
|
|
||||||
-- | Install an unpacked cabal distribution.Symbol
|
-- | Install an unpacked cabal distribution.Symbol
|
||||||
installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)
|
installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m)
|
||||||
@@ -622,6 +626,7 @@ installHLSBindist dlinfo ver isoFilepath forceInstall = do
|
|||||||
liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver
|
liftE $ runBuildAction tmpUnpack Nothing $ installHLSUnpacked workdir inst ver
|
||||||
liftE $ setHLS ver SetHLS_XYZ Nothing
|
liftE $ setHLS ver SetHLS_XYZ Nothing
|
||||||
|
|
||||||
|
liftE $ installHLSPostInst isoFilepath ver
|
||||||
|
|
||||||
isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist
|
isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist
|
||||||
-> IO Bool
|
-> IO Bool
|
||||||
@@ -691,6 +696,19 @@ installHLSUnpackedLegacy path inst mver' forceInstall = do
|
|||||||
lift $ chmod_755 destWrapperPath
|
lift $ chmod_755 destWrapperPath
|
||||||
|
|
||||||
|
|
||||||
|
installHLSPostInst :: (MonadReader env m, HasDirs env, HasLog env, MonadIO m, MonadCatch m, MonadMask m, MonadFail m, MonadUnliftIO m)
|
||||||
|
=> Maybe FilePath
|
||||||
|
-> Version
|
||||||
|
-> Excepts '[NotInstalled] m ()
|
||||||
|
installHLSPostInst isoFilepath ver =
|
||||||
|
case isoFilepath of
|
||||||
|
Just _ -> pure ()
|
||||||
|
Nothing -> do
|
||||||
|
-- create symlink if this is the latest version in a regular install
|
||||||
|
hlsVers <- lift $ fmap rights getInstalledHLSs
|
||||||
|
let lInstHLS = headMay . reverse . sort $ hlsVers
|
||||||
|
when (maybe True (ver >=) lInstHLS) $ liftE $ setHLS ver SetHLSOnly Nothing
|
||||||
|
|
||||||
|
|
||||||
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
|
-- | Installs hls binaries @haskell-language-server-\<ghcver\>@
|
||||||
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
|
-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@.
|
||||||
@@ -898,6 +916,8 @@ compileHLS targetHLS ghcs jobs ov isolateDir cabalProject cabalProjectLocal patc
|
|||||||
liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True
|
liftE $ installHLSUnpackedLegacy installDir binDir (Just installVer) True
|
||||||
)
|
)
|
||||||
|
|
||||||
|
liftE $ installHLSPostInst isolateDir installVer
|
||||||
|
|
||||||
pure installVer
|
pure installVer
|
||||||
|
|
||||||
|
|
||||||
@@ -1014,6 +1034,11 @@ installStackBindist dlinfo ver isoFilepath forceInstall = do
|
|||||||
Nothing -> do -- regular install
|
Nothing -> do -- regular install
|
||||||
liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall
|
liftE $ installStackUnpacked workdir binDir (Just ver) forceInstall
|
||||||
|
|
||||||
|
-- create symlink if this is the latest version and a regular install
|
||||||
|
sVers <- lift $ fmap rights getInstalledStacks
|
||||||
|
let lInstStack = headMay . reverse . sort $ sVers
|
||||||
|
when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
|
||||||
|
|
||||||
|
|
||||||
-- | Install an unpacked stack distribution.
|
-- | Install an unpacked stack distribution.
|
||||||
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
|
installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m)
|
||||||
|
|||||||
@@ -121,28 +121,25 @@ getDownloadsF = do
|
|||||||
Settings { urlSource } <- lift getSettings
|
Settings { urlSource } <- lift getSettings
|
||||||
case urlSource of
|
case urlSource of
|
||||||
GHCupURL -> liftE $ getBase ghcupURL
|
GHCupURL -> liftE $ getBase ghcupURL
|
||||||
(OwnSource url) -> liftE $ getBase url
|
(OwnSource exts) -> do
|
||||||
|
ext <- liftE $ mapM (either pure getBase) exts
|
||||||
|
mergeGhcupInfo ext
|
||||||
(OwnSpec av) -> pure av
|
(OwnSpec av) -> pure av
|
||||||
(AddSource (Left ext)) -> do
|
(AddSource exts) -> do
|
||||||
base <- liftE $ getBase ghcupURL
|
base <- liftE $ getBase ghcupURL
|
||||||
pure (mergeGhcupInfo base ext)
|
ext <- liftE $ mapM (either pure getBase) exts
|
||||||
(AddSource (Right uri)) -> do
|
mergeGhcupInfo (base:ext)
|
||||||
base <- liftE $ getBase ghcupURL
|
|
||||||
ext <- liftE $ getBase uri
|
|
||||||
pure (mergeGhcupInfo base ext)
|
|
||||||
|
|
||||||
where
|
where
|
||||||
|
mergeGhcupInfo :: MonadFail m
|
||||||
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
|
=> [GHCupInfo]
|
||||||
-> GHCupInfo -- ^ extension overwriting the base
|
-> m GHCupInfo
|
||||||
-> GHCupInfo
|
mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
|
||||||
mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
|
mergeGhcupInfo xs@(GHCupInfo{}: _) =
|
||||||
let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
|
let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)
|
||||||
Just a' -> M.union a' a
|
newGlobalTools = M.unionsWith (\_ a2 -> a2 ) (_globalTools <$> xs)
|
||||||
Nothing -> a
|
newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
|
||||||
) base
|
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
|
||||||
newGlobalTools = M.union base2 ext2
|
|
||||||
in GHCupInfo tr newDownloads newGlobalTools
|
|
||||||
|
|
||||||
|
|
||||||
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
|
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
|
||||||
|
|||||||
@@ -286,9 +286,9 @@ instance Pretty TarDir where
|
|||||||
|
|
||||||
-- | Where to fetch GHCupDownloads from.
|
-- | Where to fetch GHCupDownloads from.
|
||||||
data URLSource = GHCupURL
|
data URLSource = GHCupURL
|
||||||
| OwnSource URI
|
| OwnSource [Either GHCupInfo URI] -- ^ complete source list
|
||||||
| OwnSpec GHCupInfo
|
| OwnSpec GHCupInfo
|
||||||
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
|
| AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
|
||||||
deriving (GHC.Generic, Show)
|
deriving (GHC.Generic, Show)
|
||||||
|
|
||||||
instance NFData URLSource
|
instance NFData URLSource
|
||||||
|
|||||||
@@ -79,6 +79,38 @@ instance FromJSON Tag where
|
|||||||
instance ToJSON URI where
|
instance ToJSON URI where
|
||||||
toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef'
|
toJSON = toJSON . E.decodeUtf8With E.lenientDecode . serializeURIRef'
|
||||||
|
|
||||||
|
instance FromJSON URLSource where
|
||||||
|
parseJSON v =
|
||||||
|
parseGHCupURL v
|
||||||
|
<|> parseOwnSourceLegacy v
|
||||||
|
<|> parseOwnSourceNew1 v
|
||||||
|
<|> parseOwnSourceNew2 v
|
||||||
|
<|> parseOwnSpec v
|
||||||
|
<|> legacyParseAddSource v
|
||||||
|
<|> newParseAddSource v
|
||||||
|
where
|
||||||
|
parseOwnSourceLegacy = withObject "URLSource" $ \o -> do
|
||||||
|
r :: URI <- o .: "OwnSource"
|
||||||
|
pure (OwnSource [Right r])
|
||||||
|
parseOwnSourceNew1 = withObject "URLSource" $ \o -> do
|
||||||
|
r :: [URI] <- o .: "OwnSource"
|
||||||
|
pure (OwnSource (fmap Right r))
|
||||||
|
parseOwnSourceNew2 = withObject "URLSource" $ \o -> do
|
||||||
|
r :: [Either GHCupInfo URI] <- o .: "OwnSource"
|
||||||
|
pure (OwnSource r)
|
||||||
|
parseOwnSpec = withObject "URLSource" $ \o -> do
|
||||||
|
r :: GHCupInfo <- o .: "OwnSpec"
|
||||||
|
pure (OwnSpec r)
|
||||||
|
parseGHCupURL = withObject "URLSource" $ \o -> do
|
||||||
|
_ :: [Value] <- o .: "GHCupURL"
|
||||||
|
pure GHCupURL
|
||||||
|
legacyParseAddSource = withObject "URLSource" $ \o -> do
|
||||||
|
r :: Either GHCupInfo URI <- o .: "AddSource"
|
||||||
|
pure (AddSource [r])
|
||||||
|
newParseAddSource = withObject "URLSource" $ \o -> do
|
||||||
|
r :: [Either GHCupInfo URI] <- o .: "AddSource"
|
||||||
|
pure (AddSource r)
|
||||||
|
|
||||||
instance FromJSON URI where
|
instance FromJSON URI where
|
||||||
parseJSON = withText "URL" $ \t ->
|
parseJSON = withText "URL" $ \t ->
|
||||||
case parseURI strictURIParserOptions (encodeUtf8 t) of
|
case parseURI strictURIParserOptions (encodeUtf8 t) of
|
||||||
@@ -314,7 +346,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir
|
|||||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
|
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
|
||||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
||||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
||||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
|
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
|
||||||
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
|
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
|
||||||
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
|
deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
|
||||||
|
|||||||
Reference in New Issue
Block a user