Merge branch 'max_path'
This commit is contained in:
commit
76acc9a5f5
GPG Key ID:
3786C5262ECB4A3F
@ -5,6 +5,11 @@
|
||||
* Vastly improve shell completions wrt [#242](https://gitlab.haskell.org/haskell/ghcup-hs/-/merge_requests/242)
|
||||
* Fix 'ghcup install cabal/hls/stack --set' wrt [#324](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/324)
|
||||
* Fix bad error message wrt [#323](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/323)
|
||||
* Use predictable /tmp names for `ghcup run`, fixes [#329](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/329)
|
||||
* Fix bug with isolated installation of not previously installed versions
|
||||
* Add `--no-set` to install commands, fixes [#330](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/330)
|
||||
* Fix serious bug in `ghcup list --raw-format -t <tool> -c installed`
|
||||
* Overhaul metadata merging and add `ghcup config add-release-channel URI` wrt [#328](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/328)
|
||||
|
||||
## 0.1.17.5 -- 2022-02-26
|
||||
|
||||
|
||||
@ -7,6 +7,7 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE DuplicateRecordFields #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ExplicitForAll #-}
|
||||
|
||||
module GHCup.OptParse.Config where
|
||||
|
||||
@ -17,6 +18,7 @@ import GHCup.Utils
|
||||
import GHCup.Utils.Prelude
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
import GHCup.OptParse.Common
|
||||
|
||||
#if !MIN_VERSION_base(4,13,0)
|
||||
import Control.Monad.Fail ( MonadFail )
|
||||
@ -27,10 +29,11 @@ import Control.Monad.Trans.Resource
|
||||
import Data.Functor
|
||||
import Data.Maybe
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Options.Applicative hiding ( style )
|
||||
import Options.Applicative hiding ( style, ParseError )
|
||||
import Options.Applicative.Help.Pretty ( text )
|
||||
import Prelude hiding ( appendFile )
|
||||
import System.Exit
|
||||
import URI.ByteString hiding ( uriParser )
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.ByteString.UTF8 as UTF8
|
||||
@ -49,6 +52,7 @@ data ConfigCommand
|
||||
= ShowConfig
|
||||
| SetConfig String (Maybe String)
|
||||
| InitConfig
|
||||
| AddReleaseChannel URI
|
||||
|
||||
|
||||
|
||||
@ -62,6 +66,7 @@ configP = subparser
|
||||
( command "init" initP
|
||||
<> command "set" setP -- [set] KEY VALUE at help lhs
|
||||
<> command "show" showP
|
||||
<> command "add-release-channel" addP
|
||||
)
|
||||
<|> argsP -- add show for a single option
|
||||
<|> pure ShowConfig
|
||||
@ -70,6 +75,8 @@ configP = subparser
|
||||
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))
|
||||
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
|
||||
|
||||
|
||||
updateSettings :: Monad m => UTF8.ByteString -> Settings -> Excepts '[JSONError] m Settings
|
||||
updateSettings config' settings = do
|
||||
settings' <- lE' (JSONDecodeError . displayException) . Y.decodeEither' $ config'
|
||||
pure $ mergeConf settings' settings
|
||||
where
|
||||
mergeConf :: UserSettings -> Settings -> Settings
|
||||
mergeConf UserSettings{..} Settings{..} =
|
||||
let cache' = fromMaybe cache uCache
|
||||
metaCache' = fromMaybe metaCache uMetaCache
|
||||
noVerify' = fromMaybe noVerify uNoVerify
|
||||
keepDirs' = fromMaybe keepDirs uKeepDirs
|
||||
downloader' = fromMaybe downloader uDownloader
|
||||
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
|
||||
updateSettings :: UserSettings -> Settings -> Settings
|
||||
updateSettings UserSettings{..} Settings{..} =
|
||||
let cache' = fromMaybe cache uCache
|
||||
metaCache' = fromMaybe metaCache uMetaCache
|
||||
noVerify' = fromMaybe noVerify uNoVerify
|
||||
keepDirs' = fromMaybe keepDirs uKeepDirs
|
||||
downloader' = fromMaybe downloader uDownloader
|
||||
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
|
||||
, MonadUnliftIO m
|
||||
, MonadFail m
|
||||
@ -161,27 +163,42 @@ config configCommand settings keybindings runLogger = case configCommand of
|
||||
liftIO $ putStrLn $ formatConfig $ fromSettings settings (Just keybindings)
|
||||
pure ExitSuccess
|
||||
|
||||
(SetConfig k (Just v)) ->
|
||||
case v of
|
||||
"" -> do
|
||||
runLogger $ logError "Empty values are not allowed"
|
||||
pure $ ExitFailure 55
|
||||
_ -> doConfig (k <> ": " <> v <> "\n")
|
||||
(SetConfig k mv) -> do
|
||||
r <- runE @'[JSONError, ParseError] $ do
|
||||
case mv of
|
||||
Just "" ->
|
||||
throwE $ ParseError "Empty values are not allowed"
|
||||
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
|
||||
doConfig val = do
|
||||
r <- runE @'[JSONError] $ do
|
||||
settings' <- updateSettings (UTF8.fromString val) settings
|
||||
path <- liftIO getConfigFilePath
|
||||
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
|
||||
lift $ runLogger $ logDebug $ T.pack $ show settings'
|
||||
pure ()
|
||||
doConfig :: MonadIO m => UserSettings -> m ()
|
||||
doConfig usersettings = do
|
||||
let settings' = updateSettings usersettings settings
|
||||
path <- liftIO getConfigFilePath
|
||||
liftIO $ writeFile path $ formatConfig $ fromSettings settings' (Just keybindings)
|
||||
runLogger $ logDebug $ T.pack $ show settings'
|
||||
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
|
||||
decodeSettings = lE' (JSONDecodeError . displayException) . Y.decodeEither' . UTF8.fromString
|
||||
|
||||
@ -143,11 +143,11 @@ printListResult no_color raw lr = do
|
||||
)
|
||||
$ lr
|
||||
let cols =
|
||||
foldr (\xs ys -> zipWith (:) xs ys) (cycle [[]]) rows
|
||||
foldr (\xs ys -> zipWith (:) xs ys) (repeat []) rows
|
||||
lengths = fmap (maximum . fmap strWidth) cols
|
||||
padded = fmap (\xs -> zipWith padTo xs lengths) rows
|
||||
|
||||
forM_ padded $ \row -> putStrLn $ unwords row
|
||||
forM_ (if raw then rows else padded) $ \row -> putStrLn $ unwords row
|
||||
where
|
||||
|
||||
padTo str' x =
|
||||
|
||||
@ -15,7 +15,7 @@ import GHCup.Utils.File
|
||||
import GHCup.OptParse.Common
|
||||
import GHCup.Errors
|
||||
import GHCup.Types
|
||||
import GHCup.Types.Optics ( getDirs )
|
||||
import GHCup.Types.Optics
|
||||
import GHCup.Utils.Logger
|
||||
import GHCup.Utils.String.QQ
|
||||
|
||||
@ -187,14 +187,16 @@ runLeanRUN leanAppstate =
|
||||
@RunEffects
|
||||
|
||||
runRUN :: MonadUnliftIO m
|
||||
=> (ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
|
||||
=> IO AppState
|
||||
-> Excepts RunEffects (ResourceT (ReaderT AppState m)) a
|
||||
-> m (VEither RunEffects a)
|
||||
runRUN runAppState =
|
||||
runAppState
|
||||
runRUN appState action' = do
|
||||
s' <- liftIO appState
|
||||
flip runReaderT s'
|
||||
. runResourceT
|
||||
. runE
|
||||
@RunEffects
|
||||
$ action'
|
||||
|
||||
|
||||
|
||||
@ -212,52 +214,77 @@ run :: forall m.
|
||||
, MonadUnliftIO m
|
||||
)
|
||||
=> RunOptions
|
||||
-> (forall a. ReaderT AppState m (VEither RunEffects a) -> m (VEither RunEffects a))
|
||||
-> IO AppState
|
||||
-> LeanAppState
|
||||
-> (ReaderT LeanAppState m () -> m ())
|
||||
-> m ExitCode
|
||||
run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
|
||||
toolchain <- Excepts resolveToolchain
|
||||
tmp <- case runBinDir of
|
||||
Just bindir -> do
|
||||
liftIO $ createDirRecursive' bindir
|
||||
liftIO $ canonicalizePath bindir
|
||||
Nothing -> do
|
||||
d <- liftIO $ predictableTmpDir toolchain
|
||||
liftIO $ createDirRecursive' d
|
||||
liftIO $ canonicalizePath d
|
||||
Excepts $ installToolChain toolchain tmp
|
||||
pure tmp
|
||||
) >>= \case
|
||||
VRight tmp -> do
|
||||
case runCOMMAND of
|
||||
[] -> do
|
||||
liftIO $ putStr tmp
|
||||
pure ExitSuccess
|
||||
(cmd:args) -> do
|
||||
newEnv <- liftIO $ addToPath tmp
|
||||
run RunOptions{..} runAppState leanAppstate runLogger = do
|
||||
r <- if or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool'
|
||||
then runRUN runAppState $ do
|
||||
toolchain <- liftE resolveToolchainFull
|
||||
tmp <- case runBinDir of
|
||||
Just bindir -> do
|
||||
liftIO $ createDirRecursive' bindir
|
||||
liftIO $ canonicalizePath bindir
|
||||
Nothing -> do
|
||||
d <- liftIO $ predictableTmpDir toolchain
|
||||
liftIO $ createDirRecursive' d
|
||||
liftIO $ canonicalizePath d
|
||||
liftE $ installToolChainFull toolchain tmp
|
||||
pure tmp
|
||||
else runLeanRUN leanAppstate $ do
|
||||
toolchain <- resolveToolchain
|
||||
tmp <- case runBinDir of
|
||||
Just bindir -> do
|
||||
liftIO $ createDirRecursive' bindir
|
||||
liftIO $ canonicalizePath bindir
|
||||
Nothing -> do
|
||||
d <- liftIO $ predictableTmpDir toolchain
|
||||
liftIO $ createDirRecursive' d
|
||||
liftIO $ canonicalizePath d
|
||||
liftE $ installToolChain toolchain tmp
|
||||
pure tmp
|
||||
case r of
|
||||
VRight tmp -> do
|
||||
case runCOMMAND of
|
||||
[] -> do
|
||||
liftIO $ putStr tmp
|
||||
pure ExitSuccess
|
||||
(cmd:args) -> do
|
||||
newEnv <- liftIO $ addToPath tmp
|
||||
#ifndef IS_WINDOWS
|
||||
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
|
||||
pure ExitSuccess
|
||||
void $ liftIO $ SPP.executeFile cmd True args (Just newEnv)
|
||||
pure ExitSuccess
|
||||
#else
|
||||
r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
|
||||
case r' of
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 28
|
||||
r' <- runLeanRUN leanAppstate $ liftE $ lEM @_ @'[ProcessError] $ exec cmd args Nothing (Just newEnv)
|
||||
case r' of
|
||||
VRight _ -> pure ExitSuccess
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 28
|
||||
#endif
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 27
|
||||
VLeft e -> do
|
||||
runLogger $ logError $ T.pack $ prettyShow e
|
||||
pure $ ExitFailure 27
|
||||
|
||||
where
|
||||
|
||||
isToolTag :: ToolVersion -> Bool
|
||||
isToolTag (ToolTag _) = True
|
||||
isToolTag _ = False
|
||||
|
||||
-- TODO: doesn't work for cross
|
||||
resolveToolchain
|
||||
| or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do
|
||||
resolveToolchainFull :: ( MonadFail m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Excepts
|
||||
'[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
] (ResourceT (ReaderT AppState m)) Toolchain
|
||||
resolveToolchainFull = do
|
||||
ghcVer <- forM runGHCVer $ \ver -> do
|
||||
(v, _) <- liftE $ fromVersion (Just ver) GHC
|
||||
pure v
|
||||
@ -271,7 +298,8 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
|
||||
(v, _) <- liftE $ fromVersion (Just ver) Stack
|
||||
pure v
|
||||
pure Toolchain{..}
|
||||
| otherwise = runLeanRUN leanAppstate $ do
|
||||
|
||||
resolveToolchain = do
|
||||
ghcVer <- case runGHCVer of
|
||||
Just (ToolVersion v) -> pure $ Just v
|
||||
Nothing -> pure Nothing
|
||||
@ -290,8 +318,33 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
|
||||
_ -> fail "Internal error"
|
||||
pure Toolchain{..}
|
||||
|
||||
installToolChain Toolchain{..} tmp
|
||||
| or (fmap (maybe False isToolTag) [runGHCVer, runCabalVer, runHLSVer, runStackVer]) || runInstTool' = runRUN runAppState $ do
|
||||
installToolChainFull :: ( MonadFail m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Toolchain
|
||||
-> FilePath
|
||||
-> Excepts
|
||||
'[ TagNotFound
|
||||
, NextVerNotFound
|
||||
, NoToolVersionSet
|
||||
, UnknownArchive
|
||||
, TarDirDoesNotExist
|
||||
, ProcessError
|
||||
, NotInstalled
|
||||
, NoDownload
|
||||
, GPGError
|
||||
, DownloadFailed
|
||||
, DirNotEmpty
|
||||
, DigestError
|
||||
, BuildFailed
|
||||
, ArchiveResult
|
||||
, AlreadyInstalled
|
||||
, FileAlreadyExistsError
|
||||
, CopyError
|
||||
] (ResourceT (ReaderT AppState m)) ()
|
||||
installToolChainFull Toolchain{..} tmp = do
|
||||
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
|
||||
isInstalled <- maybe (pure False) (\(tool, v) -> lift $ checkIfToolInstalled' tool v) mt
|
||||
case mt of
|
||||
@ -320,7 +373,16 @@ run RunOptions{..} runAppState leanAppstate runLogger = runE @RunEffects ( do
|
||||
False
|
||||
setTool HLS v tmp
|
||||
_ -> pure ()
|
||||
| otherwise = runLeanRUN leanAppstate $ do
|
||||
|
||||
installToolChain :: ( MonadFail m
|
||||
, MonadThrow m
|
||||
, MonadIO m
|
||||
, MonadCatch m
|
||||
)
|
||||
=> Toolchain
|
||||
-> FilePath
|
||||
-> Excepts '[NotInstalled] (ReaderT LeanAppState m) ()
|
||||
installToolChain Toolchain{..} tmp = do
|
||||
forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do
|
||||
case mt of
|
||||
Just (GHC, v) -> setTool GHC v tmp
|
||||
|
||||
@ -82,7 +82,7 @@ toSettings options = do
|
||||
keepDirs = fromMaybe (fromMaybe (Types.keepDirs defaultSettings) uKeepDirs) optKeepDirs
|
||||
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader
|
||||
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
|
||||
gpgSetting = fromMaybe (fromMaybe (Types.gpgSetting defaultSettings) uGPGSetting) optGpg
|
||||
in (Settings {..}, keyBindings)
|
||||
@ -235,7 +235,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Interactive -> pure ()
|
||||
#endif
|
||||
-- check for new tools
|
||||
_ -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
||||
_
|
||||
| Just False <- optVerbose -> pure ()
|
||||
| otherwise -> lookupEnv "GHCUP_SKIP_UPDATE_CHECK" >>= \case
|
||||
Nothing -> void . flip runReaderT s' . runE @'[TagNotFound, NextVerNotFound, NoToolVersionSet] $ do
|
||||
newTools <- lift checkForUpdates
|
||||
forM_ newTools $ \newTool@(t, l) -> do
|
||||
@ -313,7 +315,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
|
||||
Nuke -> nuke appState runLogger
|
||||
Prefetch pfCom -> prefetch pfCom runAppState runLogger
|
||||
GC gcOpts -> gc gcOpts runAppState runLogger
|
||||
Run runCommand -> run runCommand runAppState leanAppstate runLogger
|
||||
Run runCommand -> run runCommand appState leanAppstate runLogger
|
||||
|
||||
case res of
|
||||
ExitSuccess -> pure ()
|
||||
|
||||
@ -48,12 +48,16 @@ url-source:
|
||||
|
||||
## Example 1: Read download info from this location instead
|
||||
## 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"
|
||||
|
||||
## 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:
|
||||
# Left:
|
||||
# toolRequirements: {} # this is ignored
|
||||
# globalTools: {}
|
||||
# toolRequirements: {}
|
||||
# ghcupDownloads:
|
||||
# GHC:
|
||||
# 9.10.2:
|
||||
@ -66,6 +70,8 @@ url-source:
|
||||
# dlSubdir: ghc-7.10.3
|
||||
# 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:
|
||||
# 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"
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
cabal-version: 3.0
|
||||
name: ghcup
|
||||
version: 0.1.17.5
|
||||
version: 0.1.17.6
|
||||
license: LGPL-3.0-only
|
||||
license-file: LICENSE
|
||||
copyright: Julian Ospald 2020
|
||||
|
||||
@ -121,28 +121,25 @@ getDownloadsF = do
|
||||
Settings { urlSource } <- lift getSettings
|
||||
case urlSource of
|
||||
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
|
||||
(AddSource (Left ext)) -> do
|
||||
(AddSource exts) -> do
|
||||
base <- liftE $ getBase ghcupURL
|
||||
pure (mergeGhcupInfo base ext)
|
||||
(AddSource (Right uri)) -> do
|
||||
base <- liftE $ getBase ghcupURL
|
||||
ext <- liftE $ getBase uri
|
||||
pure (mergeGhcupInfo base ext)
|
||||
ext <- liftE $ mapM (either pure getBase) exts
|
||||
mergeGhcupInfo (base:ext)
|
||||
|
||||
where
|
||||
|
||||
mergeGhcupInfo :: GHCupInfo -- ^ base to merge with
|
||||
-> GHCupInfo -- ^ extension overwriting the base
|
||||
-> GHCupInfo
|
||||
mergeGhcupInfo (GHCupInfo tr base base2) (GHCupInfo _ ext ext2) =
|
||||
let newDownloads = M.mapWithKey (\k a -> case M.lookup k ext of
|
||||
Just a' -> M.union a' a
|
||||
Nothing -> a
|
||||
) base
|
||||
newGlobalTools = M.union base2 ext2
|
||||
in GHCupInfo tr newDownloads newGlobalTools
|
||||
where
|
||||
mergeGhcupInfo :: MonadFail m
|
||||
=> [GHCupInfo]
|
||||
-> m GHCupInfo
|
||||
mergeGhcupInfo [] = fail "mergeGhcupInfo: internal error: need at least one GHCupInfo"
|
||||
mergeGhcupInfo xs@(GHCupInfo{}: _) =
|
||||
let newDownloads = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_ghcupDownloads <$> xs)
|
||||
newGlobalTools = M.unionsWith (\_ a2 -> a2 ) (_globalTools <$> xs)
|
||||
newToolReqs = M.unionsWith (M.unionWith (\_ b2 -> b2)) (_toolRequirements <$> xs)
|
||||
in pure $ GHCupInfo newToolReqs newDownloads newGlobalTools
|
||||
|
||||
|
||||
yamlFromCache :: (MonadReader env m, HasDirs env) => URI -> m FilePath
|
||||
|
||||
@ -286,9 +286,9 @@ instance Pretty TarDir where
|
||||
|
||||
-- | Where to fetch GHCupDownloads from.
|
||||
data URLSource = GHCupURL
|
||||
| OwnSource URI
|
||||
| OwnSource [Either GHCupInfo URI] -- ^ complete source list
|
||||
| OwnSpec GHCupInfo
|
||||
| AddSource (Either GHCupInfo URI) -- ^ merge with GHCupURL
|
||||
| AddSource [Either GHCupInfo URI] -- ^ merge with GHCupURL
|
||||
deriving (GHC.Generic, Show)
|
||||
|
||||
instance NFData URLSource
|
||||
|
||||
@ -79,6 +79,38 @@ instance FromJSON Tag where
|
||||
instance ToJSON URI where
|
||||
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
|
||||
parseJSON = withText "URL" $ \t ->
|
||||
case parseURI strictURIParserOptions (encodeUtf8 t) of
|
||||
@ -314,7 +346,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requir
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
|
||||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo
|
||||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
||||
deriveToJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
|
||||
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 "u-") . T.pack . kebab $ str' } ''UserSettings
|
||||
|
||||
@ -339,13 +339,15 @@ useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
|
||||
relativeSymlink :: FilePath -- ^ the path in which to create the symlink
|
||||
-> FilePath -- ^ the symlink destination
|
||||
-> FilePath
|
||||
relativeSymlink p1 p2 =
|
||||
let d1 = splitDirectories p1
|
||||
d2 = splitDirectories p2
|
||||
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
|
||||
cPrefix = drop (length common) d1
|
||||
in joinPath (replicate (length cPrefix) "..")
|
||||
<> joinPath ([pathSeparator] : drop (length common) d2)
|
||||
relativeSymlink p1 p2
|
||||
| isWindows = p2 -- windows quickly gets into MAX_PATH issues so we don't care about relative symlinks
|
||||
| otherwise =
|
||||
let d1 = splitDirectories p1
|
||||
d2 = splitDirectories p2
|
||||
common = takeWhile (\(x, y) -> x == y) $ zip d1 d2
|
||||
cPrefix = drop (length common) d1
|
||||
in joinPath (replicate (length cPrefix) "..")
|
||||
<> joinPath ([pathSeparator] : drop (length common) d2)
|
||||
|
||||
|
||||
cleanupTrash :: ( MonadIO m
|
||||
|
||||
Loading…
Reference in New Issue
Block a user