From 618a05484c7ad7f3004b8dda2a35dd8a06465861 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Mon, 6 Jul 2020 22:39:16 +0200 Subject: [PATCH] Create brick tui wrt #24 --- .gitlab/script/ghcup_release.sh | 4 +- README.md | 8 +- app/ghcup/BrickMain.hs | 291 ++++++++++++++++++++++++++++++++ app/ghcup/Main.hs | 33 +++- ghcup.cabal | 19 ++- 5 files changed, 346 insertions(+), 9 deletions(-) create mode 100644 app/ghcup/BrickMain.hs diff --git a/.gitlab/script/ghcup_release.sh b/.gitlab/script/ghcup_release.sh index b19c238..88213d0 100755 --- a/.gitlab/script/ghcup_release.sh +++ b/.gitlab/script/ghcup_release.sh @@ -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 diff --git a/README.md b/README.md index 3fcae8b..1f6cfc2 100644 --- a/README.md +++ b/README.md @@ -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 diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs new file mode 100644 index 0000000..73ade30 --- /dev/null +++ b/app/ghcup/BrickMain.hs @@ -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}|] + diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 00aaef0..5bdde33 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -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 |] -- 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 |] @'[ FileDoesNotExistError , NotInstalled , TagNotFound - , TagNotFound ] let @@ -923,7 +943,7 @@ Report bugs at |] 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 |] pure $ ExitFailure 14 let rmGHC' RmOptions{..} = - (runRmGHC $ do + (runRm $ do liftE $ rmGHCVer ghcVer ) >>= \case @@ -1117,7 +1137,7 @@ Report bugs at |] pure $ ExitFailure 7 let rmCabal' tv = - (runSetCabal $ do + (runRm $ do liftE $ rmCabalVer tv ) >>= \case @@ -1129,6 +1149,9 @@ Report bugs at |] 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 diff --git a/ghcup.cabal b/ghcup.cabal index d3ef251..5ea769b 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -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: