From f157cf809e4ad25f2056fa12edd4903bb53e89b9 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 10 Jan 2024 07:14:59 +0100 Subject: [PATCH] Move tui code into its own library. --- app/ghcup/Main.hs | 3 +- ghcup.cabal | 52 +++ hie.yaml | 4 + lib-tui/GHCup/Brick/Actions.hs | 462 +++++++++++++++++++++ lib-tui/GHCup/Brick/App.hs | 118 ++++++ lib-tui/GHCup/Brick/Attributes.hs | 82 ++++ lib-tui/GHCup/Brick/BrickState.hs | 46 ++ lib-tui/GHCup/Brick/Common.hs | 112 +++++ lib-tui/GHCup/Brick/Widgets/KeyInfo.hs | 80 ++++ lib-tui/GHCup/Brick/Widgets/Navigation.hs | 148 +++++++ lib-tui/GHCup/Brick/Widgets/SectionList.hs | 192 +++++++++ lib-tui/GHCup/Brick/Widgets/Tutorial.hs | 84 ++++ lib-tui/GHCup/BrickMain.hs | 60 +++ 13 files changed, 1442 insertions(+), 1 deletion(-) create mode 100644 lib-tui/GHCup/Brick/Actions.hs create mode 100644 lib-tui/GHCup/Brick/App.hs create mode 100644 lib-tui/GHCup/Brick/Attributes.hs create mode 100644 lib-tui/GHCup/Brick/BrickState.hs create mode 100644 lib-tui/GHCup/Brick/Common.hs create mode 100644 lib-tui/GHCup/Brick/Widgets/KeyInfo.hs create mode 100644 lib-tui/GHCup/Brick/Widgets/Navigation.hs create mode 100644 lib-tui/GHCup/Brick/Widgets/SectionList.hs create mode 100644 lib-tui/GHCup/Brick/Widgets/Tutorial.hs create mode 100644 lib-tui/GHCup/BrickMain.hs diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index 5180511..a29a0dc 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -11,7 +11,8 @@ module Main where #if defined(BRICK) -import BrickMain ( brickMain ) +-- import BrickMain ( brickMain ) +import GHCup.BrickMain (brickMain) #endif import qualified GHCup.GHC as GHC diff --git a/ghcup.cabal b/ghcup.cabal index f27822e..13d83e5 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -322,6 +322,57 @@ library ghcup-optparse else build-depends: unix ^>=2.7 || ^>=2.8 +library ghcup-tui + import: app-common-depends + exposed-modules: + GHCup.BrickMain + GHCup.Brick.Widgets.Navigation + GHCup.Brick.Widgets.Tutorial + GHCup.Brick.Widgets.KeyInfo + GHCup.Brick.Widgets.SectionList + GHCup.Brick.Actions + GHCup.Brick.App + GHCup.Brick.BrickState + GHCup.Brick.Attributes + GHCup.Brick.Common + + hs-source-dirs: lib-tui + default-language: Haskell2010 + default-extensions: + LambdaCase + MultiWayIf + NamedFieldPuns + PackageImports + RecordWildCards + ScopedTypeVariables + StrictData + TupleSections + + ghc-options: + -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates + + build-depends: + , ghcup + , ghcup-optparse + , optics ^>=0.4 + , brick ^>=2.1 + , transformers ^>=0.5 + , vty ^>=6.0 + , optics ^>=0.4 + + if flag(internal-downloader) + cpp-options: -DINTERNAL_DOWNLOADER + + if flag(tui) + cpp-options: -DBRICK + + if os(windows) + cpp-options: -DIS_WINDOWS + + else + build-depends: unix ^>=2.7 + executable ghcup import: app-common-depends main-is: Main.hs @@ -345,6 +396,7 @@ executable ghcup build-depends: , ghcup , ghcup-optparse + , ghcup-tui if flag(internal-downloader) cpp-options: -DINTERNAL_DOWNLOADER diff --git a/hie.yaml b/hie.yaml index 2c73920..ec8d0ca 100644 --- a/hie.yaml +++ b/hie.yaml @@ -2,6 +2,10 @@ cradle: cabal: - component: "ghcup:lib:ghcup" path: ./lib + - component: "ghcup:lib:ghcup-optparse" + path: ./lib-opt + - component: "ghcup:lib:ghcup-tui" + path: ./lib-tui - component: "ghcup:exe:ghcup" path: ./app/ghcup - component: "ghcup:lib:ghcup-optparse" diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs new file mode 100644 index 0000000..3521da9 --- /dev/null +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHCup.Brick.Actions where + +import GHCup +import GHCup.Download +import GHCup.Errors +import GHCup.Types.Optics ( getDirs, getPlatformReq ) +import GHCup.Types hiding ( LeanAppState(..) ) +import GHCup.Utils +import GHCup.OptParse.Common (logGHCPostRm) +import GHCup.Prelude ( decUTF8Safe ) +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prompts +import GHCup.Brick.Common (BrickData(..), BrickSettings(..), Name(..), Mode(..)) +import qualified GHCup.Brick.Common as Common +import GHCup.Brick.BrickState +import GHCup.Brick.Widgets.SectionList +import GHCup.Brick.Widgets.Navigation (BrickInternalState) + +import qualified Brick +import qualified Brick.Widgets.List as L +import qualified Brick.Focus as F +import Codec.Archive +import Control.Applicative +import Control.Exception.Safe +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Except +import Control.Monad.Trans.Resource +import Data.Bool +import Data.Functor +import Data.Function ( (&), on) +import Data.List +import Data.Maybe +import Data.IORef (IORef, readIORef, newIORef, modifyIORef) +import Data.Versions hiding (Lens') +import Haskus.Utils.Variant.Excepts +import Prelude hiding ( appendFile ) +import System.Exit +import System.IO.Unsafe +import System.Process ( system ) +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import URI.ByteString + +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy as L +import qualified Graphics.Vty as Vty +import qualified Data.Vector as V +import System.Environment (getExecutablePath) +#if !IS_WINDOWS +import GHCup.Prelude.File +import System.FilePath +import qualified System.Posix.Process as SPP +#endif + +import Optics.State (use) +import Optics.State.Operators ( (.=)) +import Optics.Operators ((.~),(%~)) +import Optics.Getter (view) + + +{- Core Logic. + +This module defines the IO actions we can execute within the Brick App: + - Install + - Set + - UnInstall + - Launch the Changelog + +-} + +-- | Update app data and list internal state based on new evidence. +-- This synchronises @BrickInternalState@ with @BrickData@ +-- and @BrickSettings@. +updateList :: BrickData -> BrickState -> BrickState +updateList appD BrickState{..} = + let newInternalState = constructList appD _appSettings (Just _appState) + in BrickState { _appState = newInternalState + , _appData = appD + , _appSettings = _appSettings + , _appKeys = _appKeys + , _mode = Navigation + } + +constructList :: BrickData + -> BrickSettings + -> Maybe BrickInternalState + -> BrickInternalState +constructList appD settings = + replaceLR (filterVisible (_showAllVersions settings)) + (_lr appD) + +-- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0 +selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState +selectBy tool predicate internal_state = + let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state) + tool_lens = sectionL (Singular tool) + in internal_state + & sectionListFocusRingL .~ new_focus + & tool_lens %~ L.listMoveTo 0 -- We move to 0 first + & tool_lens %~ L.listFindBy predicate -- The lookup by the predicate. + +-- | Select the latests GHC tool +selectLatest :: BrickInternalState -> BrickInternalState +selectLatest = selectBy GHC (elem Latest . lTag) + + +-- | Replace the @appState@ or construct it based on a filter function +-- and a new @[ListResult]@ evidence. +-- When passed an existing @appState@, tries to keep the selected element. +replaceLR :: (ListResult -> Bool) + -> [ListResult] + -> Maybe BrickInternalState + -> BrickInternalState +replaceLR filterF list_result s = + let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e) + newVec = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] + newSectionList = sectionList AllTools newVec 1 + in case oldElem of + Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList + Nothing -> selectLatest newSectionList + where + toolEqual e1 e2 = + lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 + + +filterVisible :: Bool -> ListResult -> Bool +filterVisible v e | lInstalled e = True + | v + , Nightly `notElem` lTag e = True + | not v + , Old `notElem` lTag e + , Nightly `notElem` lTag e = True + | otherwise = (Old `notElem` lTag e) && + (Nightly `notElem` lTag e) + +-- | Suspend the current UI and run an IO action in terminal. If the +-- IO action returns a Left value, then it's thrown as userError. +withIOAction :: (Ord n, Eq n) + => ( (Int, ListResult) -> ReaderT AppState IO (Either String a)) + -> Brick.EventM n BrickState () +withIOAction action = do + as <- Brick.get + case sectionListSelectedElement (view appState as) of + Nothing -> pure () + Just (curr_ix, e) -> do + Brick.suspendAndResume $ do + settings <- readIORef settings' + flip runReaderT settings $ action (curr_ix, e) >>= \case + Left err -> liftIO $ putStrLn ("Error: " <> err) + Right _ -> liftIO $ putStrLn "Success" + getAppData Nothing >>= \case + Right data' -> do + putStrLn "Press enter to continue" + _ <- getLine + pure (updateList data' as) + Left err -> throwIO $ userError err + +install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => (Int, ListResult) + -> m (Either String ()) +install' (_, ListResult {..}) = do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + + let run = + runResourceT + . runE + @'[ AlreadyInstalled + , ArchiveResult + , UnknownArchive + , FileDoesNotExistError + , CopyError + , NoDownload + , NotInstalled + , BuildFailed + , TagNotFound + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , DirNotEmpty + , NoUpdate + , TarDirDoesNotExist + , FileAlreadyExistsError + , ProcessError + , ToolShadowed + , UninstallFailed + , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch + ] + + run (do + ce <- liftIO $ fmap (either (const Nothing) Just) $ + try @_ @SomeException $ getExecutablePath >>= canonicalizePath + dirs <- lift getDirs + case lTool of + GHC -> do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls + liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce) + Cabal -> do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls + liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) + GHCup -> do + let vi = snd <$> getLatest dls GHCup + liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) + HLS -> do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls + liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) + Stack -> do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls + liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) + ) + >>= \case + VRight (vi, Dirs{..}, Just ce) -> do + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + case lTool of + GHCup -> do +#if !IS_WINDOWS + up <- liftIO $ fmap (either (const Nothing) Just) + $ try @_ @SomeException $ canonicalizePath (binDir "ghcup" <.> exeExt) + when ((normalise <$> up) == Just (normalise ce)) $ + -- TODO: track cli arguments of previous invocation + liftIO $ SPP.executeFile ce False ["tui"] Nothing +#else + logInfo "Please restart 'ghcup' for the changes to take effect" +#endif + _ -> pure () + pure $ Right () + VRight (vi, _, _) -> do + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + logInfo "Please restart 'ghcup' for the changes to take effect" + pure $ Right () + VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () + VLeft (V NoUpdate) -> pure $ Right () + VLeft e -> pure $ Left $ prettyHFError e <> "\n" + <> "Also check the logs in ~/.ghcup/logs" + + +set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => (Int, ListResult) + -> m (Either String ()) +set' input@(_, ListResult {..}) = do + settings <- liftIO $ readIORef settings' + + let run = + flip runReaderT settings + . runResourceT + . runE + @'[ AlreadyInstalled + , ArchiveResult + , UnknownArchive + , FileDoesNotExistError + , CopyError + , NoDownload + , NotInstalled + , BuildFailed + , TagNotFound + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , DirNotEmpty + , NoUpdate + , TarDirDoesNotExist + , FileAlreadyExistsError + , ProcessError + , ToolShadowed + , UninstallFailed + , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch + ] + + run (do + case lTool of + GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> () + Cabal -> liftE $ setCabal lVer $> () + HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> () + Stack -> liftE $ setStack lVer $> () + GHCup -> do + promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: " + case promptAnswer of + PromptYes -> do + void $ liftE $ upgradeGHCup Nothing False False + PromptNo -> pure () + ) + >>= \case + VRight _ -> pure $ Right () + VLeft e -> case e of + (V (NotInstalled tool _)) -> do + promptAnswer <- getUserPromptResponse userPrompt + case promptAnswer of + PromptYes -> do + res <- install' input + case res of + (Left err) -> pure $ Left err + (Right _) -> do + logInfo "Setting now..." + set' input + + PromptNo -> pure $ Left (prettyHFError e) + where + userPrompt = L.toStrict . B.toLazyText . B.fromString $ + "This Version of " + <> show tool + <> " you are trying to set is not installed.\n" + <> "Would you like to install it first? [Y/N]: " + + _ -> pure $ Left (prettyHFError e) + + + +del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) + => (Int, ListResult) + -> m (Either String ()) +del' (_, ListResult {..}) = do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + + let run = runE @'[NotInstalled, UninstallFailed] + + run (do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls + case lTool of + GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi + Cabal -> liftE $ rmCabalVer lVer $> vi + HLS -> liftE $ rmHLSVer lVer $> vi + Stack -> liftE $ rmStackVer lVer $> vi + GHCup -> pure Nothing + ) + >>= \case + VRight vi -> do + when (lTool == GHC) $ logGHCPostRm (mkTVer lVer) + forM_ (_viPostRemove =<< vi) $ \msg -> + logInfo msg + pure $ Right () + VLeft e -> pure $ Left (prettyHFError e) + + +changelog' :: (MonadReader AppState m, MonadIO m) + => (Int, ListResult) + -> m (Either String ()) +changelog' (_, ListResult {..}) = do + AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + case getChangeLog dls lTool (ToolVersion lVer) of + Nothing -> pure $ Left $ + "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer) + Just uri -> do + case _rPlatform pfreq of + Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + Windows -> do + let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri) + c <- liftIO $ system $ args + case c of + (ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args] + ExitSuccess -> pure $ Right () + + >>= \case + Right _ -> pure $ Right () + Left e -> pure $ Left $ prettyHFError e + + +settings' :: IORef AppState +{-# NOINLINE settings' #-} +settings' = unsafePerformIO $ do + dirs <- getAllDirs + let loggerConfig = LoggerConfig { lcPrintDebug = False + , consoleOutter = \_ -> pure () + , fileOutter = \_ -> pure () + , fancyColors = True + } + newIORef $ AppState defaultSettings + dirs + defaultKeyBindings + (GHCupInfo mempty mempty Nothing) + (PlatformRequest A_64 Darwin Nothing) + loggerConfig + + +getGHCupInfo :: IO (Either String GHCupInfo) +getGHCupInfo = do + settings <- readIORef settings' + + r <- + flip runReaderT settings + . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError] + $ do + pfreq <- lift getPlatformReq + liftE $ getDownloadsF pfreq + + case r of + VRight a -> pure $ Right a + VLeft e -> pure $ Left (prettyHFError e) + + +getAppData :: Maybe GHCupInfo + -> IO (Either String BrickData) +getAppData mgi = runExceptT $ do + r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi + liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r }) + settings <- liftIO $ readIORef settings' + + flip runReaderT settings $ do + lV <- listVersions Nothing [] False True (Nothing, Nothing) + pure $ BrickData (reverse lV) + +-- + +keyHandlers :: KeyBindings + -> [ ( KeyCombination + , BrickSettings -> String + , Brick.EventM Name BrickState () + ) + ] +keyHandlers KeyBindings {..} = + [ (bQuit, const "Quit" , Brick.halt) + , (bInstall, const "Install" , withIOAction install') + , (bUninstall, const "Uninstall", withIOAction del') + , (bSet, const "Set" , withIOAction set') + , (bChangelog, const "ChangeLog", withIOAction changelog') + , ( bShowAllVersions + , \BrickSettings {..} -> + if _showAllVersions then "Don't show all versions" else "Show all versions" + , hideShowHandler' (not . _showAllVersions) + ) + , (bUp, const "Up", Common.zoom appState moveUp) + , (bDown, const "Down", Common.zoom appState moveDown) + , (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo) + ] + where + --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () + hideShowHandler' f = do + app_settings <- use appSettings + let + vers = f app_settings + newAppSettings = app_settings & Common.showAllVersions .~ vers + ad <- use appData + current_app_state <- use appState + appSettings .= newAppSettings + appState .= constructList ad newAppSettings (Just current_app_state) \ No newline at end of file diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs new file mode 100644 index 0000000..eaa0923 --- /dev/null +++ b/lib-tui/GHCup/Brick/App.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module defines the brick App. The pattern is very simple: + +- Pattern match on the Mode +- Dispatch drawing/events to the corresponding widget/s + +In general each widget should know how to draw itself and how to handle its own events, so this +module should only contain: + +- how to draw non-widget information. For example the footer +- how to change between modes (widgets aren't aware of the whole application state) + +-} + +module GHCup.Brick.App where + +import GHCup.Types ( AppState(AppState, keyBindings), KeyCombination(KeyCombination) ) +import GHCup.Brick.Common ( Name(..), Mode(..)) +import qualified GHCup.Brick.Common as Common +import GHCup.Brick.BrickState (BrickState(..), appState, mode, appKeys, appSettings) +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Widgets.Navigation as Navigation +import qualified GHCup.Brick.Widgets.Tutorial as Tutorial +import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo +import qualified GHCup.Brick.Actions as Actions + +import Brick + ( BrickEvent(VtyEvent), + App(..), + AttrMap, + EventM, + Widget(..), + (<=>)) +import qualified Brick +import Control.Monad.Reader + ( void, MonadIO(liftIO) ) +import Data.List ( find, intercalate) +import Data.IORef (readIORef) +import Prelude hiding ( appendFile ) + +import qualified Graphics.Vty as Vty + +import Optics.State (use) +import Optics.State.Operators ( (.=)) +import Optics.Operators ((^.)) +import qualified Data.Text as T + +app :: AttrMap -> AttrMap -> App BrickState () Name +app attrs dimAttrs = + App { appDraw = drawUI dimAttrs + , appHandleEvent = eventHandler + , appStartEvent = return () + , appAttrMap = const attrs + , appChooseCursor = Brick.showFirstCursor + } + +drawUI :: AttrMap -> BrickState -> [Widget Name] +drawUI dimAttrs st = + let + footer = Brick.withAttr Attributes.helpAttr + . Brick.txtWrap + . T.pack + . foldr1 (\x y -> x <> " " <> y) + . fmap (\(KeyCombination key mods, pretty_setting, _) + -> intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) <> ":" <> pretty_setting (st ^. appSettings) + ) + $ Actions.keyHandlers (st ^. appKeys) + navg = Navigation.draw dimAttrs (st ^. appState) <=> footer + in case st ^. mode of + Navigation -> [navg] + Tutorial -> [Tutorial.draw, navg] + KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] +-- InstallPopUp -> [drawCompilePopUp (st ^. popUp), navg] + +-- | On q, go back to navigation. +-- On Enter, to go to tutorial +keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState () +keyInfoHandler ev = case ev of + VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation + VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial + _ -> pure () + +-- | On q, go back to navigation. Else, do nothing +tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () +tutorialHandler ev = + case ev of + VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation + _ -> pure () + +-- | Tab/Arrows to navigate. +navigationHandler :: BrickEvent Name e -> EventM Name BrickState () +navigationHandler ev = do + AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings' + case ev of + inner_event@(VtyEvent (Vty.EvKey key _)) -> + case find (\(key', _, _) -> key' == KeyCombination key []) (Actions.keyHandlers kb) of + Just (_, _, handler) -> handler + Nothing -> void $ Common.zoom appState $ Navigation.handler inner_event + inner_event -> Common.zoom appState $ Navigation.handler inner_event + + +eventHandler :: BrickEvent Name e -> EventM Name BrickState () +eventHandler ev = do + m <- use mode + case m of + KeyInfo -> keyInfoHandler ev + Tutorial -> tutorialHandler ev + Navigation -> navigationHandler ev +-- InstallPopUp -> compilePopUpHandler ev diff --git a/lib-tui/GHCup/Brick/Attributes.hs b/lib-tui/GHCup/Brick/Attributes.hs new file mode 100644 index 0000000..194bbed --- /dev/null +++ b/lib-tui/GHCup/Brick/Attributes.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module defined the attributes. Despite of brick's capability to have a hierarchy of attributes, here +we go for the most-simple-approach: a plain hierarchy +-} + +module GHCup.Brick.Attributes where + +import Brick ( AttrMap) +import qualified Brick +import qualified Brick.Widgets.List as L +import qualified Graphics.Vty as Vty + +defaultAttributes :: Bool -> AttrMap +defaultAttributes no_color = Brick.attrMap + Vty.defAttr + [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) + , (L.listSelectedAttr , Vty.defAttr) + , (notInstalledAttr , Vty.defAttr `withForeColor` Vty.red) + , (setAttr , Vty.defAttr `withForeColor` Vty.green) + , (installedAttr , Vty.defAttr `withForeColor` Vty.green) + , (recommendedAttr , Vty.defAttr `withForeColor` Vty.green) + , (hlsPoweredAttr , Vty.defAttr `withForeColor` Vty.green) + , (latestAttr , Vty.defAttr `withForeColor` Vty.yellow) + , (latestPrereleaseAttr , Vty.defAttr `withForeColor` Vty.red) + , (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red) + , (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red) + , (nightlyAttr , Vty.defAttr `withForeColor` Vty.red) + , (compiledAttr , Vty.defAttr `withForeColor` Vty.blue) + , (strayAttr , Vty.defAttr `withForeColor` Vty.blue) + , (dayAttr , Vty.defAttr `withForeColor` Vty.blue) + , (helpAttr , Vty.defAttr `withStyle` Vty.italic) + , (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite) + ] + where + withForeColor | no_color = const + | otherwise = Vty.withForeColor + + withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo + | otherwise = Vty.withBackColor + + withStyle = Vty.withStyle + + +notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr:: Brick.AttrName +latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr:: Brick.AttrName +compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr:: Brick.AttrName + +notInstalledAttr = Brick.attrName "not-installed" +setAttr = Brick.attrName "set" +installedAttr = Brick.attrName "installed" +recommendedAttr = Brick.attrName "recommended" +hlsPoweredAttr = Brick.attrName "hls-powered" +latestAttr = Brick.attrName "latest" +latestPrereleaseAttr = Brick.attrName "latest-prerelease" +latestNightlyAttr = Brick.attrName "latest-nightly" +prereleaseAttr = Brick.attrName "prerelease" +nightlyAttr = Brick.attrName "nightly" +compiledAttr = Brick.attrName "compiled" +strayAttr = Brick.attrName "stray" +dayAttr = Brick.attrName "day" +helpAttr = Brick.attrName "help" +hoorayAttr = Brick.attrName "hooray" + +dimAttributes :: Bool -> AttrMap +dimAttributes no_color = Brick.attrMap + (Vty.defAttr `Vty.withStyle` Vty.dim) + [ (Brick.attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ?? + , (Brick.attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) + ] + where + withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo + | otherwise = Vty.withBackColor diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs new file mode 100644 index 0000000..5356a6e --- /dev/null +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE InstanceSigs #-} + +{- +This module contains the BrickState. One could be tempted to include this data structure in GHCup.Brick.Common, +but it is better to make a separated module in order to avoid cyclic dependencies. + +This happens because the BrickState is sort of a container for all widgets, +but widgets depends on common functionality, hence: + + BrickState `depends on` Widgets.XYZ `depends on` Common + +The linear relation above breaks if BrickState is defined in Common. + +-} + +module GHCup.Brick.BrickState where + +import GHCup.Types ( KeyBindings ) +import GHCup.Brick.Common ( BrickData(..), BrickSettings(..), Mode(..)) +import GHCup.Brick.Widgets.Navigation ( BrickInternalState) +import Optics.TH (makeLenses) + + +data BrickState = BrickState + { _appData :: BrickData + , _appSettings :: BrickSettings + , _appState :: BrickInternalState + , _appKeys :: KeyBindings + , _mode :: Mode + } + --deriving Show + +makeLenses ''BrickState diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs new file mode 100644 index 0000000..2f6d33d --- /dev/null +++ b/lib-tui/GHCup/Brick/Common.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE InstanceSigs #-} + +{- +This module contains common values used across the library. Crucially it contains two important types for the brick app: + +- Name: List all resources (widgets) used by the app. see https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst#resource-names +- Mode: Use to dispatch events and drawings. see: https://github.com/jtdaugherty/brick/issues/476#issuecomment-1629151920 + +-} + +module GHCup.Brick.Common where + +import GHCup.List ( ListResult ) +import GHCup.Types ( Tool ) +import Prelude hiding ( appendFile ) +import qualified Graphics.Vty as Vty +import Optics.TH (makeLenses) +import Optics.Lens (toLensVL) +import qualified Brick + +-- | Some verbosity. A FocusRing (to loop through advance options), needs an set of resource names to be able to +-- dtermine focus. See https://hackage.haskell.org/package/brick-2.1.1/docs/Brick-Focus.html#t:FocusRing +{- data PopUpResources + = UrlEditBox + | SetCheckBox + | IsolateEditBox + | ForceCheckBox + | AdditionalEditBox + | RegularInstallButton + | AdvanceInstallButton + | CancellInstallButton + deriving (Eq, Ord, Show) +-} + +-- | Name data type. Uniquely identifies each widget in the TUI. +-- some constructors might end up unused, but still is a good practise +-- to have all of them defined, just in case +data Name = AllTools -- ^ The main list widget + | Singular Tool -- ^ The particular list for each tool + | KeyInfoBox -- ^ The text box widget with action informacion + | TutorialBox -- ^ The tutorial widget +-- | PopUpBox -- ^ The whole popUp widget +-- | PopUpElement PopUpResources -- ^ each element in the popUp + deriving (Eq, Ord, Show) + +-- | Mode type. It helps to dispatch events to different handlers. +data Mode = Navigation | KeyInfo | Tutorial deriving (Eq, Show, Ord) + +installedSign :: String +#if IS_WINDOWS +installedSign = "I " +#else +installedSign = "✓ " +#endif + +setSign :: String +#if IS_WINDOWS +setSign = "IS" +#else +setSign = "✔✔" +#endif + +notInstalledSign :: String +#if IS_WINDOWS +notInstalledSign = "X " +#else +notInstalledSign = "✗ " +#endif + +showKey :: Vty.Key -> String +showKey (Vty.KChar c) = [c] +showKey Vty.KUp = "↑" +showKey Vty.KDown = "↓" +showKey key = tail (show key) + +showMod :: Vty.Modifier -> String +showMod = tail . show + + +-- I refuse to give this a type signature. + +-- | Given a lens, zoom on it. It is needed because Brick uses microlens but GHCup uses optics. +zoom l = Brick.zoom (toLensVL l) + +data BrickData = BrickData + { _lr :: [ListResult] + } + deriving Show + +makeLenses ''BrickData + +data BrickSettings = BrickSettings { _showAllVersions :: Bool} + --deriving Show + +makeLenses ''BrickSettings + +defaultAppSettings :: BrickSettings +defaultAppSettings = BrickSettings { _showAllVersions = False} diff --git a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs new file mode 100644 index 0000000..bc89acf --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +A very simple information-only widget with no handler. +-} + +module GHCup.Brick.Widgets.KeyInfo where + +import GHCup.Types ( KeyBindings(..), KeyCombination(KeyCombination) ) +import qualified GHCup.Brick.Common as Common + + +import Brick + ( Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( borderWithLabel) +import Brick.Widgets.Border.Style ( unicode ) +import Brick.Widgets.Center ( center, centerLayer ) +import Data.List ( intercalate ) +import Prelude hiding ( appendFile ) + + + +draw :: KeyBindings -> Widget Common.Name +draw KeyBindings {..} = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) + in centerLayer + $ Brick.hLimitPercent 75 + $ Brick.vLimitPercent 50 + $ Brick.withBorderStyle unicode + $ borderWithLabel (Brick.txt "Key Actions") + $ Brick.vBox [ + center $ + mkTextBox [ + Brick.hBox [ + Brick.txt "Press " + , keyToWidget bUp, Brick.txt " and ", keyToWidget bDown + , Brick.txtWrap " to navigate the list of tools" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bInstall + , Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bSet + , Brick.txtWrap " to set a tool as the one for use" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bUninstall + , Brick.txtWrap " to uninstall a tool" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bChangelog + , Brick.txtWrap " to open the tool's changelog. It will open a web browser" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bShowAllVersions + , Brick.txtWrap " to show older version of each tool" + ] + ] + ] + <=> Brick.hBox [Brick.txt "Press q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"] diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs new file mode 100644 index 0000000..f4826eb --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Navigation.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- Brick's navigation widget: +It is a FocusRing over many list's. Each list contains the information for each tool. Each list has an internal name (for Brick's runtime) +and a label which we can use in rendering. This data-structure helps to reuse Brick.Widget.List and to navegate easily across + +-} + + +module GHCup.Brick.Widgets.Navigation (BrickInternalState, create, handler, draw) where + +import GHCup.List ( ListResult(..) ) +import GHCup.Types + ( GHCTargetVersion(GHCTargetVersion), + Tool(..), + Tag(..), + tVerToText, + tagToString ) +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Widgets.SectionList as SectionList +import Brick + ( BrickEvent(..), + Padding(Max, Pad), + AttrMap, + EventM, + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( hBorder, borderWithLabel) +import Brick.Widgets.Border.Style ( unicode ) +import Brick.Widgets.Center ( center ) +import qualified Brick.Widgets.List as L +import Data.List ( intercalate, sort ) +import Data.Maybe ( mapMaybe ) +import Data.Vector ( Vector) +import Data.Versions ( prettyPVP, prettyVer ) +import Prelude hiding ( appendFile ) +import qualified Data.Text as T +import qualified Data.Vector as V + + +type BrickInternalState = SectionList.SectionList Common.Name ListResult + +-- | How to create a navigation widget +create :: Common.Name -- The name of the section list + -> [(Common.Name, Vector ListResult)] -- a list of tuples (section name, collection of elements) + -> Int -- The height of each item in a list. Commonly 1 + -> BrickInternalState +create = SectionList.sectionList + +-- | How the navigation handler handle events +handler :: BrickEvent Common.Name e -> EventM Common.Name BrickInternalState () +handler = SectionList.handleGenericListEvent + +-- | How to draw the navigation widget +draw :: AttrMap -> BrickInternalState -> Widget Common.Name +draw dimAttrs section_list + = Brick.padBottom Max + ( Brick.withBorderStyle unicode + $ borderWithLabel (Brick.str "GHCup") + (center (header <=> hBorder <=> renderList' section_list)) + ) + where + header = + minHSize 2 Brick.emptyWidget + <+> Brick.padLeft (Pad 2) (minHSize 6 $ Brick.str "Tool") + <+> minHSize 15 (Brick.str "Version") + <+> Brick.padLeft (Pad 1) (minHSize 25 $ Brick.str "Tags") + <+> Brick.padLeft (Pad 5) (Brick.str "Notes") + renderList' bis = + let allElements = V.concatMap L.listElements $ SectionList.sectionListElements bis + minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) allElements + minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) allElements + in Brick.withDefAttr L.listAttr $ SectionList.renderSectionList (renderItem minTagSize minVerSize) True bis + renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} = + let marks = if + | lSet -> (Brick.withAttr Attributes.setAttr $ Brick.str Common.setSign) + | lInstalled -> (Brick.withAttr Attributes.installedAttr $ Brick.str Common.installedSign) + | otherwise -> (Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign) + ver = case lCross of + Nothing -> T.unpack . prettyVer $ lVer + Just c -> T.unpack (c <> "-" <> prettyVer lVer) + dim + | lNoBindist && not lInstalled + && not b -- TODO: overloading dim and active ignores active + -- so we hack around it here + = Brick.updateAttrMap (const dimAttrs) . Brick.withAttr (Brick.attrName "no-bindist") + | otherwise = id + hooray + | elem Latest lTag' && not lInstalled = + Brick.withAttr Attributes.hoorayAttr + | otherwise = id + in hooray $ dim + ( marks + <+> Brick.padLeft (Pad 2) + ( minHSize 6 + (printTool lTool) + ) + <+> minHSize minVerSize (Brick.str ver) + <+> (let l = mapMaybe printTag $ sort lTag' + in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l + then Brick.emptyWidget + else foldr1 (\x y -> x <+> Brick.str "," <+> y) l + ) + <+> Brick.padLeft (Pad 5) + ( let notes = printNotes listResult + in if null notes + then Brick.emptyWidget + else foldr1 (\x y -> x <+> Brick.str "," <+> y) notes + ) + <+> Brick.vLimit 1 (Brick.fill ' ') + ) + + printTag Recommended = Just $ Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended" + printTag Latest = Just $ Brick.withAttr Attributes.latestAttr $ Brick.str "latest" + printTag Prerelease = Just $ Brick.withAttr Attributes.prereleaseAttr $ Brick.str "prerelease" + printTag Nightly = Just $ Brick.withAttr Attributes.nightlyAttr $ Brick.str "nightly" + printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp'')) + printTag Old = Nothing + printTag LatestPrerelease = Just $ Brick.withAttr Attributes.latestPrereleaseAttr $ Brick.str "latest-prerelease" + printTag LatestNightly = Just $ Brick.withAttr Attributes.latestNightlyAttr $ Brick.str "latest-nightly" + printTag (UnknownTag t) = Just $ Brick.str t + + printTool Cabal = Brick.str "cabal" + printTool GHC = Brick.str "GHC" + printTool GHCup = Brick.str "GHCup" + printTool HLS = Brick.str "HLS" + printTool Stack = Brick.str "Stack" + + printNotes ListResult {..} = + (if hlsPowered then [Brick.withAttr Attributes.hlsPoweredAttr $ Brick.str "hls-powered"] else mempty + ) + ++ (if lStray then [Brick.withAttr Attributes.strayAttr $ Brick.str "stray"] else mempty) + ++ (case lReleaseDay of + Nothing -> mempty + Just d -> [Brick.withAttr Attributes.dayAttr $ Brick.str (show d)]) + + minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') \ No newline at end of file diff --git a/lib-tui/GHCup/Brick/Widgets/SectionList.hs b/lib-tui/GHCup/Brick/Widgets/SectionList.hs new file mode 100644 index 0000000..071b1a3 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/SectionList.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE InstanceSigs #-} + +{- A general system for lists with sections + +Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing +the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). + +- To build a SectionList use the safe constructor sectionList +- To access sections use the lens provider sectionL and the name of the section you'd like to access +- You can modify Brick.Widget.List.GenericList within GenericSectionList via sectionL but do not + modify the vector length + +-} + + +module GHCup.Brick.Widgets.SectionList where + + +import Brick + ( BrickEvent(VtyEvent, MouseDown), + EventM, + Size(..), + Widget(..), + ViewportType (Vertical), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( hBorder) +import qualified Brick.Widgets.List as L +import Brick.Focus (FocusRing) +import qualified Brick.Focus as F +import Data.Function ( (&)) +import Data.Maybe ( fromMaybe ) +import Data.Vector ( Vector ) +import qualified GHCup.Brick.Common as Common +import Prelude hiding ( appendFile ) + +import qualified Graphics.Vty as Vty +import qualified Data.Vector as V + +import Optics.TH (makeLensesFor) +import Optics.State (use) +import Optics.State.Operators ( (%=), (<%=)) +import Optics.Operators ((.~), (^.)) +import Optics.Lens (Lens', lens) + +data GenericSectionList n t e + = GenericSectionList + { sectionListFocusRing :: FocusRing n -- ^ The FocusRing for all sections + , sectionListElements :: !(Vector (L.GenericList n t e)) -- ^ A vector of brick's built-in list + , sectionListName :: n -- ^ The section list name + } + +makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListElements", "sectionListElementsL"), ("sectionListName", "sectionListNameL")] ''GenericSectionList + +type SectionList n e = GenericSectionList n V.Vector e + + +-- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses. +sectionList :: Foldable t + => n -- The name of the section list + -> [(n, t e)] -- a list of tuples (section name, collection of elements) + -> Int + -> GenericSectionList n t e +sectionList name elements height + = GenericSectionList + { sectionListFocusRing = F.focusRing [section_name | (section_name, _) <- elements] + , sectionListElements = V.fromList [L.list section_name els height | (section_name, els) <- elements] + , sectionListName = name + } +-- | This lens constructor, takes a name and looks if a section has such a name. +-- Used to dispatch events to sections. It is a partial function only meant to +-- be used with the FocusRing inside GenericSectionList +sectionL :: Eq n => n -> Lens' (GenericSectionList n t e) (L.GenericList n t e) +sectionL section_name = lens g s + where is_section_name = (== section_name) . L.listName + g section_list = + let elms = section_list ^. sectionListElementsL + zeroth = elms V.! 0 -- TODO: This crashes for empty vectors. + in fromMaybe zeroth (V.find is_section_name elms) + s gl@(GenericSectionList _ elms _) list = + case V.findIndex is_section_name elms of + Nothing -> gl + Just i -> let new_elms = V.update elms (V.fromList [(i, list)]) + in gl & sectionListElementsL .~ new_elms + +moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () +moveDown = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> do -- If it is the last element, move to the first element of the next focus; else, just handle regular list event. + current_list <- use (sectionL l) + let current_idx = L.listSelected current_list + list_length = current_list & length + if current_idx == Just (list_length - 1) + then do + new_focus <- sectionListFocusRingL <%= F.focusNext + case F.focusGetCurrent new_focus of + Nothing -> pure () -- |- Optic.Zoom.zoom doesn't typecheck but Lens.Micro.Mtl.zoom does. It is re-exported by Brick + Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToBeginning) + else Common.zoom (sectionL l) $ Brick.modify L.listMoveDown + +moveUp :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () +moveUp = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> do -- If it is the first element, move to the last element of the prev focus; else, just handle regular list event. + current_list <- use (sectionL l) + let current_idx = L.listSelected current_list + if current_idx == Just 0 + then do + new_focus <- sectionListFocusRingL <%= F.focusPrev + case F.focusGetCurrent new_focus of + Nothing -> pure () + Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToEnd) + else Common.zoom (sectionL l) $ Brick.modify L.listMoveUp + +-- | Handle events for list cursor movement. Events handled are: +-- +-- * Up (up arrow key). If first element of section, then jump prev section +-- * Down (down arrow key). If last element of section, then jump next section +-- * Page Up (PgUp) +-- * Page Down (PgDown) +-- * Go to next section (Tab) +-- * Go to prev section (BackTab) +handleGenericListEvent :: (Foldable t, L.Splittable t, Ord n) + => BrickEvent n a + -> EventM n (GenericSectionList n t e) () +handleGenericListEvent (VtyEvent (Vty.EvResize _ _)) = pure () +handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab [])) = sectionListFocusRingL %= F.focusPrev +handleGenericListEvent (MouseDown _ Vty.BScrollDown _ _) = moveDown +handleGenericListEvent (MouseDown _ Vty.BScrollUp _ _) = moveUp +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KDown [])) = moveDown +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KUp [])) = moveUp +handleGenericListEvent (VtyEvent ev) = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> Common.zoom (sectionL l) $ L.handleListEvent ev +handleGenericListEvent _ = pure () + +-- This re-uses Brick.Widget.List.renderList +renderSectionList :: (Traversable t, Ord n, Show n, Eq n, L.Splittable t) + => (Bool -> e -> Widget n) -- ^ Rendering function of the list element, True for the selected element + -> Bool -- ^ Whether the section list has focus + -> GenericSectionList n t e -- ^ The section list to render + -> Widget n +renderSectionList render_elem section_focus (GenericSectionList focus elms sl_name) = + Brick.Widget Brick.Greedy Brick.Greedy $ do + c <- Brick.getContext + let -- A section is focused if the whole thing is focused, and the inner list has focus + section_is_focused l = section_focus && (Just (L.listName l) == F.focusGetCurrent focus) + -- We need to limit the widget size when the length of the list is higher than the size of the terminal + limit = min (Brick.windowHeight c) (Brick.availHeight c) + s_idx = fromMaybe 0 $ V.findIndex section_is_focused elms + render_inner_list has_focus l = Brick.vLimit (length l) $ L.renderList (\b -> render_elem (b && has_focus)) has_focus l + (widget, off) = + V.ifoldl' (\wacc i list -> + let has_focus_list = section_is_focused list + (!acc_widget, !acc_off) = wacc + new_widget = if i == 0 then render_inner_list has_focus_list list else hBorder <=> render_inner_list has_focus_list list + new_off + | i < s_idx = 1 + L.listItemHeight list * length list + | i == s_idx = 1 + L.listItemHeight list * fromMaybe 0 (L.listSelected list) + | otherwise = 0 + in (acc_widget <=> new_widget, acc_off + new_off) + ) + (Brick.emptyWidget, 0) + elms + Brick.render $ Brick.viewport sl_name Brick.Vertical $ Brick.translateBy (Brick.Location (0, min 0 (limit-off))) widget + +-- | Equivalent to listSelectedElement +sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) +sectionListSelectedElement generic_section_list = do + current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent + let current_section = generic_section_list ^. sectionL current_focus + L.listSelectedElement current_section diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs new file mode 100644 index 0000000..447f1d0 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +A very simple information-only widget with no handler. +-} + +module GHCup.Brick.Widgets.Tutorial (draw) where + +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.Attributes as Attributes + +import Brick + ( Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( hBorder, borderWithLabel) +import Brick.Widgets.Border.Style ( unicode ) +import Brick.Widgets.Center ( center, centerLayer ) +import Prelude hiding ( appendFile ) + + + +draw :: Widget Common.Name +draw = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + txt_separator = hBorder <+> Brick.str " o " <+> hBorder + in centerLayer + $ Brick.hLimitPercent 75 + $ Brick.vLimitPercent 50 + $ Brick.withBorderStyle unicode + $ borderWithLabel (Brick.txt "Tutorial") + $ Brick.vBox + (fmap center + [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] + , txt_separator + , mkTextBox [ + Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.installedAttr (Brick.str Common.installedSign) + , Brick.txtWrap " means that the tool is installed but not in used" + ] + , Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.setAttr (Brick.str Common.setSign) + , Brick.txtWrap " means that the tool is installed and in used" + ] + , Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.notInstalledAttr (Brick.str Common.notInstalledSign) + , Brick.txt " means that the tool isn't installed" + ] + ] + , txt_separator + , mkTextBox [ + Brick.hBox [ + Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended" + , Brick.txtWrap " tag is based on community adoption, known bugs, etc... So It makes this version the least experimental" + ] + , Brick.hBox [ + Brick.withAttr Attributes.latestAttr $ Brick.str "latest" + , Brick.txtWrap " tag is for the latest distributed version of the tool" + ] + , Brick.hBox [ + Brick.withAttr Attributes.latestAttr $ Brick.str "hls-powered" + , Brick.txt " denotes the compiler version supported by the currently set (" + , Brick.withAttr Attributes.setAttr (Brick.str Common.setSign) + , Brick.txt ") hls" + ] + , Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" + ] + , Brick.txt " " + ]) + <=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial") diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs new file mode 100644 index 0000000..fcb6554 --- /dev/null +++ b/lib-tui/GHCup/BrickMain.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module contains the entrypoint for the brick application and nothing else. + +-} + +module GHCup.BrickMain where + +import GHCup.Types + ( Settings(noColor), + AppState(ghcupInfo, settings, keyBindings, loggerConfig) ) +import GHCup.Prelude.Logger ( logError ) +import qualified GHCup.Brick.Actions as Actions +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.App as BrickApp +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.BrickState as AppState +import qualified Brick + +import Control.Monad.Reader ( ReaderT(runReaderT) ) +import Data.Functor ( ($>) ) +import Data.IORef (writeIORef) +import Prelude hiding ( appendFile ) +import System.Exit ( ExitCode(ExitFailure), exitWith ) + +import qualified Data.Text as T + + + +brickMain :: AppState + -> IO () +brickMain s = do + writeIORef Actions.settings' s + + eAppData <- Actions.getAppData (Just $ ghcupInfo s) + case eAppData of + Right ad -> + Brick.defaultMain + (BrickApp.app (Attributes.defaultAttributes (noColor $ settings s)) + (Attributes.dimAttributes (noColor $ settings s))) + (AppState.BrickState ad + Common.defaultAppSettings + (Actions.constructList ad Common.defaultAppSettings Nothing) + (keyBindings (s :: AppState)) + Common.Navigation + + ) + $> () + Left e -> do + flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) + exitWith $ ExitFailure 2