Compare commits

..

1 Commits

11 changed files with 177 additions and 91 deletions

View File

@@ -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"

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -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

View File

@@ -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)

View File

@@ -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"

View File

@@ -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)

View File

@@ -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

View File

@@ -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

View File

@@ -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