From 4fef93b7b1846bb76d809a311c64dc2c2b7dfaf0 Mon Sep 17 00:00:00 2001
From: Julian Ospald <hasufell@posteo.de>
Date: Sat, 24 Oct 2020 22:03:00 +0200
Subject: [PATCH] Allow to configure ghcup with a yaml config file
Fixes #41
---
CHANGELOG.md | 1 +
README.md | 42 ++++++++++++++
app/ghcup-gen/Validate.hs | 2 +-
app/ghcup/BrickMain.hs | 83 ++++++++++++++++-----------
app/ghcup/Main.hs | 115 ++++++++++++++++++++++++++++----------
ghcup.cabal | 5 ++
lib/GHCup/Types.hs | 54 +++++++++++++++++-
lib/GHCup/Types/JSON.hs | 7 +++
lib/GHCup/Utils/Dirs.hs | 51 ++++++++++++++++-
9 files changed, 296 insertions(+), 64 deletions(-)
diff --git a/CHANGELOG.md b/CHANGELOG.md
index 38ae547d..95ab981b 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -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
diff --git a/README.md b/README.md
index 06dd5980..8741d1ca 100644
--- a/README.md
+++ b/README.md
@@ -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.
diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs
index 3bed66b3..e18893d4 100644
--- a/app/ghcup-gen/Validate.hs
+++ b/app/ghcup-gen/Validate.hs
@@ -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 ())
diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs
index 091c2fd2..8615af6e 100644
--- a/app/ghcup/BrickMain.hs
+++ b/app/ghcup/BrickMain.hs
@@ -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
diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs
index 6efab75b..efeecf3a 100644
--- a/app/ghcup/Main.hs
+++ b/app/ghcup/Main.hs
@@ -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
}
diff --git a/ghcup.cabal b/ghcup.cabal
index da7bd7bb..a2a2f771 100644
--- a/ghcup.cabal
+++ b/ghcup.cabal
@@ -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
diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs
index 2da0a7c1..e2cc5267 100644
--- a/lib/GHCup/Types.hs
+++ b/lib/GHCup/Types.hs
@@ -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
diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs
index dbe1f950..4333596f 100644
--- a/lib/GHCup/Types/JSON.hs
+++ b/lib/GHCup/Types/JSON.hs
@@ -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"
diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs
index 8558a75c..0c2df15e 100644
--- a/lib/GHCup/Utils/Dirs.hs
+++ b/lib/GHCup/Utils/Dirs.hs
@@ -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 ]--
-------------------------
--
GitLab