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

Create brick tui wrt #24

Browse Source
This commit is contained in:
Julian Ospald 2020-07-06 22:39:16 +02:00
parent 35bf9b5ff2
commit 618a05484c
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
5 changed files with 346 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.gitlab/script/ghcup_release.sh
View File

@ -16,11 +16,11 @@ git describe
ecabal update
if [ "${OS}" = "LINUX" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static'
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static"
else
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static"
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" -ftui
fi
mkdir out

8
README.md
View File

@ -40,7 +40,13 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
See `ghcup --help`.
Common use cases are:
For the simple interactive TUI, run:
```sh
ghcup tui
```
For the full functionality via cli:
```sh
# list available ghc/cabal versions

291
app/ghcup/BrickMain.hs Normal file
View File

@ -0,0 +1,291 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import Brick
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List
import Codec.Archive
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
import Data.List
import Data.Char
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector )
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.Exit
import System.IO.Unsafe
import URI.ByteString
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
data AppState = AppState {
lr :: LR
, dls :: GHCupDownloads
}
type LR = GenericList String Vector ListResult
ui :: AppState -> Widget String
ui AppState {..} =
( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ renderList renderItem True lr)
)
)
<=> foldr1
(\x y -> x <+> str " " <+> y)
[ (str "q:Quit")
, (str "i:Install")
, (str "s:Set")
, (str "u:Uninstall")
, (str "c:ChangeLog")
, (str "↑↓:Navigation")
]
where
renderItem b ListResult {..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "✓ ")
| otherwise -> (withAttr "not-installed" $ str "✗ ")
ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
in ( marks
<+> ( padLeft (Pad 2)
$ minHSize 20
$ (withAttr
(bool "inactive" "active" b)
(str (fmap toLower . show $ lTool) <+> str " " <+> str ver)
)
)
<+> (padLeft (Pad 1) $ if null lTag
then str ""
else
foldr1 (\x y -> x <+> str "," <+> y)
$ (fmap printTag $ sort lTag)
)
)
printTag Recommended = withAttr "recommended" $ str "recommended"
printTag Latest = withAttr "latest" $ str "latest"
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> str (replicate s' ' '))
app :: App AppState e String
app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler
, appStartEvent = return
, appAttrMap = const theMap
, appChooseCursor = neverShowCursor
}
where
theMap = attrMap
Vty.defAttr
[ ("active" , bg Vty.blue)
, ("not-installed", fg Vty.red)
, ("set" , fg Vty.green)
, ("installed" , fg Vty.green)
, ("recommended" , fg Vty.green)
, ("latest" , fg Vty.yellow)
]
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
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 AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (AppState (listMoveUp lr) dls)
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (AppState (listMoveDown lr) dls)
eventHandler AppState { dls = dls', lr = lr' } (VtyEvent (Vty.EvKey (Vty.KChar c) _))
| (Just (ix, e)) <- listSelectedElement lr'
, c `elem` ['i', 's', 'u', 'c']
= suspendAndResume $ do
r <- case c of
'i' -> install' e dls'
's' -> set' e
'u' -> del' e
'c' -> changelog' e dls'
_ -> error ""
case r of
Left err -> throwIO $ userError err
Right _ -> do
apps <- (fmap . fmap)
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
getAppState
case apps of
Right as -> do
putStrLn "Press enter to continue"
_ <- getLine
pure as
Left err -> throwIO $ userError err
eventHandler st _ = continue st
install' :: ListResult -> GHCupDownloads -> IO (Either String ())
install' ListResult {..} dls = do
l <- readIORef logger'
let runLogger = myLoggerT l
let
run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[AlreadyInstalled, UnknownArchive, ArchiveResult, DistroNotFound, FileDoesNotExistError, CopyError, NoCompatibleArch, NoDownload, NotInstalled, NoCompatiblePlatform, BuildFailed, TagNotFound, DigestError, DownloadFailed, NoUpdate]
(run $ do
case lTool of
GHC -> liftE $ installGHCBin dls lVer Nothing
Cabal -> liftE $ installCabalBin dls lVer Nothing
GHCup -> liftE $ upgradeGHCup dls Nothing False $> ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V (BuildFailed _ e)) ->
pure $ Left [i|Build failed with #{e}|]
VLeft (V NoDownload) ->
pure $ Left [i|No available version for #{prettyVer lVer}|]
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}
Also check the logs in ~/.ghcup/logs|]
set' :: ListResult -> IO (Either String ())
set' ListResult {..} = do
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
(run $ do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
del' :: ListResult -> IO (Either String ())
del' ListResult {..} = do
l <- readIORef logger'
let runLogger = myLoggerT l
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
(run $ do
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
Cabal -> liftE $ rmCabalVer lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
changelog' :: ListResult -> GHCupDownloads -> IO (Either String ())
changelog' ListResult {..} dls = do
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
Just uri -> do
exec "xdg-open" True [serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left [i|#{e}|]
settings :: Settings
settings = Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
}
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: LoggerConfig -> IO ()
brickMain l = do
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
eApps <- getAppState
case eApps of
Right as -> defaultMain app as $> ()
Left _ -> do
runLogger ($(logError) [i|Error building app state|])
exitWith $ ExitFailure 2
getAppState :: IO (Either String AppState)
getAppState = do
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
. runE
@'[JSONError, DownloadFailed, FileDoesNotExistError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
$ do
(GHCupInfo _ dls) <- liftE $ getDownloadsF GHCupURL
lV <- liftE $ listVersions dls Nothing Nothing
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls)
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left [i|#{e}|]

33
app/ghcup/Main.hs
View File

@ -10,6 +10,10 @@
module Main where
#if defined(BRICK)
import BrickMain ( brickMain )
#endif
import GHCup
import GHCup.Download
import GHCup.Errors
@ -95,6 +99,9 @@ data Command
| Upgrade UpgradeOpts Bool
| ToolRequirements
| ChangeLog ChangeLogOptions
#if defined(BRICK)
| Interactive
#endif
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolTag Tag
@ -223,7 +230,20 @@ opts =
com :: Parser Command
com =
subparser
#if defined(BRICK)
( command
"tui"
( (\_ -> Interactive)
<$> (info
helper
( progDesc "Start the interactive GHCup UI"
)
)
)
<> command
#else
( command
#endif
"install"
( Install
<$> (info
@ -870,11 +890,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- logger interpreter
logfile <- initGHCupFileLogging [rel|ghcup.log|]
let runLogger = myLoggerT LoggerConfig
let loggerConfig = LoggerConfig
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}
let runLogger = myLoggerT loggerConfig
-------------------------
@ -910,7 +931,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, TagNotFound
]
let
@ -923,7 +943,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
let runRmGHC =
let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
@ -1107,7 +1127,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
(runRmGHC $ do
(runRm $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
@ -1117,7 +1137,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 7
let rmCabal' tv =
(runSetCabal $ do
(runRm $ do
liftE $ rmCabalVer tv
)
>>= \case
@ -1129,6 +1149,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of
#if defined(BRICK)
Interactive -> liftIO $ brickMain loggerConfig >> pure ExitSuccess
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
installGHC iopts

19
ghcup.cabal
View File

@ -21,6 +21,11 @@ source-repository head
type: git
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
flag tui
description: Build the brick powered tui (ghcup \-\-interactive)
default: False
manual: True
flag internal-downloader
description: Compile the internal downloader, which links against OpenSSL
default: False
@ -50,6 +55,9 @@ common base16-bytestring
common binary
build-depends: binary >=0.8.6.0
common brick
build-depends: brick >=0.54
common bytestring
build-depends: bytestring >=0.10
@ -158,7 +166,6 @@ common string-interpolate
common table-layout
build-depends: table-layout >=0.8
common template-haskell
build-depends: template-haskell >=2.7
@ -198,6 +205,9 @@ common vector
common versions
build-depends: versions >=3.5
common vty
build-depends: vty >=5.28.2
common word8
build-depends: word8 >=0.1.3
@ -350,6 +360,13 @@ executable ghcup
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
if flag(tui)
import:
brick
, vector
, vty
other-modules: BrickMain
cpp-options: -DBRICK
executable ghcup-gen
import: