diff --git a/CHANGELOG.md b/CHANGELOG.md index 38ae547..95ab981 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 06dd598..8741d1c 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 3bed66b..e18893d 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 091c2fd..8615af6 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 +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 diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 6efab75..efeecf3 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 "" <> help "Keep build directories? (default: errors)" - <> value Errors <> hidden - ) - <*> option + )) + <*> optional (option (eitherReader downloaderParser) ( long "downloader" #if defined(INTERNAL_DOWNLOADER) <> metavar "" <> help "Downloader to use (default: internal)" - <> value Internal #else <> metavar "" <> 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 |] -- 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 da7bd7b..a2a2f77 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 2da0a7c..e2cc526 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 dbe1f95..4333596 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 8558a75..0c2df15 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 ]-- -------------------------