@@ -7,6 +7,7 @@ | |||
- reverse list order so latest is on top | |||
- expand the blues selected bar | |||
- show new latest versions in bright white | |||
* allow configuration file and settings TUI hotkeys wrt #41 | |||
## 0.1.11 -- 2020-09-23 | |||
@@ -13,6 +13,7 @@ Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [p | |||
* [Manual install](#manual-install) | |||
* [Vim integration](#vim-integration) | |||
* [Usage](#usage) | |||
* [Configuration](#configuration) | |||
* [Manpages](#manpages) | |||
* [Shell-completion](#shell-completion) | |||
* [Cross support](#cross-support) | |||
@@ -80,6 +81,47 @@ ghcup upgrade | |||
Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which | |||
handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler) of `ghc` is available, which `ghcup` can do. | |||
### Configuration | |||
A configuration file can be put in `~/.ghcup/config.yaml`. Here is the complete default | |||
configuration: | |||
```yaml | |||
# Cache downloads in ~/.ghcup/cache | |||
cache: False | |||
# Skip tarball checksum verification | |||
no-verify: False | |||
# enable verbosity | |||
verbose: False | |||
# When to keep build directories | |||
keep-dirs: Errors # Always | Never | Errors | |||
# Which downloader to use | |||
downloader: Curl # Curl | Wget | Internal | |||
# TUI key bindings, | |||
# see https://hackage.haskell.org/package/vty-5.31/docs/Graphics-Vty-Input-Events.html#t:Key | |||
# for possible values. | |||
key-bindings: | |||
up: | |||
KUp: [] | |||
down: | |||
KDown: [] | |||
quit: | |||
KChar: 'q' | |||
install: | |||
KChar: 'i' | |||
uninstall: | |||
KChar: 'u' | |||
set: | |||
KChar: 's' | |||
changelog: | |||
KChar: 'c' | |||
show-all: | |||
KChar: 'a' | |||
``` | |||
Partial configuration is fine. Command line options always overwrite the config file settings. | |||
### Manpages | |||
For man pages to work you need [man-db](http://man-db.nongnu.org/) as your `man` provider, then issue `man ghc`. Manpages only work for the currently set ghc. | |||
@@ -193,7 +193,7 @@ validateTarballs dls = do | |||
where | |||
downloadAll dli = do | |||
dirs <- liftIO getDirs | |||
let settings = AppState (Settings True False Never Curl False) dirs | |||
let settings = AppState (Settings True False Never Curl False) dirs defaultKeyBindings | |||
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True | |||
, colorOutter = B.hPut stderr | |||
, rawOutter = (\_ -> pure ()) | |||
@@ -36,7 +36,6 @@ import Data.Bool | |||
import Data.Functor | |||
import Data.List | |||
import Data.Maybe | |||
import Data.Char | |||
import Data.IORef | |||
import Data.String.Interpolate | |||
import Data.Vector ( Vector | |||
@@ -77,33 +76,44 @@ data BrickState = BrickState | |||
{ appData :: BrickData | |||
, appSettings :: BrickSettings | |||
, appState :: BrickInternalState | |||
, appKeys :: KeyBindings | |||
} | |||
deriving Show | |||
keyHandlers :: [ ( Char | |||
keyHandlers :: KeyBindings | |||
-> [ ( Vty.Key | |||
, BrickSettings -> String | |||
, BrickState -> EventM n (Next BrickState) | |||
) | |||
] | |||
keyHandlers = | |||
[ ('q', const "Quit" , halt) | |||
, ('i', const "Install" , withIOAction install') | |||
, ('u', const "Uninstall", withIOAction del') | |||
, ('s', const "Set" , withIOAction set') | |||
, ('c', const "ChangeLog", withIOAction changelog') | |||
, ( 'a' | |||
keyHandlers KeyBindings {..} = | |||
[ (bQuit, const "Quit" , halt) | |||
, (bInstall, const "Install" , withIOAction install') | |||
, (bUninstall, const "Uninstall", withIOAction del') | |||
, (bSet, const "Set" , withIOAction set') | |||
, (bChangelog, const "ChangeLog", withIOAction changelog') | |||
, ( bShowAll | |||
, (\BrickSettings {..} -> | |||
if showAll then "Hide old versions" else "Show all versions" | |||
) | |||
, hideShowHandler | |||
) | |||
, (bUp, const "Up", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Up), .. })) | |||
, (bDown, const "Down", \BrickState {..} -> continue (BrickState { appState = (moveCursor 1 appState Down), .. })) | |||
] | |||
where | |||
hideShowHandler (BrickState {..}) = | |||
let newAppSettings = appSettings { showAll = not . showAll $ appSettings } | |||
newInternalState = constructList appData newAppSettings (Just appState) | |||
in continue (BrickState appData newAppSettings newInternalState) | |||
in continue (BrickState appData newAppSettings newInternalState appKeys) | |||
showKey :: Vty.Key -> String | |||
showKey (Vty.KChar c) = [c] | |||
showKey (Vty.KUp) = "↑" | |||
showKey (Vty.KDown) = "↓" | |||
showKey key = tail (show key) | |||
ui :: BrickState -> Widget String | |||
@@ -122,8 +132,7 @@ ui BrickState { appSettings = as@(BrickSettings {}), ..} | |||
. txtWrap | |||
. T.pack | |||
. foldr1 (\x y -> x <> " " <> y) | |||
. (++ ["↑↓:Navigation"]) | |||
$ (fmap (\(c, s, _) -> (c : ':' : s as)) keyHandlers) | |||
$ (fmap (\(key, s, _) -> (showKey key <> ":" <> s as)) $ keyHandlers appKeys) | |||
header = | |||
(minHSize 2 $ emptyWidget) | |||
<+> (padLeft (Pad 2) $ minHSize 6 $ str "Tool") | |||
@@ -261,24 +270,30 @@ dimAttributes = attrMap | |||
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) | |||
] | |||
eventHandler :: BrickState -> BrickEvent n e -> EventM n (Next BrickState) | |||
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st | |||
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st | |||
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st | |||
eventHandler BrickState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) = | |||
continue (BrickState { appState = (moveCursor appState Up), .. }) | |||
eventHandler BrickState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) = | |||
continue (BrickState { appState = (moveCursor appState Down), .. }) | |||
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) = | |||
case find (\(c', _, _) -> c' == c) keyHandlers of | |||
Nothing -> continue as | |||
Just (_, _, handler) -> handler as | |||
eventHandler st _ = continue st | |||
moveCursor :: BrickInternalState -> Direction -> BrickInternalState | |||
moveCursor ais@(BrickInternalState {..}) direction = | |||
let newIx = if direction == Down then ix + 1 else ix - 1 | |||
eventHandler st@(BrickState {..}) ev = do | |||
AppState { keyBindings = kb } <- liftIO $ readIORef settings' | |||
case ev of | |||
(MouseDown _ Vty.BScrollUp _ _) -> | |||
continue (BrickState { appState = moveCursor 1 appState Up, .. }) | |||
(MouseDown _ Vty.BScrollDown _ _) -> | |||
continue (BrickState { appState = moveCursor 1 appState Down, .. }) | |||
(VtyEvent (Vty.EvResize _ _)) -> continue st | |||
(VtyEvent (Vty.EvKey Vty.KUp _)) -> | |||
continue (BrickState { appState = (moveCursor 1 appState Up), .. }) | |||
(VtyEvent (Vty.EvKey Vty.KDown _)) -> | |||
continue (BrickState { appState = (moveCursor 1 appState Down), .. }) | |||
(VtyEvent (Vty.EvKey key _)) -> | |||
case find (\(key', _, _) -> key' == key) (keyHandlers kb) of | |||
Nothing -> continue st | |||
Just (_, _, handler) -> handler st | |||
_ -> continue st | |||
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState | |||
moveCursor steps ais@(BrickInternalState {..}) direction = | |||
let newIx = if direction == Down then ix + steps else ix - steps | |||
in case clr !? newIx of | |||
Just _ -> BrickInternalState { ix = newIx, .. } | |||
Nothing -> ais | |||
@@ -310,9 +325,10 @@ updateList :: BrickData -> BrickState -> BrickState | |||
updateList appD (BrickState {..}) = | |||
let newInternalState = constructList appD appSettings (Just appState) | |||
in BrickState { appState = newInternalState | |||
, appData = appD | |||
, appSettings = appSettings | |||
} | |||
, appData = appD | |||
, appSettings = appSettings | |||
, appKeys = appKeys | |||
} | |||
constructList :: BrickData | |||
@@ -481,6 +497,7 @@ settings' = unsafePerformIO $ do | |||
, .. | |||
}) | |||
dirs | |||
defaultKeyBindings | |||
@@ -515,6 +532,8 @@ brickMain s muri l av pfreq' = do | |||
(BrickState ad | |||
defaultAppSettings | |||
(constructList ad defaultAppSettings Nothing) | |||
(keyBindings s) | |||
) | |||
$> () | |||
Left e -> do | |||
@@ -81,12 +81,12 @@ import qualified Text.Megaparsec.Char as MPC | |||
data Options = Options | |||
{ | |||
-- global options | |||
optVerbose :: Bool | |||
, optCache :: Bool | |||
optVerbose :: Maybe Bool | |||
, optCache :: Maybe Bool | |||
, optUrlSource :: Maybe URI | |||
, optNoVerify :: Bool | |||
, optKeepDirs :: KeepDirs | |||
, optsDownloader :: Downloader | |||
, optNoVerify :: Maybe Bool | |||
, optKeepDirs :: Maybe KeepDirs | |||
, optsDownloader :: Maybe Downloader | |||
-- commands | |||
, optCommand :: Command | |||
} | |||
@@ -180,13 +180,48 @@ data ChangeLogOptions = ChangeLogOptions | |||
} | |||
-- https://github.com/pcapriotti/optparse-applicative/issues/148 | |||
-- | A switch that can be enabled using --foo and disabled using --no-foo. | |||
-- | |||
-- The option modifier is applied to only the option that is *not* enabled | |||
-- by default. For example: | |||
-- | |||
-- > invertableSwitch "recursive" True (help "do not recurse into directories") | |||
-- | |||
-- This example makes --recursive enabled by default, so | |||
-- the help is shown only for --no-recursive. | |||
invertableSwitch | |||
:: String -- ^ long option | |||
-> Char -- ^ short option for the non-default option | |||
-> Bool -- ^ is switch enabled by default? | |||
-> Mod FlagFields Bool -- ^ option modifier | |||
-> Parser (Maybe Bool) | |||
invertableSwitch longopt shortopt defv optmod = invertableSwitch' longopt shortopt defv | |||
(if defv then mempty else optmod) | |||
(if defv then optmod else mempty) | |||
-- | Allows providing option modifiers for both --foo and --no-foo. | |||
invertableSwitch' | |||
:: String -- ^ long option (eg "foo") | |||
-> Char -- ^ short option for the non-default option | |||
-> Bool -- ^ is switch enabled by default? | |||
-> Mod FlagFields Bool -- ^ option modifier for --foo | |||
-> Mod FlagFields Bool -- ^ option modifier for --no-foo | |||
-> Parser (Maybe Bool) | |||
invertableSwitch' longopt shortopt defv enmod dismod = optional | |||
( flag' True (enmod <> long longopt <> if defv then mempty else short shortopt) | |||
<|> flag' False (dismod <> long nolongopt <> if defv then short shortopt else mempty) | |||
) | |||
where | |||
nolongopt = "no-" ++ longopt | |||
opts :: Parser Options | |||
opts = | |||
Options | |||
<$> switch (short 'v' <> long "verbose" <> help "Enable verbosity") | |||
<*> switch | |||
(short 'c' <> long "cache" <> help "Cache downloads in ~/.ghcup/cache" | |||
) | |||
<$> invertableSwitch "verbose" 'v' False (help "Enable verbosity (default: disabled)") | |||
<*> invertableSwitch "cache" 'c' False (help "Cache downloads in ~/.ghcup/cache (default: disabled)") | |||
<*> (optional | |||
(option | |||
(eitherReader parseUri) | |||
@@ -198,35 +233,29 @@ opts = | |||
) | |||
) | |||
) | |||
<*> switch | |||
(short 'n' <> long "no-verify" <> help | |||
"Skip tarball checksum verification" | |||
) | |||
<*> option | |||
<*> (fmap . fmap) not (invertableSwitch "verify" 'n' True (help "Disable tarball checksum verification (default: enabled)")) | |||
<*> optional (option | |||
(eitherReader keepOnParser) | |||
( long "keep" | |||
<> metavar "<always|errors|never>" | |||
<> help | |||
"Keep build directories? (default: errors)" | |||
<> value Errors | |||
<> hidden | |||
) | |||
<*> option | |||
)) | |||
<*> optional (option | |||
(eitherReader downloaderParser) | |||
( long "downloader" | |||
#if defined(INTERNAL_DOWNLOADER) | |||
<> metavar "<internal|curl|wget>" | |||
<> help | |||
"Downloader to use (default: internal)" | |||
<> value Internal | |||
#else | |||
<> metavar "<curl|wget>" | |||
<> help | |||
"Downloader to use (default: curl)" | |||
<> value Curl | |||
#endif | |||
<> hidden | |||
) | |||
)) | |||
<*> com | |||
where | |||
parseUri s' = | |||
@@ -857,14 +886,44 @@ bindistParser = first show . parseURI strictURIParserOptions . UTF8.fromString | |||
toSettings :: Options -> IO AppState | |||
toSettings Options {..} = do | |||
let cache = optCache | |||
noVerify = optNoVerify | |||
keepDirs = optKeepDirs | |||
downloader = optsDownloader | |||
verbose = optVerbose | |||
toSettings options = do | |||
dirs <- getDirs | |||
pure $ AppState (Settings { .. }) dirs | |||
userConf <- runE @'[ JSONError ] ghcupConfigFile >>= \case | |||
VRight r -> pure r | |||
VLeft (V (JSONDecodeError e)) -> do | |||
B.hPut stderr ("Error decoding config file: " <> (E.encodeUtf8 . T.pack . show $ e)) | |||
pure defaultUserSettings | |||
_ -> do | |||
die "Unexpected error!" | |||
pure $ mergeConf options dirs userConf | |||
where | |||
mergeConf :: Options -> Dirs -> UserSettings -> AppState | |||
mergeConf (Options {..}) dirs (UserSettings {..}) = | |||
let cache = fromMaybe (fromMaybe False uCache) optCache | |||
noVerify = fromMaybe (fromMaybe False uNoVerify) optNoVerify | |||
verbose = fromMaybe (fromMaybe False uVerbose) optVerbose | |||
keepDirs = fromMaybe (fromMaybe Errors uKeepDirs) optKeepDirs | |||
downloader = fromMaybe (fromMaybe defaultDownloader uDownloader) optsDownloader | |||
keyBindings = maybe defaultKeyBindings mergeKeys uKeyBindings | |||
in AppState (Settings {..}) dirs keyBindings | |||
#if defined(INTERNAL_DOWNLOADER) | |||
defaultDownloader = Internal | |||
#else | |||
defaultDownloader = Curl | |||
#endif | |||
mergeKeys :: UserKeyBindings -> KeyBindings | |||
mergeKeys UserKeyBindings {..} = | |||
let KeyBindings {..} = defaultKeyBindings | |||
in KeyBindings { | |||
bUp = fromMaybe bUp kUp | |||
, bDown = fromMaybe bDown kDown | |||
, bQuit = fromMaybe bQuit kQuit | |||
, bInstall = fromMaybe bInstall kInstall | |||
, bUninstall = fromMaybe bUninstall kUninstall | |||
, bSet = fromMaybe bSet kSet | |||
, bChangelog = fromMaybe bChangelog kChangelog | |||
, bShowAll = fromMaybe bShowAll kShowAll | |||
} | |||
upgradeOptsP :: Parser UpgradeOpts | |||
@@ -948,7 +1007,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|] | |||
-- logger interpreter | |||
logfile <- flip runReaderT appstate $ initGHCupFileLogging [rel|ghcup.log|] | |||
let loggerConfig = LoggerConfig | |||
{ lcPrintDebug = optVerbose | |||
{ lcPrintDebug = verbose settings | |||
, colorOutter = B.hPut stderr | |||
, rawOutter = appendFile logfile | |||
} | |||
@@ -72,6 +72,9 @@ common bz2 | |||
common case-insensitive | |||
build-depends: case-insensitive >=1.2.1.0 | |||
common casing | |||
build-depends: casing >=0.1.4.1 | |||
common concurrent-output | |||
build-depends: concurrent-output >=1.10.11 | |||
@@ -266,6 +269,7 @@ library | |||
, bytestring | |||
, bz2 | |||
, case-insensitive | |||
, casing | |||
, concurrent-output | |||
, containers | |||
, cryptohash-sha256 | |||
@@ -307,6 +311,7 @@ library | |||
, utf8-string | |||
, vector | |||
, versions | |||
, vty | |||
, word8 | |||
, yaml | |||
, zlib | |||
@@ -21,6 +21,7 @@ import URI.ByteString | |||
import qualified Data.Text as T | |||
import qualified GHC.Generics as GHC | |||
import qualified Graphics.Vty as Vty | |||
@@ -193,9 +194,59 @@ data URLSource = GHCupURL | |||
deriving (GHC.Generic, Show) | |||
data UserSettings = UserSettings | |||
{ uCache :: Maybe Bool | |||
, uNoVerify :: Maybe Bool | |||
, uVerbose :: Maybe Bool | |||
, uKeepDirs :: Maybe KeepDirs | |||
, uDownloader :: Maybe Downloader | |||
, uKeyBindings :: Maybe UserKeyBindings | |||
} | |||
deriving (Show, GHC.Generic) | |||
defaultUserSettings :: UserSettings | |||
defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing | |||
data UserKeyBindings = UserKeyBindings | |||
{ kUp :: Maybe Vty.Key | |||
, kDown :: Maybe Vty.Key | |||
, kQuit :: Maybe Vty.Key | |||
, kInstall :: Maybe Vty.Key | |||
, kUninstall :: Maybe Vty.Key | |||
, kSet :: Maybe Vty.Key | |||
, kChangelog :: Maybe Vty.Key | |||
, kShowAll :: Maybe Vty.Key | |||
} | |||
deriving (Show, GHC.Generic) | |||
data KeyBindings = KeyBindings | |||
{ bUp :: Vty.Key | |||
, bDown :: Vty.Key | |||
, bQuit :: Vty.Key | |||
, bInstall :: Vty.Key | |||
, bUninstall :: Vty.Key | |||
, bSet :: Vty.Key | |||
, bChangelog :: Vty.Key | |||
, bShowAll :: Vty.Key | |||
} | |||
deriving (Show, GHC.Generic) | |||
defaultKeyBindings :: KeyBindings | |||
defaultKeyBindings = KeyBindings | |||
{ bUp = Vty.KUp | |||
, bDown = Vty.KDown | |||
, bQuit = Vty.KChar 'q' | |||
, bInstall = Vty.KChar 'i' | |||
, bUninstall = Vty.KChar 'u' | |||
, bSet = Vty.KChar 's' | |||
, bChangelog = Vty.KChar 'c' | |||
, bShowAll = Vty.KChar 'a' | |||
} | |||
data AppState = AppState | |||
{ settings :: Settings | |||
, dirs :: Dirs | |||
, keyBindings :: KeyBindings | |||
} deriving (Show) | |||
data Settings = Settings | |||
@@ -205,13 +256,14 @@ data Settings = Settings | |||
, downloader :: Downloader | |||
, verbose :: Bool | |||
} | |||
deriving Show | |||
deriving (Show, GHC.Generic) | |||
data Dirs = Dirs | |||
{ baseDir :: Path Abs | |||
, binDir :: Path Abs | |||
, cacheDir :: Path Abs | |||
, logsDir :: Path Abs | |||
, confDir :: Path Abs | |||
} | |||
deriving Show | |||
@@ -33,9 +33,11 @@ import Data.Versions | |||
import Data.Word8 | |||
import HPath | |||
import URI.ByteString | |||
import Text.Casing | |||
import qualified Data.ByteString as BS | |||
import qualified Data.Text as T | |||
import qualified Graphics.Vty as Vty | |||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture | |||
@@ -51,6 +53,11 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Versio | |||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo | |||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupInfo | |||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Requirements | |||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''KeepDirs | |||
deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downloader | |||
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 "k-") . T.pack . kebab $ str' } ''UserKeyBindings | |||
deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Vty.Key | |||
instance ToJSON Tag where | |||
toJSON Latest = String "Latest" | |||
@@ -1,3 +1,4 @@ | |||
{-# LANGUAGE DataKinds #-} | |||
{-# LANGUAGE OverloadedStrings #-} | |||
{-# LANGUAGE FlexibleContexts #-} | |||
{-# LANGUAGE QuasiQuotes #-} | |||
@@ -14,16 +15,18 @@ Portability : POSIX | |||
-} | |||
module GHCup.Utils.Dirs | |||
( getDirs | |||
, ghcupConfigFile | |||
, ghcupGHCBaseDir | |||
, ghcupGHCDir | |||
, parseGHCupGHCDir | |||
, mkGhcupTmpDir | |||
, withGHCupTmpDir | |||
, parseGHCupGHCDir | |||
, relativeSymlink | |||
, withGHCupTmpDir | |||
) | |||
where | |||
import GHCup.Errors | |||
import GHCup.Types | |||
import GHCup.Types.JSON ( ) | |||
import GHCup.Utils.MegaParsec | |||
@@ -34,8 +37,11 @@ import Control.Exception.Safe | |||
import Control.Monad | |||
import Control.Monad.Reader | |||
import Control.Monad.Trans.Resource | |||
import Data.Bifunctor | |||
import Data.ByteString ( ByteString ) | |||
import Data.Maybe | |||
import GHC.IO.Exception ( IOErrorType(NoSuchThing) ) | |||
import Haskus.Utils.Variant.Excepts | |||
import HPath | |||
import HPath.IO | |||
import Optics | |||
@@ -49,8 +55,10 @@ import System.Posix.Env.ByteString ( getEnv | |||
import System.Posix.FilePath hiding ( (</>) ) | |||
import System.Posix.Temp.ByteString ( mkdtemp ) | |||
import qualified Data.ByteString.Lazy as L | |||
import qualified Data.ByteString.UTF8 as UTF8 | |||
import qualified Data.Text.Encoding as E | |||
import qualified Data.Yaml as Y | |||
import qualified System.Posix.FilePath as FP | |||
import qualified System.Posix.User as PU | |||
import qualified Text.Megaparsec as MP | |||
@@ -84,6 +92,28 @@ ghcupBaseDir = do | |||
pure (bdir </> [rel|.ghcup|]) | |||
-- | ~/.ghcup by default | |||
-- | |||
-- If 'GHCUP_USE_XDG_DIRS' is set (to anything), | |||
-- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec. | |||
ghcupConfigDir :: IO (Path Abs) | |||
ghcupConfigDir = do | |||
xdg <- useXDG | |||
if xdg | |||
then do | |||
bdir <- getEnv "XDG_CONFIG_HOME" >>= \case | |||
Just r -> parseAbs r | |||
Nothing -> do | |||
home <- liftIO getHomeDirectory | |||
pure (home </> [rel|.config|]) | |||
pure (bdir </> [rel|ghcup|]) | |||
else do | |||
bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case | |||
Just r -> parseAbs r | |||
Nothing -> liftIO getHomeDirectory | |||
pure (bdir </> [rel|.ghcup|]) | |||
-- | If 'GHCUP_USE_XDG_DIRS' is set (to anything), | |||
-- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin' | |||
-- (which, sadly is not strictly xdg spec). | |||
@@ -142,10 +172,27 @@ getDirs = do | |||
binDir <- ghcupBinDir | |||
cacheDir <- ghcupCacheDir | |||
logsDir <- ghcupLogsDir | |||
confDir <- ghcupConfigDir | |||
pure Dirs { .. } | |||
------------------- | |||
--[ GHCup files ]-- | |||
------------------- | |||
ghcupConfigFile :: (MonadIO m) | |||
=> Excepts '[JSONError] m UserSettings | |||
ghcupConfigFile = do | |||
confDir <- liftIO $ ghcupConfigDir | |||
let file = confDir </> [rel|config.yaml|] | |||
bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ fmap Just $ readFile file | |||
case bs of | |||
Nothing -> pure defaultUserSettings | |||
Just bs' -> lE' JSONDecodeError . bimap show id . Y.decodeEither' . L.toStrict $ bs' | |||
------------------------- | |||
--[ GHCup directories ]-- | |||
------------------------- | |||