hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Allow to configure ghcup with a yaml config file

Browse Source 
Fixes #41
This commit is contained in:
Julian Ospald
2020-10-24 22:03:00 +02:00
parent 241dadbeb5
commit 4fef93b7b1
9 changed files with 294 additions and 62 deletions
Download Patch File Download Diff File Expand all files Collapse all files

79
app/ghcup/BrickMain.hs
View File

@@ -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

115
app/ghcup/Main.hs
View File

@@ -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
}