Allow to configure ghcup with a yaml config file

Fixes #41
2020-10-24 22:03:00 +02:00 · 2020-10-24 22:03:00 +02:00 · 4fef93b7b1
--- 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

--- 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.
--- 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 ())
--- 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
+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 :: BrickInternalState -> Direction -> BrickInternalState
-moveCursor ais@(BrickInternalState {..}) direction =
-  let newIx = if direction == Down then ix + 1 else ix - 1
+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
--- 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
                }
--- 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
--- 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

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