diff --git a/ghcup.cabal b/ghcup.cabal index 0562f2c89..b5687761f 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -371,18 +371,24 @@ 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.BaseWidget + GHCup.Brick.Widgets.BasicOverlay GHCup.Brick.Widgets.SectionList - GHCup.Brick.Widgets.Menu - GHCup.Brick.Widgets.Menus.Context - GHCup.Brick.Widgets.Menus.AdvanceInstall - GHCup.Brick.Widgets.Menus.CompileGHC - GHCup.Brick.Widgets.Menus.CompileHLS + GHCup.Brick.Widgets.GenericMenu + GHCup.Brick.Widgets.InputField.Class + GHCup.Brick.Widgets.InputField.CheckBox + GHCup.Brick.Widgets.InputField.EditInput + GHCup.Brick.Widgets.InputField.SelectInput GHCup.Brick.Actions - GHCup.Brick.App - GHCup.Brick.BrickState + GHCup.Brick.App.Common + GHCup.Brick.App.AdvanceInstallOptions + GHCup.Brick.App.AdvanceInstallMenu + GHCup.Brick.App.CompileGHCMenu + GHCup.Brick.App.CompileHLSMenu + GHCup.Brick.App.ContextMenu + GHCup.Brick.App.Navigation + GHCup.Brick.App.KeyInfo + GHCup.Brick.App.Tutorial GHCup.Brick.Attributes GHCup.Brick.Common @@ -400,6 +406,7 @@ library ghcup-tui build-depends: , ghcup + , some , brick >=2.1 && <2.8 , vty ^>=6.0 || ^>=6.1 || ^>=6.2 diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index a53af1a4f..4de75f41b 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -3,10 +3,6 @@ {-# 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 @@ -22,15 +18,9 @@ import GHCup.Prelude ( decUTF8Safe, runBothE' ) 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 qualified GHCup.Brick.App.Common as Common +import qualified GHCup.Brick.App.AdvanceInstallOptions as AdvanceInstall import GHCup.Brick.Widgets.SectionList -import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu -import GHCup.Brick.Widgets.Navigation (BrickInternalState) -import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall -import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC -import GHCup.Brick.Widgets.Menu (MenuKeyBindings(..)) import qualified Brick import qualified Brick.Widgets.List as L @@ -49,7 +39,6 @@ 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 Data.Variant.Excepts import Prelude hiding ( appendFile ) @@ -78,12 +67,12 @@ import Optics.Operators ((.~),(%~)) import Optics.Getter (view) import Optics.Optic ((%)) import Optics ((^.), to) -import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS import Control.Concurrent (threadDelay) import qualified GHCup.GHC as GHC import qualified GHCup.Utils.Parsers as Utils import qualified GHCup.HLS as HLS +type NavigationList = SectionList Common.Name ListResult {- Core Logic. @@ -96,37 +85,18 @@ This module defines the IO actions we can execute within the Brick App: -} --- | Update app data and list internal state based on new evidence. --- This synchronises @BrickInternalState@ with @BrickData@ --- and @BrickSettings@. -updateList :: BrickData -> BrickState -> BrickState -updateList appD bst = - let newInternalState = constructList appD (bst ^. appSettings) (Just (bst ^. appState)) - in bst - & appState .~ newInternalState - & appData .~ appD - & 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 -> (ListResult -> Bool) -> NavigationList -> NavigationList selectBy tool predicate internal_state = - let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state) - tool_lens = sectionL (Singular tool) + let new_focus = F.focusSetCurrent (Common.Singular tool) (view sectionListFocusRingL internal_state) + tool_lens = sectionL (Common.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 :: NavigationList -> NavigationList selectLatest = selectBy GHC (elem Latest . lTag) @@ -135,12 +105,12 @@ selectLatest = selectBy GHC (elem Latest . lTag) -- When passed an existing @appState@, tries to keep the selected element. replaceLR :: (ListResult -> Bool) -> [ListResult] - -> Maybe BrickInternalState - -> BrickInternalState + -> Maybe NavigationList + -> NavigationList 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 + newVec = [(Common.Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] + newSectionList = sectionList Common.AllTools newVec 1 in case oldElem of Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList Nothing -> selectLatest newSectionList @@ -160,41 +130,32 @@ filterVisible v e | lInstalled e = True (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 +-- IO action returns a Left value, then it is printed. +suspendBrickAndRunAction :: (Ord n) + => AppState + -> ReaderT AppState IO (Either String a) + -> Brick.EventM n s () +suspendBrickAndRunAction s action = do + Brick.suspendAndResume' $ do + flip runReaderT s $ action >>= \case + Left err -> liftIO $ putStrLn ("Error: " <> err) + Right _ -> liftIO $ putStrLn "Success" + installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => AdvanceInstall.InstallOptions - -> (Int, ListResult) + -> ListResult -> m (Either String ()) -installWithOptions opts (_, ListResult {..}) = do +installWithOptions opts ListResult {..} = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask let - misolated = opts ^. AdvanceInstall.isolateDirL - shouldIsolate = maybe GHCupInternal IsolateDir (opts ^. AdvanceInstall.isolateDirL) - shouldForce = opts ^. AdvanceInstall.forceInstallL - shouldSet = opts ^. AdvanceInstall.instSetL - extraArgs = opts ^. AdvanceInstall.addConfArgsL - installTargets = opts ^. AdvanceInstall.installTargetsL - v = fromMaybe (GHCTargetVersion lCross lVer) (opts ^. AdvanceInstall.instVersionL) + misolated = opts ^. AdvanceInstall.isolateDir + shouldIsolate = maybe GHCupInternal IsolateDir (opts ^. AdvanceInstall.isolateDir) + shouldForce = opts ^. AdvanceInstall.forceInstall + shouldSet = opts ^. AdvanceInstall.instSet + extraArgs = opts ^. AdvanceInstall.addConfArgs + installTargets = opts ^. AdvanceInstall.installTargets + v = fromMaybe (GHCTargetVersion lCross lVer) (opts ^. AdvanceInstall.instVersion) toolV = _tvVersion v let run = runResourceT @@ -244,7 +205,7 @@ installWithOptions opts (_, ListResult {..}) = do lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- give the user a sec to intervene - case opts ^. AdvanceInstall.instBindistL of + case opts ^. AdvanceInstall.instBindist of Nothing -> do liftE $ runBothE' @@ -272,7 +233,7 @@ installWithOptions opts (_, ListResult {..}) = do lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- give the user a sec to intervene - case opts ^. AdvanceInstall.instBindistL of + case opts ^. AdvanceInstall.instBindist of Nothing -> do liftE $ runBothE' @@ -301,7 +262,7 @@ installWithOptions opts (_, ListResult {..}) = do lift $ logWarn "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- give the user a sec to intervene - case opts ^. AdvanceInstall.instBindistL of + case opts ^. AdvanceInstall.instBindist of Nothing -> do liftE $ runBothE' @@ -321,7 +282,7 @@ installWithOptions opts (_, ListResult {..}) = do Stack -> do let vi = getVersionInfo v Stack dls - case opts ^. AdvanceInstall.instBindistL of + case opts ^. AdvanceInstall.instBindist of Nothing -> do liftE $ runBothE' @@ -363,13 +324,13 @@ installWithOptions opts (_, ListResult {..}) = do install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => (Int, ListResult) -> m (Either String ()) -install' = installWithOptions (AdvanceInstall.InstallOptions Nothing False Nothing Nothing False [] "install") +install' (_, lr) = installWithOptions (AdvanceInstall.InstallOptions Nothing False Nothing Nothing False [] "install") lr 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' + settings <- ask let run = flip runReaderT settings @@ -505,284 +466,32 @@ changelog' (_, ListResult {..}) = do Right _ -> pure $ Right () Left e -> pure $ Left $ prettyHFError e -compileGHC :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => CompileGHC.CompileGHCOptions -> (Int, ListResult) -> m (Either String ()) -compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do - appstate <- ask - let run = - runResourceT - . runE @'[ AlreadyInstalled - , BuildFailed - , DigestError - , ContentLengthError - , GPGError - , DownloadFailed - , GHCupSetError - , NoDownload - , NotFoundInPATH - , PatchFailed - , UnknownArchive - , TarDirDoesNotExist - , NotInstalled - , DirNotEmpty - , ArchiveResult - , FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , ProcessError - , CopyError - , BuildFailed - , UninstallFailed - , MergeFileTreeError - , URIParseError - ] - compileResult <- run (do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - ghcVer <- case compopts ^. CompileGHC.gitRef of - Just ref -> pure (GHC.GitDist (GitBranch ref Nothing)) - Nothing -> do - -- Compile the version user is pointing to in the tui - let vi = getVersionInfo (mkTVer lVer) GHC dls - forM_ (_viPreInstall =<< vi) $ \msg -> do - lift $ logWarn msg - lift $ logWarn - "...waiting for 5 seconds, you can still abort..." - liftIO $ threadDelay 5000000 -- give the user a sec to intervene - forM_ (_viPreCompile =<< vi) $ \msg -> do - logInfo msg - logInfo - "...waiting for 5 seconds, you can still abort..." - liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene - pure (GHC.SourceDist lVer) - - targetVer <- liftE $ GHCup.compileGHC - ghcVer - (compopts ^. CompileGHC.crossTarget) - (compopts ^. CompileGHC.overwriteVer) - (compopts ^. CompileGHC.bootstrapGhc) - (compopts ^. CompileGHC.hadrianGhc) - (compopts ^. CompileGHC.jobs) - (compopts ^. CompileGHC.buildConfig) - (compopts ^. CompileGHC.patches) - (compopts ^. CompileGHC.addConfArgs) - (compopts ^. CompileGHC.buildFlavour) - (compopts ^. CompileGHC.buildSystem) - (maybe GHCupInternal IsolateDir $ compopts ^. CompileGHC.isolateDir) - (compopts ^. CompileGHC.installTargets) - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask - let vi2 = getVersionInfo targetVer GHC dls2 - when - (compopts ^. CompileGHC.setCompile) - (liftE . void $ GHCup.setGHC targetVer SetGHCOnly Nothing) - pure (vi2, targetVer) - ) - case compileResult of - VRight (vi, tv) -> do - logInfo "GHC successfully compiled and installed" - forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg - liftIO $ putStr (T.unpack $ tVerToText tv) - pure $ Right () - VLeft (V (AlreadyInstalled _ v)) -> do - pure $ Left $ - "GHC ver " <> T.unpack (prettyVer v) <> " already installed, remove it first to reinstall" - VLeft (V (DirNotEmpty fp)) -> do - pure $ Left $ - "Install directory " <> fp <> " is not empty." - VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $ - case keepDirs (appstate & settings) of - Never -> prettyHFError err - _ -> prettyHFError err <> "\n" - <> "Check the logs at " <> (fromGHCupPath $ appstate & dirs & logsDir) - <> " and the build directory " - <> tmpdir <> " for more clues." <> "\n" - <> "Make sure to clean up " <> tmpdir <> " afterwards." - VLeft e -> do - pure $ Left $ prettyHFError e --- This is the case when the tool is not GHC... which should be impossible but, --- it exhaustes pattern matches -compileGHC _ (_, ListResult{lTool = _}) = pure (Right ()) - - -compileHLS :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => CompileHLS.CompileHLSOptions -> (Int, ListResult) -> m (Either String ()) -compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do - appstate <- ask - let run = - runResourceT - . runE @'[ AlreadyInstalled - , BuildFailed - , DigestError - , ContentLengthError - , GPGError - , DownloadFailed - , GHCupSetError - , NoDownload - , NotFoundInPATH - , PatchFailed - , UnknownArchive - , TarDirDoesNotExist - , TagNotFound - , DayNotFound - , NextVerNotFound - , NoToolVersionSet - , NotInstalled - , DirNotEmpty - , ArchiveResult - , UninstallFailed - , MergeFileTreeError - , URIParseError - ] - compileResult <- run (do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - hlsVer <- case compopts ^. CompileHLS.gitRef of - Just ref -> pure (HLS.GitDist (GitBranch ref Nothing)) - Nothing -> do - -- Compile the version user is pointing to in the tui - let vi = getVersionInfo (mkTVer lVer) HLS dls - forM_ (_viPreInstall =<< vi) $ \msg -> do - lift $ logWarn msg - lift $ logWarn - "...waiting for 5 seconds, you can still abort..." - liftIO $ threadDelay 5000000 -- give the user a sec to intervene - forM_ (_viPreCompile =<< vi) $ \msg -> do - logInfo msg - logInfo - "...waiting for 5 seconds, you can still abort..." - liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene - pure (HLS.SourceDist lVer) - - ghcs <- - liftE $ forM (compopts ^. CompileHLS.targetGHCs) - (\ghc -> fmap (_tvVersion . fst) . Utils.fromVersion (Just ghc) GStrict $ GHC) - targetVer <- liftE $ GHCup.compileHLS - hlsVer - ghcs - (compopts ^. CompileHLS.jobs) - (compopts ^. CompileHLS.overwriteVer) - (maybe GHCupInternal IsolateDir $ compopts ^. CompileHLS.isolateDir) - (compopts ^. CompileHLS.cabalProject) - (compopts ^. CompileHLS.cabalProjectLocal) - (compopts ^. CompileHLS.updateCabal) - (compopts ^. CompileHLS.patches) - (compopts ^. CompileHLS.cabalArgs) - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask - let vi2 = getVersionInfo (mkTVer targetVer) GHC dls2 - when - (compopts ^. CompileHLS.setCompile) - (liftE . void $ GHCup.setHLS targetVer SetHLSOnly Nothing) - pure (vi2, targetVer) - ) - case compileResult of - VRight (vi, tv) -> do - logInfo "HLS successfully compiled and installed" - forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg - liftIO $ putStr (T.unpack $ prettyVer tv) - pure $ Right () - VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $ - case keepDirs (appstate & settings) of - Never -> prettyHFError err - _ -> prettyHFError err <> "\n" - <> "Check the logs at " <> (fromGHCupPath $ appstate & dirs & logsDir) - <> " and the build directory " - <> tmpdir <> " for more clues." <> "\n" - <> "Make sure to clean up " <> tmpdir <> " afterwards." - VLeft e -> do - pure $ Left $ prettyHFError e --- This is the case when the tool is not HLS... which should be impossible but, --- it exhaustes pattern matches -compileHLS _ (_, ListResult{lTool = _}) = pure (Right ()) - - -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 +getUpdatedAppState :: AppState -> IO (Either String (AppState, [ListResult])) +getUpdatedAppState s = runExceptT $ do + r <- ExceptT $ getGHCupInfo s + let newS = s { ghcupInfo = r } + ls <- liftIO $ getListResults newS + pure (newS, ls) + + where + getGHCupInfo :: AppState -> IO (Either String GHCupInfo) + getGHCupInfo settings = do + 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) + + +getListResults :: AppState -> IO [ListResult] +getListResults s = + flip runReaderT s $ do lV <- listVersions Nothing [] False True (Nothing, Nothing) - pure $ BrickData (reverse lV) + pure $ 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) - , (KeyCombination Vty.KEnter [], const "advance options", createMenuforTool ) - ] - where - createMenuforTool = do - e <- use (appState % to sectionListSelectedElement) - case e of - Nothing -> pure () - Just (_, r) -> do - -- Create new ContextMenu, but maintain the state of Install/Compile - -- menus. This is especially useful in case the user made a typo and - -- would like to retry the action. - contextMenu .= ContextMenu.create r - (MenuKeyBindings { mKbUp = bUp, mKbDown = bDown, mKbQuit = bQuit}) - -- Set mode to context - mode .= ContextPanel - pure () - - --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) diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs deleted file mode 100644 index 1f5ee1f25..000000000 --- a/lib-tui/GHCup/Brick/App.hs +++ /dev/null @@ -1,195 +0,0 @@ -{-# 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 qualified GHCup.Brick.Actions as Actions -import qualified GHCup.Brick.Attributes as Attributes -import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu, compileHLSMenu) -import GHCup.Brick.Common (Mode (..), Name (..)) -import qualified GHCup.Brick.Common as Common -import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo -import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu -import qualified GHCup.Brick.Widgets.Navigation as Navigation -import qualified GHCup.Brick.Widgets.Tutorial as Tutorial -import qualified GHCup.Brick.Widgets.Menu as Menu -import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall - -import GHCup.List (ListResult) -import GHCup.Types (AppState (AppState, keyBindings), KeyCombination (KeyCombination), KeyBindings (..)) - -import qualified Brick.Focus as F -import Brick ( - App (..), - AttrMap, - BrickEvent (VtyEvent), - EventM, - Widget (..), - (<=>), - ) -import qualified Brick -import Control.Monad.Reader ( - MonadIO (liftIO), ReaderT, - ) -import Data.IORef (readIORef) -import Data.List (find, intercalate) -import Prelude hiding (appendFile) - -import qualified Graphics.Vty as Vty - -import qualified Data.Text as T - -import Optics (Lens') -import Optics.Getter (to) -import Optics.Operators ((^.)) -import Optics.Optic ((%)) -import Optics.State (use) -import Optics.State.Operators ((.=)) -import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC -import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS -import Control.Monad (void, when) - -app :: AttrMap -> AttrMap -> App BrickState () Name -app attrs dimAttrs = - App { appDraw = drawUI dimAttrs - , appHandleEvent = eventHandler - , appStartEvent = setupVtyMode - , appAttrMap = const attrs - , appChooseCursor = Brick.showFirstCursor - } - --- | Enable mouse mode if supported by the terminal -setupVtyMode :: EventM Name BrickState () -setupVtyMode = do - vty <- Brick.getVtyHandle - let output = Vty.outputIface vty - when (Vty.supportsMode output Vty.Mouse) $ - liftIO $ Vty.setMode output Vty.Mouse True - -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 (bQuit $ st ^. appKeys), navg] - KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] - ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg] - AdvanceInstallPanel -> AdvanceInstall.draw (st ^. advanceInstallMenu) ++ [navg] - CompileGHCPanel -> CompileGHC.draw (st ^. compileGHCMenu) ++ [navg] - CompileHLSPanel -> CompileHLS.draw (st ^. compileHLSMenu) ++ [navg] - --- | On q, go back to navigation. --- On Enter, to go to tutorial -keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState () -keyInfoHandler ev = do - AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings' - case ev of - VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial - VtyEvent (Vty.EvKey key mods) - | bQuit kb == KeyCombination key mods -> mode .= Navigation - _ -> pure () - --- | On q, go back to navigation. Else, do nothing -tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () -tutorialHandler ev = do - AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings' - case ev of - VtyEvent (Vty.EvKey key mods) - | bQuit kb == KeyCombination key mods -> 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 mods)) -> - case find (\(key', _, _) -> key' == KeyCombination key mods) (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 - -contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState () -contextMenuHandler ev = do - ctx <- use contextMenu - let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent - (KeyCombination exitKey mods) = ctx ^. Menu.menuKeyBindingsL % Menu.mKbQuitL - case (ev, focusedElement) of - (_ , Nothing) -> pure () - (VtyEvent (Vty.EvKey k m), Just n) | k == exitKey && m == mods -> mode .= Navigation - (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel - (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompileGHCButton) ) -> mode .= Common.CompileGHCPanel - (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompileHLSButton) ) -> mode .= Common.CompileHLSPanel - _ -> Common.zoom contextMenu $ ContextMenu.handler ev --- -advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState () -advanceInstallHandler = menuWithOverlayHandler advanceInstallMenu Actions.installWithOptions AdvanceInstall.handler - -compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState () -compileGHCHandler = menuWithOverlayHandler compileGHCMenu Actions.compileGHC CompileGHC.handler - -compileHLSHandler :: BrickEvent Name e -> EventM Name BrickState () -compileHLSHandler = menuWithOverlayHandler compileHLSMenu Actions.compileHLS CompileHLS.handler - --- | Passes all events to innerHandler if an overlay is opened --- else handles the exitKey and Enter key for the Menu's "OkButton" -menuWithOverlayHandler :: Lens' BrickState (Menu.Menu t Name) - -> (t -> ((Int, ListResult) -> ReaderT AppState IO (Either String a))) - -> (BrickEvent Name e -> EventM Name (Menu.Menu t Name) ()) - -> BrickEvent Name e - -> EventM Name BrickState () -menuWithOverlayHandler accessor action innerHandler ev = do - ctx <- use accessor - let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent - focusedField = (\n -> find (\x -> Brick.getName x == n) $ ctx ^. Menu.menuFieldsL) =<< focusedElement - (KeyCombination exitKey mods) = ctx ^. Menu.menuKeyBindingsL % Menu.mKbQuitL - case (ev, focusedElement, Menu.drawFieldOverlay =<< focusedField) of - (_ , Nothing, _) -> pure () - (_ , _, Just _) -> Common.zoom accessor $ innerHandler ev - (VtyEvent (Vty.EvKey k m), Just n, _) | k == exitKey && m == mods -> mode .= ContextPanel - (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton), _) -> do - let iopts = ctx ^. Menu.menuStateL - when (Menu.isValidMenu ctx) - (Actions.withIOAction $ action iopts) - _ -> Common.zoom accessor $ innerHandler ev - -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 - ContextPanel -> contextMenuHandler ev - AdvanceInstallPanel -> advanceInstallHandler ev - CompileGHCPanel -> compileGHCHandler ev - CompileHLSPanel -> compileHLSHandler ev diff --git a/lib-tui/GHCup/Brick/App/AdvanceInstallMenu.hs b/lib-tui/GHCup/Brick/App/AdvanceInstallMenu.hs new file mode 100644 index 000000000..9a8af81b0 --- /dev/null +++ b/lib-tui/GHCup/Brick/App/AdvanceInstallMenu.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} + +module GHCup.Brick.App.AdvanceInstallMenu where + +import GHCup.List ( ListResult (..)) +import GHCup.Types (GHCTargetVersion(..), KeyBindings, AppState) +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.BasicOverlay +import GHCup.Brick.Widgets.InputField.Class +import GHCup.Brick.Widgets.InputField.CheckBox +import GHCup.Brick.Widgets.InputField.EditInput as EditInput +import GHCup.Brick.Widgets.GenericMenu +import qualified GHCup.Brick.Actions as Actions +import qualified GHCup.Brick.App.Common as Common +import GHCup.Brick.App.AdvanceInstallOptions +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Utils.Parsers as Utils + +import Brick + ( BrickEvent(..), + Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Center ( center ) +import Control.Monad (when, forM, forM_, void) +import Data.Bifunctor (Bifunctor(..)) +import Data.Char (isSpace) +import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Some +import qualified Data.Text as T +import GHC.Generics (Generic) +import Prelude hiding ( appendFile ) +import qualified Graphics.Vty as Vty +import Optics.State.Operators ((.=), (?=)) +import Optics.TH (makeLenses) +import URI.ByteString (URI) + +data AdvanceInstallMenuFields n = AdvanceInstallMenuFields + { _instBindistF :: EditInput n (Maybe URI) + , _instSetF :: CheckBoxInput n Bool + , _instVersionF :: EditInput n (Maybe GHCTargetVersion) + , _isolateDirF :: EditInput n (Maybe FilePath) + , _forceInstallF :: CheckBoxInput n Bool + , _addConfArgsF :: EditInput n [T.Text] + , _installTargetsF :: EditInput n T.Text + } deriving Generic + +makeLenses ''AdvanceInstallMenuFields + +type AdvanceInstallMenu = GenericMenu Common.Name AdvanceInstallMenuFields (AppState, ListResult) InstallOptions + +create :: KeyBindings -> ListResult -> AppState -> AdvanceInstallMenu +create kb lr s = mkGenericMenu + Common.AdvanceInstallBox + menuFields + validateInputs + (s, lr) + (\(s, lr) opts -> (Just CloseAllOverlays) <$ (Actions.suspendBrickAndRunAction s $ Actions.installWithOptions opts lr)) + (Common.toMenuKeyBindings kb) + "Advance Install" + (Button (Common.MenuElement Common.OkButton) + "Advance Install" + "Install with options below") + where + menuFields = AdvanceInstallMenuFields + { _instBindistF = instBindistField + , _instSetF = instSetField + , _instVersionF = instVersionField + , _isolateDirF = isolateDirField + , _forceInstallF = forceInstallField + , _addConfArgsF = addConfArgsField + , _installTargetsF = installTargetsField + } + + validateInputs :: AdvanceInstallMenuFields Common.Name -> Either ErrorMessage InstallOptions + validateInputs AdvanceInstallMenuFields {..} = do + let + instSetVal = _checked _instSetF + isolateDirVal = editInputValue _isolateDirF + case (instSetVal, isolateDirVal) of + (True, Right (Just _)) -> Left "Cannot set active when doing an isolated install" + _ -> InstallOptions + <$> editInputValue _instBindistF + <*> (Right $ _checked _instSetF) + <*> editInputValue _instVersionF + <*> editInputValue _isolateDirF + <*> (Right $ _checked _forceInstallF) + <*> editInputValue _addConfArgsF + <*> editInputValue _installTargetsF + + instBindistField = EditInput.create + (Common.MenuElement Common.UrlEditBox) + "url" + "Install the specified version from this bindist" + uriValidator + "" + + instSetField = CheckBoxInput + (Common.MenuElement Common.SetCheckBox) + "set" + "Set as active version after install" + False + + instVersionField = EditInput.create + (Common.MenuElement Common.ToolVersionBox) + "version" + "Specify a custom version" + toolVersionValidator + "" + + isolateDirField = EditInput.create + (Common.MenuElement Common.IsolateEditBox) + "isolated" + "install in an isolated absolute directory instead of the default one" + filepathValidator + "" + + forceInstallField = CheckBoxInput + (Common.MenuElement Common.ForceCheckBox) + "force" + "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)" + False + + addConfArgsField = EditInput.create + (Common.MenuElement Common.AdditionalEditBox) + "CONFIGURE_ARGS" + "Additional arguments to bindist configure" + additionalValidator + "" + + installTargetsField = EditInput.create + (Common.MenuElement Common.GHCInstallTargets) + "install-targets" + "Specify space separated list of make install targets" + Right + initialInstallTargets + + initialInstallTargets = "install" + + -- Brick's internal editor representation is [mempty]. + emptyEditor i = T.null i || (i == "\n") + + whenEmpty :: a -> (T.Text -> Either ErrorMessage a) -> T.Text -> Either ErrorMessage a + whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval + + uriValidator :: T.Text -> Either ErrorMessage (Maybe URI) + uriValidator = whenEmpty Nothing (second Just . readUri) + where readUri = first T.pack . Utils.uriParser . T.unpack + + filepathValidator :: T.Text -> Either ErrorMessage (Maybe FilePath) + filepathValidator = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . T.unpack) + + toolVersionValidator :: T.Text -> Either ErrorMessage (Maybe GHCTargetVersion) + toolVersionValidator = whenEmpty Nothing (bimap T.pack Just . Utils.ghcVersionEither . T.unpack) + + additionalValidator :: T.Text -> Either ErrorMessage [T.Text] + additionalValidator = Right . T.split isSpace diff --git a/lib-tui/GHCup/Brick/App/AdvanceInstallOptions.hs b/lib-tui/GHCup/Brick/App/AdvanceInstallOptions.hs new file mode 100644 index 000000000..0a54e4a02 --- /dev/null +++ b/lib-tui/GHCup/Brick/App/AdvanceInstallOptions.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Brick.App.AdvanceInstallOptions where + +import GHCup.Types (GHCTargetVersion) +import qualified Data.Text as T +import Optics.TH (makeLenses) +import URI.ByteString (URI) + +data InstallOptions = InstallOptions + { _instBindist :: Maybe URI + , _instSet :: Bool + , _instVersion :: Maybe GHCTargetVersion + -- ^ User specified version to override default + , _isolateDir :: Maybe FilePath + , _forceInstall :: Bool + , _addConfArgs :: [T.Text] + , _installTargets :: T.Text + } deriving (Eq, Show) + +makeLenses ''InstallOptions diff --git a/lib-tui/GHCup/Brick/App/Common.hs b/lib-tui/GHCup/Brick/App/Common.hs new file mode 100644 index 000000000..04dc0a19d --- /dev/null +++ b/lib-tui/GHCup/Brick/App/Common.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Brick.App.Common where + +import GHCup.Brick.Common +import qualified GHCup.Brick.Widgets.SectionList as SectionList +import GHCup.List ( ListResult ) +import GHCup.Types ( Tool, KeyCombination (KeyCombination) ) + +import Optics.TH (makeLenses) + +{- +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 + +-} + +-- We could use regular ADTs but different menus share the same options. +-- example: all of ghcup compile ghc, ghcup compile hls, ghcup install cabal, etc... +-- all have a --set, --force, etc... common arguments. If we went for the ADT we'd end up +-- with SetCompileHLSOption, SetCompileGHCOption, SetInstallCabalOption, etc... +-- which isn't terrible, but verbose enough to reject it. + +-- | A newtype for labeling resources in menus. It is bundled along with pattern synonyms +newtype ResourceId = ResourceId Int deriving (Eq, Ord, Show) + +pattern OkButton :: ResourceId +pattern OkButton = ResourceId 0 +pattern AdvanceInstallButton :: ResourceId +pattern AdvanceInstallButton = ResourceId 100 +pattern CompileGHCButton :: ResourceId +pattern CompileGHCButton = ResourceId 101 +pattern CompileHLSButton :: ResourceId +pattern CompileHLSButton = ResourceId 102 + +pattern UrlEditBox :: ResourceId +pattern UrlEditBox = ResourceId 1 +pattern SetCheckBox :: ResourceId +pattern SetCheckBox = ResourceId 2 +pattern IsolateEditBox :: ResourceId +pattern IsolateEditBox = ResourceId 3 +pattern ForceCheckBox :: ResourceId +pattern ForceCheckBox = ResourceId 4 +pattern AdditionalEditBox :: ResourceId +pattern AdditionalEditBox = ResourceId 5 + +pattern TargetGhcEditBox :: ResourceId +pattern TargetGhcEditBox = ResourceId 6 +pattern BootstrapGhcEditBox :: ResourceId +pattern BootstrapGhcEditBox = ResourceId 7 +pattern HadrianGhcEditBox :: ResourceId +pattern HadrianGhcEditBox = ResourceId 20 +pattern JobsEditBox :: ResourceId +pattern JobsEditBox = ResourceId 8 +pattern BuildConfigEditBox :: ResourceId +pattern BuildConfigEditBox = ResourceId 9 +pattern PatchesEditBox :: ResourceId +pattern PatchesEditBox = ResourceId 10 +pattern CrossTargetEditBox :: ResourceId +pattern CrossTargetEditBox = ResourceId 11 +pattern AddConfArgsEditBox :: ResourceId +pattern AddConfArgsEditBox = ResourceId 12 +pattern OvewrwiteVerEditBox :: ResourceId +pattern OvewrwiteVerEditBox = ResourceId 13 +pattern BuildFlavourEditBox :: ResourceId +pattern BuildFlavourEditBox = ResourceId 14 +pattern BuildSystemEditBox :: ResourceId +pattern BuildSystemEditBox = ResourceId 15 + +pattern CabalProjectEditBox :: ResourceId +pattern CabalProjectEditBox = ResourceId 16 +pattern CabalProjectLocalEditBox :: ResourceId +pattern CabalProjectLocalEditBox = ResourceId 17 +pattern UpdateCabalCheckBox :: ResourceId +pattern UpdateCabalCheckBox = ResourceId 18 + +pattern GitRefEditBox :: ResourceId +pattern GitRefEditBox = ResourceId 19 + +pattern BootstrapGhcSelectBox :: ResourceId +pattern BootstrapGhcSelectBox = ResourceId 21 +pattern HadrianGhcSelectBox :: ResourceId +pattern HadrianGhcSelectBox = ResourceId 22 + +pattern ToolVersionBox :: ResourceId +pattern ToolVersionBox = ResourceId 23 + +pattern GHCInstallTargets :: ResourceId +pattern GHCInstallTargets = ResourceId 24 + +-- | 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 + | ListItem Tool Int -- ^ An item in list + | KeyInfoBox -- ^ The text box widget with action informacion + | TutorialBox -- ^ The tutorial widget + | ContextBox -- ^ The resource for Context Menu + | CompileGHCBox -- ^ The resource for CompileGHC Menu + | AdvanceInstallBox -- ^ The resource for AdvanceInstall Menu + | MenuElement ResourceId -- ^ Each element in a Menu. Resources must not be share for visible + -- Menus, but MenuA and MenuB can share resources if they both are + -- invisible, or just one of them is visible. + + deriving (Eq, Ord, Show) + +instance SectionList.ListItemSectionNameIndex Name where + getListItemSectionNameIndex = \case + ListItem tool ix -> Just (Singular tool, ix) + _ -> Nothing diff --git a/lib-tui/GHCup/Brick/App/CompileGHCMenu.hs b/lib-tui/GHCup/Brick/App/CompileGHCMenu.hs new file mode 100644 index 000000000..b996dc2a4 --- /dev/null +++ b/lib-tui/GHCup/Brick/App/CompileGHCMenu.hs @@ -0,0 +1,405 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHCup.Brick.App.CompileGHCMenu where + +import qualified GHCup +import GHCup.Errors +import GHCup.List ( ListResult (..)) +import GHCup.Types hiding ( LeanAppState(..) ) +import qualified GHCup.Utils.Parsers as Utils +import GHCup.Utils + +import qualified GHCup.Brick.Actions as Actions +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.BasicOverlay +import GHCup.Brick.Widgets.InputField.Class +import GHCup.Brick.Widgets.InputField.CheckBox +import GHCup.Brick.Widgets.InputField.EditInput as EditInput +import GHCup.Brick.Widgets.InputField.SelectInput as SelectInput +import GHCup.Brick.Widgets.GenericMenu +import qualified GHCup.Brick.App.Common as Common +import qualified GHCup.Brick.Common as Common +import GHCup.Brick.App.Tutorial (Tutorial(..)) +import qualified GHCup.GHC as GHC +import GHCup.Prelude.Logger + + +import Brick + ( BrickEvent(..), + Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Center ( center ) +import Control.Applicative (Alternative((<|>))) +import Control.Concurrent (threadDelay) +import Control.Exception.Safe +import Control.Monad (when, forM, forM_, void) +import Control.Monad.Reader +import Control.Monad.Trans.Except +import Control.Monad.Trans.Resource +import Data.Bifunctor (Bifunctor(..)) +import Data.Char (isSpace) +import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Some +import qualified Data.Text as T +import Data.Variant.Excepts +import Data.Versions (prettyVer, Version) +import GHC.Generics (Generic) +import Prelude hiding ( appendFile ) +import qualified Graphics.Vty as Vty +import Optics (Lens', lens, over, (^.), (%), (&), (.~), (%~)) +import Optics.State.Operators ((.=), (?=)) +import Optics.TH (makeLenses) +import Text.Read (readEither) +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import URI.ByteString (URI) + +data CompileGHCMenuFields n = CompileGHCMenuFields + { _bootstrapGhcF :: SelectInput n Version (Maybe FilePath) + , _hadrianGhcF :: SelectInput n Version (Maybe FilePath) + , _jobsF :: EditInput n (Maybe Int) + , _setCompileF :: CheckBoxInput n Bool + , _flavourF :: EditInput n (Maybe String) + , _addConfArgsF :: EditInput n [T.Text] + , _buildConfigF :: EditInput n (Maybe FilePath) + , _patchesF :: EditInput n (Maybe (Either FilePath [URI])) + , _crossTargetF :: EditInput n (Maybe T.Text) + , _buildSystemF :: SelectInput n (Maybe BuildSystem) () + , _overwriteVerF :: EditInput n (Maybe [VersionPattern]) + , _isolateDirF :: EditInput n (Maybe FilePath) + , _gitRefF :: EditInput n (Maybe String) + , _installTargetsF :: EditInput n (T.Text) + } deriving Generic + +data CompileGHCOptions = CompileGHCOptions + { _bootstrapGhc :: Either Version FilePath + , _hadrianGhc :: Maybe (Either Version FilePath) + , _jobs :: Maybe Int + , _buildConfig :: Maybe FilePath + , _patches :: Maybe (Either FilePath [URI]) + , _crossTarget :: Maybe T.Text + , _addConfArgs :: [T.Text] + , _setCompile :: Bool + , _overwriteVer :: Maybe [VersionPattern] + , _buildFlavour :: Maybe String + , _buildSystem :: Maybe BuildSystem + , _isolateDir :: Maybe FilePath + , _gitRef :: Maybe String + , _installTargets :: T.Text + } deriving (Eq, Show) + +concat <$> mapM makeLenses [''CompileGHCMenuFields, ''CompileGHCOptions] + +type CompileGHCMenu = GenericMenu Common.Name CompileGHCMenuFields (AppState, ListResult) CompileGHCOptions + +create :: KeyBindings -> ListResult -> AppState -> [Version] -> CompileGHCMenu +create kb lr s availableGHCs = mkGenericMenu + Common.CompileGHCBox + menuFields + validateInputs + (s, lr) + (\(s, lr) opts -> (Just CloseAllOverlays) <$ (Actions.suspendBrickAndRunAction s $ compileGHC opts lr)) + (Common.toMenuKeyBindings kb) + "Compile GHC" + (Button (Common.MenuElement Common.OkButton) + "Compile" + "Compile GHC from source with options below\nRequired fields: bootstrap-ghc") + where + menuFields = CompileGHCMenuFields + { _bootstrapGhcF = bootstrapGhcField + , _hadrianGhcF = hadrianGhcField + , _jobsF = jobsField + , _setCompileF = setCompileField + , _flavourF = flavourField + , _addConfArgsF = addConfArgsField + , _buildConfigF = buildConfigField + , _patchesF = patchesField + , _crossTargetF = crossTargetField + , _buildSystemF = buildSystemField + , _overwriteVerF = overwriteVerField + , _isolateDirF = isolateDirField + , _gitRefF = gitRefField + , _installTargetsF = installTargetsField + } + + validateInputs :: CompileGHCMenuFields Common.Name -> Either ErrorMessage CompileGHCOptions + validateInputs CompileGHCMenuFields {..} = do + let + setCompileVal = _checked _setCompileF + isolateDirVal = editInputValue _isolateDirF + bootstrapGhc = case getSelection _bootstrapGhcF of + ([], Just (Right (Just path, _))) -> Right $ Right path + ([], Just (Left msg)) -> Left msg + ((v:_), _) -> Right $ Left v + ([], _) -> Left "bootstrap-ghc: No version selected / no path specified" + + hadrianGhc = case getSelection _hadrianGhcF of + ([], Just (Right (Just path, _))) -> Right $ Just $ Right path + ([], Just (Left msg)) -> Left msg + ((v:_), _) -> Right $ Just $ Left v + ([], _) -> Right $ Nothing + + buildSystem = case getSelection _buildSystemF of + ([], _) -> Right $ Nothing + ((v:_), _) -> Right $ v + case (setCompileVal, isolateDirVal) of + (True, Right (Just _)) -> Left "Cannot set active when doing an isolated install" + _ -> CompileGHCOptions + <$> bootstrapGhc + <*> hadrianGhc + <*> editInputValue _jobsF + <*> editInputValue _buildConfigF + <*> editInputValue _patchesF + <*> editInputValue _crossTargetF + <*> editInputValue _addConfArgsF + <*> (Right $ _checked $ _setCompileF) + <*> editInputValue _overwriteVerF + <*> editInputValue _flavourF + <*> buildSystem + <*> editInputValue _isolateDirF + <*> editInputValue _gitRefF + <*> editInputValue _installTargetsF + + bootstrapGhcField = SelectInput.createSelectInputWithEditable + (Common.MenuElement Common.BootstrapGhcSelectBox) + (Common.MenuElement Common.BootstrapGhcEditBox) + "bootstrap-ghc" + "The GHC version (or full path) to bootstrap with (must be installed)" + availableGHCs + (T.pack . prettyShow) + filepathV + (Common.toMenuKeyBindings kb) + + hadrianGhcField = SelectInput.createSelectInputWithEditable + (Common.MenuElement Common.HadrianGhcSelectBox) + (Common.MenuElement Common.HadrianGhcEditBox) + "hadrian-ghc" + "The GHC version (or full path) that will be used to compile hadrian (must be installed)" + availableGHCs + (T.pack . prettyShow) + filepathV + (Common.toMenuKeyBindings kb) + + jobsField = EditInput.create + (Common.MenuElement Common.JobsEditBox) + "jobs" + "How many jobs to use for make" + jobsV + "" + + setCompileField = CheckBoxInput + (Common.MenuElement Common.SetCheckBox) + "set" + "Set as active version after install" + False + + flavourField = EditInput.create + (Common.MenuElement Common.BuildFlavourEditBox) + "flavour" + "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')" + (whenEmpty Nothing (Right . Just . T.unpack)) + "" + + addConfArgsField = EditInput.create + (Common.MenuElement Common.AdditionalEditBox) + "CONFIGURE_ARGS" + "Additional arguments to compile configure" + (Right . T.split isSpace) + "" + + buildConfigField = EditInput.create + (Common.MenuElement Common.BuildConfigEditBox) + "build config" + "Absolute path to build config file (make build system only)" + filepathV + "" + + patchesField = EditInput.create + (Common.MenuElement Common.PatchesEditBox) + "patches" + "Either a URI to a patch (https/http/file) or Absolute path to patch directory" + patchesV + "" + + crossTargetField = EditInput.create + (Common.MenuElement Common.CrossTargetEditBox) + "cross target" + "Build cross-compiler for this platform" + (Right . Just) + "" + + buildSystemField = SelectInput.createSelectInput + (Common.MenuElement Common.BuildSystemEditBox) + "build system" + "Select the build system" + (Nothing :| [Just Hadrian, Just Make]) + (\case + Nothing -> "Auto select (prefer hadrian if available, and build config is not specified)" + Just Hadrian -> "hadrian" + Just Make -> "make") + (Common.toMenuKeyBindings kb) + + overwriteVerField = EditInput.create + (Common.MenuElement Common.OvewrwiteVerEditBox) + "overwrite-version" + "Allows to overwrite the finally installed VERSION with a different one. Allows to specify patterns: %v (version), %b (branch name), %h (short commit hash), %H (long commit hash), %g ('git describe' output)" + versionV + "" + + isolateDirField = EditInput.create + (Common.MenuElement Common.IsolateEditBox) + "isolated" + "install in an isolated absolute directory instead of the default one" + filepathV + "" + + gitRefField = EditInput.create + (Common.MenuElement Common.GitRefEditBox) + "git-ref" + "The git commit/branch/ref to build from" + (whenEmpty Nothing (Right . Just . T.unpack)) + "" + + installTargetsField = EditInput.create + (Common.MenuElement Common.GHCInstallTargets) + "install-targets" + "Specify space separated list of make install targets" + Right + initialInstallTargets + + initialInstallTargets = "install" + + -- Brick's internal editor representation is [mempty]. + emptyEditor i = T.null i || (i == "\n") + whenEmpty :: a -> (T.Text -> Either ErrorMessage a) -> T.Text -> Either ErrorMessage a + whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval + + filepathV :: T.Text -> Either ErrorMessage (Maybe FilePath) + filepathV = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . T.unpack) + + jobsV :: T.Text -> Either ErrorMessage (Maybe Int) + jobsV = + let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack + in whenEmpty Nothing parseInt + + patchesV :: T.Text -> Either ErrorMessage (Maybe (Either FilePath [URI])) + patchesV = whenEmpty Nothing readPatches + where + readPatches j = + let + x = second (Just . Left) $ Utils.absolutePathParser (T.unpack j) + y = second (Just . Right) $ traverse (Utils.uriParser . T.unpack) (T.split isSpace j) + in first T.pack $ x <|> y + + versionV :: T.Text -> Either ErrorMessage (Maybe [VersionPattern]) + versionV = whenEmpty Nothing (bimap T.pack Just . Utils.overWriteVersionParser . T.unpack) + +updateAvailableGHCs :: [Version] -> CompileGHCMenu -> CompileGHCMenu +updateAvailableGHCs availableGHCs v = v + & fields % bootstrapGhcF %~ SelectInput.updateItems availableGHCs + & fields % hadrianGhcF %~ SelectInput.updateItems availableGHCs + +compileGHC :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => CompileGHCOptions -> ListResult -> m (Either String ()) +compileGHC compopts lr@ListResult{lTool = GHC, ..} = do + appstate <- ask + let run = + runResourceT + . runE @'[ AlreadyInstalled + , BuildFailed + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , NotInstalled + , DirNotEmpty + , ArchiveResult + , FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , ProcessError + , CopyError + , BuildFailed + , UninstallFailed + , MergeFileTreeError + , URIParseError + ] + compileResult <- run (do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + ghcVer <- case compopts ^. gitRef of + Just ref -> pure (GHC.GitDist (GitBranch ref Nothing)) + Nothing -> do + -- Compile the version user is pointing to in the tui + let vi = getVersionInfo (mkTVer lVer) GHC dls + forM_ (_viPreInstall =<< vi) $ \msg -> do + lift $ logWarn msg + lift $ logWarn + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- give the user a sec to intervene + forM_ (_viPreCompile =<< vi) $ \msg -> do + logInfo msg + logInfo + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene + pure (GHC.SourceDist lVer) + + targetVer <- liftE $ GHCup.compileGHC + ghcVer + (compopts ^. crossTarget) + (compopts ^. overwriteVer) + (compopts ^. bootstrapGhc) + (compopts ^. hadrianGhc) + (compopts ^. jobs) + (compopts ^. buildConfig) + (compopts ^. patches) + (compopts ^. addConfArgs) + (compopts ^. buildFlavour) + (compopts ^. buildSystem) + (maybe GHCupInternal IsolateDir $ compopts ^. isolateDir) + (compopts ^. installTargets) + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask + let vi2 = getVersionInfo targetVer GHC dls2 + when + (compopts ^. setCompile) + (liftE . void $ GHCup.setGHC targetVer SetGHCOnly Nothing) + pure (vi2, targetVer) + ) + case compileResult of + VRight (vi, tv) -> do + logInfo "GHC successfully compiled and installed" + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + liftIO $ putStr (T.unpack $ tVerToText tv) + pure $ Right () + VLeft (V (AlreadyInstalled _ v)) -> do + pure $ Left $ + "GHC ver " <> T.unpack (prettyVer v) <> " already installed, remove it first to reinstall" + VLeft (V (DirNotEmpty fp)) -> do + pure $ Left $ + "Install directory " <> fp <> " is not empty." + VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $ + case keepDirs (appstate & settings) of + Never -> prettyHFError err + _ -> prettyHFError err <> "\n" + <> "Check the logs at " <> (fromGHCupPath $ appstate & dirs & logsDir) + <> " and the build directory " + <> tmpdir <> " for more clues." <> "\n" + <> "Make sure to clean up " <> tmpdir <> " afterwards." + VLeft e -> do + pure $ Left $ prettyHFError e +-- This is the case when the tool is not GHC... which should be impossible but, +-- it exhaustes pattern matches +compileGHC _ ListResult{lTool = _} = pure (Right ()) diff --git a/lib-tui/GHCup/Brick/App/CompileHLSMenu.hs b/lib-tui/GHCup/Brick/App/CompileHLSMenu.hs new file mode 100644 index 000000000..d37ea1e7f --- /dev/null +++ b/lib-tui/GHCup/Brick/App/CompileHLSMenu.hs @@ -0,0 +1,362 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} + +module GHCup.Brick.App.CompileHLSMenu where + +import qualified GHCup +import GHCup.Errors +import GHCup.List ( ListResult (..)) +import GHCup.Types hiding ( LeanAppState(..) ) +import qualified GHCup.Utils.Parsers as Utils +import GHCup.Utils + +import qualified GHCup.Brick.Actions as Actions +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.BasicOverlay +import GHCup.Brick.Widgets.InputField.Class +import GHCup.Brick.Widgets.InputField.CheckBox +import GHCup.Brick.Widgets.InputField.EditInput as EditInput +import GHCup.Brick.Widgets.InputField.SelectInput as SelectInput +import GHCup.Brick.Widgets.GenericMenu +import qualified GHCup.Brick.Actions as Actions +import qualified GHCup.Brick.App.Common as Common +import qualified GHCup.Brick.Common as Common +import GHCup.Prelude.Logger +import qualified GHCup.HLS as HLS + +import Brick + ( BrickEvent(..), + Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Control.Applicative (Alternative((<|>))) +import Control.Concurrent (threadDelay) +import Control.Exception.Safe +import Control.Monad (when, forM, forM_, void) +import Control.Monad.Reader +import Control.Monad.Trans.Except +import Control.Monad.Trans.Resource +import Data.Bifunctor (Bifunctor(..)) +import Data.Char (isSpace) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NE +import Data.Some +import qualified Data.Text as T +import Data.Variant.Excepts +import Data.Versions (Version, prettyVer) +import GHC.Generics (Generic) +import Prelude hiding (appendFile) +import qualified Graphics.Vty as Vty +import Optics ((^.), (&), to, (%), (%~)) +import Optics.State.Operators ((.=), (?=)) +import Optics.TH (makeLenses) +import Text.Read (readEither) +import Text.PrettyPrint.HughesPJClass (prettyShow) +import URI.ByteString (URI) + +data CompileHLSMenuFields n = CompileHLSMenuFields + { _targetGHCsF :: SelectInput n ToolVersion [ToolVersion] + , _updateCabalF :: CheckBoxInput n Bool + , _jobsF :: EditInput n (Maybe Int) + , _setCompileF :: CheckBoxInput n Bool + , _cabalArgsF :: EditInput n [T.Text] + , _isolateDirF :: EditInput n (Maybe FilePath) + , _overwriteVerF :: EditInput n (Maybe [VersionPattern]) + , _patchesF :: EditInput n (Maybe (Either FilePath [URI])) + , _cabalProjectF :: EditInput n (Maybe (Either FilePath URI)) + , _cabalProjectLocalF :: EditInput n (Maybe URI) + , _gitRefF :: EditInput n (Maybe String) + } deriving Generic + +data CompileHLSOptions = CompileHLSOptions + { _jobs :: Maybe Int + , _setCompile :: Bool + , _updateCabal :: Bool + , _overwriteVer :: Maybe [VersionPattern] + , _isolateDir :: Maybe FilePath + , _cabalProject :: Maybe (Either FilePath URI) + , _cabalProjectLocal :: Maybe URI + , _patches :: Maybe (Either FilePath [URI]) + , _targetGHCs :: [ToolVersion] + , _cabalArgs :: [T.Text] + , _gitRef :: Maybe String + } deriving (Eq, Show) + +concat <$> mapM makeLenses [''CompileHLSMenuFields, ''CompileHLSOptions] + +type CompileHLSMenu = GenericMenu Common.Name CompileHLSMenuFields (AppState, ListResult) CompileHLSOptions + +create :: KeyBindings -> ListResult -> AppState -> [Version] -> CompileHLSMenu +create kb lr s availableGHCs = mkGenericMenu + Common.CompileGHCBox + menuFields + validateInputs + (s, lr) + (\(s, lr) opts -> (Just CloseAllOverlays) <$ (Actions.suspendBrickAndRunAction s $ compileHLS opts lr)) + (Common.toMenuKeyBindings kb) + "Compile HLS" + (Button (Common.MenuElement Common.OkButton) + "Compile" + "Compile HLS from source with options below\nRequired fields: target GHC(s)") + where + menuFields = CompileHLSMenuFields + { _targetGHCsF = targetGHCsField + , _updateCabalF = updateCabalField + , _jobsF = jobsField + , _setCompileF = setCompileField + , _overwriteVerF = overwriteVerField + , _isolateDirF = isolateDirField + , _cabalProjectF = cabalProjectField + , _cabalProjectLocalF = cabalProjectLocalField + , _patchesF = patchesField + , _cabalArgsF = cabalArgsField + , _gitRefF = gitRefField + } + + validateInputs :: CompileHLSMenuFields Common.Name -> Either ErrorMessage CompileHLSOptions + validateInputs CompileHLSMenuFields {..} = do + let setCompileVal = _checked _setCompileF + isolateDirVal = editInputValue _isolateDirF + targetGHCs = case getSelection _targetGHCsF of + (vs, Just (Right (xs, _))) -> Right $ vs ++ xs + (_, Just (Left msg)) -> Left msg + (vs, Nothing) -> Right $ vs + ([], _) -> Left "target GHC(s): No version selected" + + case (setCompileVal, isolateDirVal) of + (True, Right (Just _)) -> Left "Cannot set active when doing an isolated install" + _ -> CompileHLSOptions + <$> editInputValue _jobsF + <*> Right setCompileVal + <*> Right (_checked _updateCabalF) + <*> editInputValue _overwriteVerF + <*> isolateDirVal + <*> editInputValue _cabalProjectF + <*> editInputValue _cabalProjectLocalF + <*> editInputValue _patchesF + <*> targetGHCs + <*> editInputValue _cabalArgsF + <*> editInputValue _gitRefF + + targetGHCsField = SelectInput.createMultiSelectInputWithEditable + (Common.MenuElement Common.BootstrapGhcSelectBox) + (Common.MenuElement Common.TargetGhcEditBox) + "target GHC(s)" + "GHC versions to compile for (Press Enter to edit)" + (fmap ToolVersion availableGHCs) + (T.pack . prettyShow) + ghcVersionTagEither + (Common.toMenuKeyBindings kb) + + cabalArgsField = EditInput.create + (Common.MenuElement Common.AdditionalEditBox) + "CABAL_ARGS" + "Additional arguments to cabal install" + additionalValidator + "" + + jobsField = EditInput.create + (Common.MenuElement Common.JobsEditBox) + "jobs" + "How many jobs to use for make" + jobsV + "" + + setCompileField = CheckBoxInput + (Common.MenuElement Common.SetCheckBox) + "set" + "Set as active version after install" + False + + updateCabalField = CheckBoxInput + (Common.MenuElement Common.UpdateCabalCheckBox) + "cabal update" + "Run 'cabal update' before the build" + False + + overwriteVerField = EditInput.create + (Common.MenuElement Common.OvewrwiteVerEditBox) + "overwrite version" + "Allows to overwrite the finally installed VERSION with a different one. Allows to specify patterns: %v (version), %b (branch name), %h (short commit hash), %H (long commit hash), %g ('git describe' output)" + overWriteVersionParser + "" + + isolateDirField = EditInput.create + (Common.MenuElement Common.IsolateEditBox) + "isolated" + "install in an isolated absolute directory instead of the default one" + filepathV + "" + + cabalProjectField = EditInput.create + (Common.MenuElement Common.CabalProjectEditBox) + "cabal project" + "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme." + cabalProjectV + "" + + cabalProjectLocalField = EditInput.create + (Common.MenuElement Common.CabalProjectLocalEditBox) + "cabal project local" + "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over." + cabalProjectLocalV + "" + + patchesField = EditInput.create + (Common.MenuElement Common.PatchesEditBox) + "patches" + "Either a URI to a patch (https/http/file) or Absolute path to patch directory" + patchesV + "" + + gitRefField = EditInput.create + (Common.MenuElement Common.GitRefEditBox) + "git-ref" + "The git commit/branch/ref to build from" + (whenEmpty Nothing (Right . Just . T.unpack)) + "" + + -- Brick's internal editor representation is [mempty]. + emptyEditor i = T.null i || (i == "\n") + whenEmpty :: a -> (T.Text -> Either ErrorMessage a) -> T.Text -> Either ErrorMessage a + whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval + + readUri :: T.Text -> Either ErrorMessage URI + readUri = first T.pack . Utils.uriParser . T.unpack + + cabalProjectV :: T.Text -> Either ErrorMessage (Maybe (Either FilePath URI)) + cabalProjectV = whenEmpty Nothing parseFileOrUri + where + parseFileOrUri i = + let x = bimap T.unpack Right (readUri i) + y = Right . Left . T.unpack $ i + in bimap T.pack Just $ x <|> y + + cabalProjectLocalV :: T.Text -> Either ErrorMessage (Maybe URI) + cabalProjectLocalV = whenEmpty Nothing (second Just . readUri) + + ghcVersionTagEither :: T.Text -> Either ErrorMessage [ToolVersion] + ghcVersionTagEither = whenEmpty [] $ first T.pack . traverse (Utils.ghcVersionTagEither . T.unpack) . T.split isSpace + + additionalValidator :: T.Text -> Either ErrorMessage [T.Text] + additionalValidator = whenEmpty [] $ Right . T.split isSpace + + jobsV :: T.Text -> Either ErrorMessage (Maybe Int) + jobsV = + let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack + in whenEmpty Nothing parseInt + + patchesV :: T.Text -> Either ErrorMessage (Maybe (Either FilePath [URI])) + patchesV = whenEmpty Nothing readPatches + where + readPatches j = + let + x = second (Just . Left) $ Utils.absolutePathParser (T.unpack j) + y = second (Just . Right) $ traverse (Utils.uriParser . T.unpack) (T.split isSpace j) + in first T.pack $ x <|> y + + filepathV :: T.Text -> Either ErrorMessage (Maybe FilePath) + filepathV = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . T.unpack) + + overWriteVersionParser :: T.Text -> Either ErrorMessage (Maybe [VersionPattern]) + overWriteVersionParser = whenEmpty Nothing $ bimap T.pack Just . Utils.overWriteVersionParser . T.unpack + +updateAvailableGHCs :: [Version] -> CompileHLSMenu -> CompileHLSMenu +updateAvailableGHCs availableGHCs v = v + & fields % targetGHCsF %~ SelectInput.updateItems (fmap ToolVersion availableGHCs) + +compileHLS :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => CompileHLSOptions -> ListResult -> m (Either String ()) +compileHLS compopts lr@ListResult{lTool = HLS, ..} = do + appstate <- ask + let run = + runResourceT + . runE @'[ AlreadyInstalled + , BuildFailed + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , TagNotFound + , DayNotFound + , NextVerNotFound + , NoToolVersionSet + , NotInstalled + , DirNotEmpty + , ArchiveResult + , UninstallFailed + , MergeFileTreeError + , URIParseError + ] + compileResult <- run (do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + hlsVer <- case compopts ^. gitRef of + Just ref -> pure (HLS.GitDist (GitBranch ref Nothing)) + Nothing -> do + -- Compile the version user is pointing to in the tui + let vi = getVersionInfo (mkTVer lVer) HLS dls + forM_ (_viPreInstall =<< vi) $ \msg -> do + lift $ logWarn msg + lift $ logWarn + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- give the user a sec to intervene + forM_ (_viPreCompile =<< vi) $ \msg -> do + logInfo msg + logInfo + "...waiting for 5 seconds, you can still abort..." + liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene + pure (HLS.SourceDist lVer) + + ghcs <- + liftE $ forM (compopts ^. targetGHCs) + (\ghc -> fmap (_tvVersion . fst) . Utils.fromVersion (Just ghc) GStrict $ GHC) + targetVer <- liftE $ GHCup.compileHLS + hlsVer + ghcs + (compopts ^. jobs) + (compopts ^. overwriteVer) + (maybe GHCupInternal IsolateDir $ compopts ^. isolateDir) + (compopts ^. cabalProject) + (compopts ^. cabalProjectLocal) + (compopts ^. updateCabal) + (compopts ^. patches) + (compopts ^. cabalArgs) + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask + let vi2 = getVersionInfo (mkTVer targetVer) GHC dls2 + when + (compopts ^. setCompile) + (liftE . void $ GHCup.setHLS targetVer SetHLSOnly Nothing) + pure (vi2, targetVer) + ) + case compileResult of + VRight (vi, tv) -> do + logInfo "HLS successfully compiled and installed" + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + liftIO $ putStr (T.unpack $ prettyVer tv) + pure $ Right () + VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $ + case keepDirs (appstate & settings) of + Never -> prettyHFError err + _ -> prettyHFError err <> "\n" + <> "Check the logs at " <> (fromGHCupPath $ appstate & dirs & logsDir) + <> " and the build directory " + <> tmpdir <> " for more clues." <> "\n" + <> "Make sure to clean up " <> tmpdir <> " afterwards." + VLeft e -> do + pure $ Left $ prettyHFError e +-- This is the case when the tool is not HLS... which should be impossible but, +-- it exhaustes pattern matches +compileHLS _ ListResult{lTool = _} = pure (Right ()) diff --git a/lib-tui/GHCup/Brick/App/ContextMenu.hs b/lib-tui/GHCup/Brick/App/ContextMenu.hs new file mode 100644 index 000000000..9e5d4fa46 --- /dev/null +++ b/lib-tui/GHCup/Brick/App/ContextMenu.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Brick.App.ContextMenu where + +import GHCup.List ( ListResult (..)) +import GHCup.Types ( KeyBindings(..), Tool(..), KeyCombination(..), AppState ) +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.BasicOverlay +import GHCup.Brick.Widgets.GenericMenu (state) +import qualified GHCup.Brick.App.AdvanceInstallMenu as AdvanceInstallMenu +import qualified GHCup.Brick.App.CompileGHCMenu as CompileGHCMenu +import qualified GHCup.Brick.App.CompileHLSMenu as CompileHLSMenu +import qualified GHCup.Brick.App.Common as Common +import qualified GHCup.Brick.Common as Common + +import Brick + ( BrickEvent(..), + Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import qualified Brick.Focus as F +import Data.Maybe +import Data.Some +import qualified Data.Text as T +import Data.Versions (prettyVer, Version) +import Prelude hiding ( appendFile ) +import qualified Graphics.Vty as Vty +import Optics (Lens', lens, over, (^.), (%), (&), (.~), (%~), _1, _2) +import Optics.State.Operators ((.=), (?=), (%=)) +import Optics.TH (makeLenses) + +data ContextMenu = ContextMenu + { _menuKeys :: Common.MenuKeyBindings + , _listResult :: ListResult + , _focusRing :: F.FocusRing Common.Name + , _overlay :: Maybe (Some (IsSubWidget Common.Name ContextMenu)) + , _advanceInstallMenu :: BasicOverlay Common.Name AdvanceInstallMenu.AdvanceInstallMenu + , _compileGHCMenu :: BasicOverlay Common.Name CompileGHCMenu.CompileGHCMenu + , _compileHLSMenu :: BasicOverlay Common.Name CompileHLSMenu.CompileHLSMenu + } + +makeLenses ''ContextMenu + +create :: KeyBindings -> ListResult -> AppState -> [Version] -> ContextMenu +create kb lr s availableGHCs = ContextMenu (Common.toMenuKeyBindings kb) lr (mkFocusRing lr) Nothing + (BasicOverlay (AdvanceInstallMenu.create kb lr s) [bQuit kb] (Common.frontwardLayer "Advance Install")) + (BasicOverlay (CompileGHCMenu.create kb lr s availableGHCs) [bQuit kb] (Common.frontwardLayer "Compile GHC")) + (BasicOverlay (CompileHLSMenu.create kb lr s availableGHCs) [bQuit kb] (Common.frontwardLayer "Compile HLS")) + +-- | This is done when the user selects a new row in navigation and opens the context menu +updateListResult :: ListResult -> ContextMenu -> ContextMenu +updateListResult lr v = v + & focusRing .~ mkFocusRing lr + & listResult .~ lr + & advanceInstallMenu % innerWidget % state % _2 .~ lr + & compileGHCMenu % innerWidget % state % _2 .~ lr + & compileHLSMenu % innerWidget % state % _2 .~ lr + +-- | This should be done when the AppState is potentially updated due to installation / +-- removal of tools +updateStateAndAvailableGHCs :: AppState -> [Version] -> ContextMenu -> ContextMenu +updateStateAndAvailableGHCs s availableGHCs v = v + & compileGHCMenu % innerWidget %~ CompileGHCMenu.updateAvailableGHCs availableGHCs + & compileHLSMenu % innerWidget %~ CompileHLSMenu.updateAvailableGHCs availableGHCs + & compileGHCMenu % innerWidget % state % _1 .~ s + & compileHLSMenu % innerWidget % state % _1 .~ s + & advanceInstallMenu % innerWidget % state % _1 .~ s + +mkFocusRing :: ListResult -> F.FocusRing Common.Name +mkFocusRing (ListResult {..}) = F.focusRing $ + case lTool of + GHC -> [Common.MenuElement Common.CompileGHCButton, Common.MenuElement Common.AdvanceInstallButton] + HLS -> [Common.MenuElement Common.CompileHLSButton, Common.MenuElement Common.AdvanceInstallButton] + _ -> [Common.MenuElement Common.AdvanceInstallButton] + +mkTitle :: ListResult -> T.Text +mkTitle (ListResult {..}) = "Context Menu for " <> tool_str <> " " <> prettyVer lVer + where + tool_str = + case lTool of + GHC -> "GHC" + GHCup -> "GHCup" + Cabal -> "Cabal" + HLS -> "HLS" + Stack -> "Stack" + +instance BaseWidget Common.Name ContextMenu where + draw (ContextMenu {..}) = Brick.vBox + [ Brick.vBox buttonWidgets + , Brick.txt " " + , Brick.padRight Brick.Max $ + Brick.txt "Press " + <+> Common.keyToWidget (_menuKeys ^. Common.mKbQuit) + <+> Brick.txt " to go back" + ] + where + buttonWidgets = map drawButtons (F.focusRingToList $ mkFocusRing _listResult) + maxWidth = 10 + currentFocus = fromMaybe (Common.MenuElement Common.AdvanceInstallButton) $ F.focusGetCurrent _focusRing + + drawButtons n@(Common.MenuElement Common.CompileGHCButton) = + drawOneField (n, "Compile") (Brick.txt "Compile GHC from source") + drawButtons n@(Common.MenuElement Common.CompileHLSButton) = + drawOneField (n, "Compile") (Brick.txt "Compile HLS from source") + drawButtons n@(Common.MenuElement Common.AdvanceInstallButton) = + drawOneField (n, "Install") (Brick.txt "Advance Installation Settings") + drawButtons _ = Brick.txt "" + + drawOneField (n, l) f = Common.rightify (maxWidth + 1) (Common.renderAslabel l (n == currentFocus) <+> Brick.txt " ") <+> f + + handleEvent ev = do + (ContextMenu {..}) <- Brick.get + let + currentFocus = fromMaybe (Common.MenuElement Common.AdvanceInstallButton) $ F.focusGetCurrent _focusRing + case ev of + VtyEvent (Vty.EvKey k m) + | KeyCombination k m == _menuKeys ^. Common.mKbUp -> do + focusRing %= F.focusPrev + | KeyCombination k m == _menuKeys ^. Common.mKbDown -> do + focusRing %= F.focusNext + VtyEvent (Vty.EvKey Vty.KEnter []) + | currentFocus == (Common.MenuElement Common.AdvanceInstallButton) -> + overlay ?= Some (IsSubWidget advanceInstallMenu) + | currentFocus == (Common.MenuElement Common.CompileGHCButton) -> + overlay ?= Some (IsSubWidget compileGHCMenu) + | currentFocus == (Common.MenuElement Common.CompileHLSButton) -> + overlay ?= Some (IsSubWidget compileHLSMenu) + _ -> pure () + pure Nothing + + hasOverlay = _overlay + closeOverlay = overlay .= Nothing diff --git a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs b/lib-tui/GHCup/Brick/App/KeyInfo.hs similarity index 60% rename from lib-tui/GHCup/Brick/Widgets/KeyInfo.hs rename to lib-tui/GHCup/Brick/App/KeyInfo.hs index 9122cfb90..ee298c943 100644 --- a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs +++ b/lib-tui/GHCup/Brick/App/KeyInfo.hs @@ -1,40 +1,48 @@ -{-# 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 #-} +{-# LANGUAGE TemplateHaskell #-} -{- -A very simple information-only widget with no handler. --} - -module GHCup.Brick.Widgets.KeyInfo where +module GHCup.Brick.App.KeyInfo where import GHCup.Types ( KeyBindings(..) ) +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.BasicOverlay +import qualified GHCup.Brick.App.Common as Common import qualified GHCup.Brick.Common as Common +import GHCup.Brick.App.Tutorial (Tutorial(..)) import Brick - ( Padding(Max), + ( BrickEvent(..), + Padding(Max), Widget(..), (<+>), (<=>)) import qualified Brick import Brick.Widgets.Center ( center ) +import Data.Some import Prelude hiding ( appendFile ) +import qualified Graphics.Vty as Vty +import Optics.State.Operators ((.=), (?=)) +import Optics.TH (makeLenses) + +data KeyInfo = KeyInfo + { _appKeys :: KeyBindings + , _tutorial :: BasicOverlay Common.Name Tutorial + , _overlay :: Maybe (Some (IsSubWidget Common.Name KeyInfo)) + } +makeLenses ''KeyInfo +create :: KeyBindings -> KeyInfo +create kb = KeyInfo kb (BasicOverlay (Tutorial (bQuit kb)) [] (Common.frontwardLayer "Tutorial")) Nothing -draw :: KeyBindings -> Widget Common.Name -draw KeyBindings {..} = - let - mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - in Common.frontwardLayer "Key Actions" - $ Brick.vBox [ +instance BaseWidget Common.Name KeyInfo where + draw (KeyInfo {..}) = + let + KeyBindings {..} = _appKeys + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + in Brick.vBox [ center $ mkTextBox [ Brick.hBox [ @@ -70,3 +78,12 @@ draw KeyBindings {..} = ] ] <=> Brick.hBox [Brick.txt "Press " <+> Common.keyToWidget bQuit <+> Brick.txt " to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"] + + handleEvent ev = do + case ev of + VtyEvent (Vty.EvKey Vty.KEnter _ ) -> overlay ?= Some (IsSubWidget tutorial) + _ -> pure () + pure Nothing + + hasOverlay = _overlay + closeOverlay = overlay .= Nothing diff --git a/lib-tui/GHCup/Brick/App/Navigation.hs b/lib-tui/GHCup/Brick/App/Navigation.hs new file mode 100644 index 000000000..393223506 --- /dev/null +++ b/lib-tui/GHCup/Brick/App/Navigation.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Brick.App.Navigation where + +import GHCup.Brick.Actions +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.App.Common as Common +import qualified GHCup.Brick.App.KeyInfo as KeyInfo +import qualified GHCup.Brick.App.ContextMenu as ContextMenu +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.BasicOverlay +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Widgets.SectionList as SectionList + +import GHCup.List ( ListResult(..) ) +import GHCup.Types + ( GHCTargetVersion(GHCTargetVersion), + AppState(..), + Tool(..), + Tag(..), + KeyBindings(..), + KeyCombination (KeyCombination), + tVerToText, + tagToString ) + +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 Control.Exception.Safe (throwIO) +import Control.Monad +import Control.Monad.Reader +import Data.Some +import Data.Vector ( Vector ) +import qualified Graphics.Vty as Vty +import Optics (Lens', use, to, (^.), (%), (&), (%~), (.~)) +import Optics.TH (makeLenses) +import Optics.State.Operators ((.=), (?=), (%=)) + +import Data.List ( intercalate, sort, find ) +import Data.Maybe ( mapMaybe ) +import Data.Vector ( Vector) +import Data.Versions ( prettyPVP, prettyVer ) +import Prelude hiding ( appendFile ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import qualified Data.Text as T +import qualified Data.Vector as V + +data Navigation = Navigation + { _sectionList :: NavigationList + , _listResult :: [ListResult] + , _appState :: AppState + , _showAllVersions :: Bool + , _attrMap :: AttrMap + , _appKeys :: KeyBindings + , _overlay :: Maybe (Some (IsSubWidget Common.Name Navigation)) + , _keyInfo :: BasicOverlay Common.Name KeyInfo.KeyInfo + , _contextMenu :: BasicOverlay Common.Name ContextMenu.ContextMenu + } + +makeLenses ''Navigation + +-- | How to create a navigation widget +create :: NonEmpty ListResult + -> AttrMap + -> KeyBindings + -> AppState + -> Navigation +create lr' dimAttrs kb s = + let showAllVersions = False + secList = replaceLR (filterVisible showAllVersions) lr Nothing + keyInfo = KeyInfo.create kb + cmenu = ContextMenu.create kb current_element s availableGHCs + cmenuTitle = ContextMenu.mkTitle current_element + -- As we have a NonEmpty list, this will always be Just + Just (_, current_element) = SectionList.sectionListSelectedElement secList + lr = NE.toList lr' + availableGHCs = fmap lVer $ + filter (\(ListResult {..}) -> lInstalled && lTool == GHC && lCross == Nothing) lr + in Navigation + { _sectionList = secList + , _listResult = lr + , _appState = s + , _showAllVersions = showAllVersions + , _attrMap = dimAttrs + , _appKeys = kb + , _overlay = Nothing + , _keyInfo = (BasicOverlay keyInfo [bQuit kb] (Common.frontwardLayer "Key Actions")) + , _contextMenu = BasicOverlay cmenu [bQuit kb] (Common.frontwardLayer cmenuTitle) + } + +-- | This will parse the GHCupInfo again and recreate the list of tools +-- This is necessary after an action like install, set, uninstall, compile etc +updateNavigation :: Brick.EventM n Navigation () +updateNavigation = do + old <- Brick.get + new <- liftIO (updateAppState old) + Brick.put new + where + updateAppState :: Navigation -> IO Navigation + updateAppState nav = do + (newState, lr) <- ((liftIO (getUpdatedAppState (_appState nav))) >>= \case + Left err -> throwIO $ userError err + Right s -> pure s) + + let availableGHCs = fmap lVer $ + filter (\(ListResult {..}) -> lInstalled && lTool == GHC && lCross == Nothing) lr + + pure $ nav + & appState .~ newState + & sectionList %~ replaceLR (filterVisible $ _showAllVersions nav) lr . Just + & listResult .~ lr + & contextMenu % innerWidget %~ ContextMenu.updateStateAndAvailableGHCs newState availableGHCs + +instance BaseWidget Common.Name Navigation where + draw (Navigation {..}) = + 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 _showAllVersions + ) + $ keyHandlers (_appKeys) + in drawNav _attrMap _sectionList <=> footer + + handleEvent ev = do + kb <- use appKeys + let listHandler = Common.zoom sectionList $ SectionList.handleGenericListEvent ev + case ev of + (VtyEvent (Vty.EvKey key mods)) -> + case find (\(key', _, _) -> key' == KeyCombination key mods) (keyHandlers kb) of + Just (_, _, handler) -> handler + Nothing -> listHandler + _ -> listHandler + pure Nothing + + hasOverlay = _overlay + closeOverlay = do + -- Doing this everytime the overlay is closed is not ideal, but doing this + -- here avoids fair bit of complexity related to update of listResult after + -- some action inside an overlay + updateNavigation + overlay .= Nothing + + +-- | How to draw the navigation widget +drawNav :: AttrMap -> NavigationList -> Widget Common.Name +drawNav 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 listIx 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 + active = if b then Common.enableScreenReader (Common.ListItem lTool listIx) else id + in Brick.clickable (Common.ListItem lTool listIx) $ hooray $ active $ 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 Experimental = Just $ Brick.withAttr Attributes.latestNightlyAttr $ Brick.str "experimental" + 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 ' ') + +keyHandlers :: KeyBindings + -> [ ( KeyCombination + , Bool -> String + , Brick.EventM Common.Name Navigation () + ) + ] +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 + , \showAllVersions -> + if showAllVersions then "Don't show all versions" else "Show all versions" + , hideShowHandler + ) + , (bUp, const "Up", Common.zoom sectionList SectionList.moveUp) + , (bDown, const "Down", Common.zoom sectionList SectionList.moveDown) + , (KeyCombination (Vty.KChar 'h') [], const "help", overlay ?= Some (IsSubWidget keyInfo)) + , (KeyCombination Vty.KEnter [], const "advance options", openContextMenuforTool ) + ] + where + withIOAction' action = do + Navigation {..} <- Brick.get + case SectionList.sectionListSelectedElement _sectionList of + Nothing -> pure () + Just (curr_ix, e) -> do + suspendBrickAndRunAction _appState $ action (curr_ix, e) + updateNavigation + + openContextMenuforTool = do + e <- use (sectionList % to SectionList.sectionListSelectedElement) + case e of + Nothing -> pure () + Just (_, r) -> do + -- Update the ListResult of ContextMenu, but maintain the state of Install/Compile + -- menus. This is especially useful in case the user made a typo and + -- would like to retry the action. + contextMenu % overlayLayer .= Common.frontwardLayer (ContextMenu.mkTitle r) + contextMenu % innerWidget %= ContextMenu.updateListResult r + overlay ?= Some (IsSubWidget contextMenu) + + hideShowHandler = do + Common.zoom showAllVersions $ Brick.modify not + b <- use showAllVersions + lr <- use listResult + Common.zoom sectionList $ Brick.modify (replaceLR (filterVisible b) lr . Just) diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/App/Tutorial.hs similarity index 76% rename from lib-tui/GHCup/Brick/Widgets/Tutorial.hs rename to lib-tui/GHCup/Brick/App/Tutorial.hs index 738ff6944..8b7bd2b6c 100644 --- a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs +++ b/lib-tui/GHCup/Brick/App/Tutorial.hs @@ -1,40 +1,34 @@ -{-# 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 +module GHCup.Brick.App.Tutorial (Tutorial(..)) where +import GHCup.Brick.Widgets.BaseWidget +import qualified GHCup.Brick.App.Common as Common import qualified GHCup.Brick.Common as Common import qualified GHCup.Brick.Attributes as Attributes import GHCup.Types (KeyCombination(..)) import Brick - ( Padding(Max), + ( BrickEvent(..), + Padding(Max), Widget(..), (<=>), (<+>)) import qualified Brick import Brick.Widgets.Center ( center ) +import qualified Graphics.Vty as Vty import Prelude hiding ( appendFile ) +data Tutorial = Tutorial + { _quitKey :: KeyCombination + } +instance BaseWidget Common.Name Tutorial where + draw (Tutorial {..}) = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) -draw :: KeyCombination -> Widget Common.Name -draw exitKey = - let - mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - - in Common.frontwardLayer "Tutorial" - $ Brick.vBox + in Brick.vBox (fmap center [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] , Common.separator @@ -76,4 +70,11 @@ draw exitKey = , Brick.txt " " ]) <=> (Brick.padRight Brick.Max $ - Brick.txt "Press " <+> Common.keyToWidget exitKey <+> Brick.txt " to exit the tutorial") + Brick.txt "Press " <+> Common.keyToWidget _quitKey <+> Brick.txt " to exit the tutorial") + + handleEvent ev = do + (Tutorial {..}) <- Brick.get + case ev of + VtyEvent (Vty.EvKey key mods) + | _quitKey == KeyCombination key mods -> pure (Just CloseAllOverlays) + _ -> pure Nothing diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs deleted file mode 100644 index ab59b74fa..000000000 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# 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 GHCup.Brick.Widgets.Menus.Context (ContextMenu) -import GHCup.Brick.Widgets.Menus.AdvanceInstall (AdvanceInstallMenu) -import GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCMenu) -import Optics.TH (makeLenses) -import GHCup.Brick.Widgets.Menus.CompileHLS (CompileHLSMenu) - - -data BrickState = BrickState - { _appData :: BrickData - , _appSettings :: BrickSettings - , _appState :: BrickInternalState - , _contextMenu :: ContextMenu - , _advanceInstallMenu :: AdvanceInstallMenu - , _compileGHCMenu :: CompileGHCMenu - , _compileHLSMenu :: CompileHLSMenu - , _appKeys :: KeyBindings - , _mode :: Mode - } - --deriving Show - -makeLenses ''BrickState diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 9b5747d7b..8b600654a 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -1,170 +1,25 @@ -{-# 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 #-} -{-# LANGUAGE PatternSynonyms #-} - -{- -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 ( - installedSign, - setSign, - notInstalledSign, - checkBoxSelectedSign, - showKey, - showMod, - keyToWidget, - separator, - frontwardLayer, - enableScreenReader, - zoom, - defaultAppSettings, - lr, - showAllVersions, - Name(..), - Mode(..), - BrickData(..), - BrickSettings(..), - ResourceId ( - UrlEditBox, SetCheckBox, IsolateEditBox, ForceCheckBox, AdditionalEditBox - , TargetGhcEditBox, BootstrapGhcEditBox, HadrianGhcEditBox, JobsEditBox, BuildConfigEditBox - , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox - , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton - , CompileGHCButton, CompileHLSButton, CabalProjectEditBox - , CabalProjectLocalEditBox, UpdateCabalCheckBox, GitRefEditBox - , BootstrapGhcSelectBox, HadrianGhcSelectBox, ToolVersionBox, GHCInstallTargets - ) ) where - -import GHCup.List ( ListResult ) + +module GHCup.Brick.Common where + import GHCup.Prelude ( isWindows ) -import GHCup.Types ( Tool, KeyCombination (KeyCombination) ) +import qualified GHCup.Brick.Attributes as Attributes +import GHCup.Types ( Tool, KeyCombination (KeyCombination), KeyBindings(..) ) import Data.List (intercalate) import Prelude hiding ( appendFile ) import qualified Graphics.Vty as Vty -import Optics.TH (makeLenses) import Optics.Lens (toLensVL) import qualified Brick +import qualified Brick.Widgets.List as L import qualified Brick.Widgets.Border as Border import Brick ((<+>)) import qualified Data.Text as T import qualified Brick.Widgets.Center as Brick import qualified Brick.Widgets.Border.Style as Border - --- We could use regular ADTs but different menus share the same options. --- example: all of ghcup compile ghc, ghcup compile hls, ghcup install cabal, etc... --- all have a --set, --force, etc... common arguments. If we went for the ADT we'd end up --- with SetCompileHLSOption, SetCompileGHCOption, SetInstallCabalOption, etc... --- which isn't terrible, but verbose enough to reject it. - --- | A newtype for labeling resources in menus. It is bundled along with pattern synonyms -newtype ResourceId = ResourceId Int deriving (Eq, Ord, Show) - -pattern OkButton :: ResourceId -pattern OkButton = ResourceId 0 -pattern AdvanceInstallButton :: ResourceId -pattern AdvanceInstallButton = ResourceId 100 -pattern CompileGHCButton :: ResourceId -pattern CompileGHCButton = ResourceId 101 -pattern CompileHLSButton :: ResourceId -pattern CompileHLSButton = ResourceId 102 - -pattern UrlEditBox :: ResourceId -pattern UrlEditBox = ResourceId 1 -pattern SetCheckBox :: ResourceId -pattern SetCheckBox = ResourceId 2 -pattern IsolateEditBox :: ResourceId -pattern IsolateEditBox = ResourceId 3 -pattern ForceCheckBox :: ResourceId -pattern ForceCheckBox = ResourceId 4 -pattern AdditionalEditBox :: ResourceId -pattern AdditionalEditBox = ResourceId 5 - -pattern TargetGhcEditBox :: ResourceId -pattern TargetGhcEditBox = ResourceId 6 -pattern BootstrapGhcEditBox :: ResourceId -pattern BootstrapGhcEditBox = ResourceId 7 -pattern HadrianGhcEditBox :: ResourceId -pattern HadrianGhcEditBox = ResourceId 20 -pattern JobsEditBox :: ResourceId -pattern JobsEditBox = ResourceId 8 -pattern BuildConfigEditBox :: ResourceId -pattern BuildConfigEditBox = ResourceId 9 -pattern PatchesEditBox :: ResourceId -pattern PatchesEditBox = ResourceId 10 -pattern CrossTargetEditBox :: ResourceId -pattern CrossTargetEditBox = ResourceId 11 -pattern AddConfArgsEditBox :: ResourceId -pattern AddConfArgsEditBox = ResourceId 12 -pattern OvewrwiteVerEditBox :: ResourceId -pattern OvewrwiteVerEditBox = ResourceId 13 -pattern BuildFlavourEditBox :: ResourceId -pattern BuildFlavourEditBox = ResourceId 14 -pattern BuildSystemEditBox :: ResourceId -pattern BuildSystemEditBox = ResourceId 15 - -pattern CabalProjectEditBox :: ResourceId -pattern CabalProjectEditBox = ResourceId 16 -pattern CabalProjectLocalEditBox :: ResourceId -pattern CabalProjectLocalEditBox = ResourceId 17 -pattern UpdateCabalCheckBox :: ResourceId -pattern UpdateCabalCheckBox = ResourceId 18 - -pattern GitRefEditBox :: ResourceId -pattern GitRefEditBox = ResourceId 19 - -pattern BootstrapGhcSelectBox :: ResourceId -pattern BootstrapGhcSelectBox = ResourceId 21 -pattern HadrianGhcSelectBox :: ResourceId -pattern HadrianGhcSelectBox = ResourceId 22 - -pattern ToolVersionBox :: ResourceId -pattern ToolVersionBox = ResourceId 23 - -pattern GHCInstallTargets :: ResourceId -pattern GHCInstallTargets = ResourceId 24 - --- | 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 - | ListItem Tool Int -- ^ An item in list - | KeyInfoBox -- ^ The text box widget with action informacion - | TutorialBox -- ^ The tutorial widget - | ContextBox -- ^ The resource for Context Menu - | CompileGHCBox -- ^ The resource for CompileGHC Menu - | AdvanceInstallBox -- ^ The resource for AdvanceInstall Menu - | MenuElement ResourceId -- ^ Each element in a Menu. Resources must not be share for visible - -- Menus, but MenuA and MenuB can share resources if they both are - -- invisible, or just one of them is visible. - - deriving (Eq, Ord, Show) - --- | Mode type. It helps to dispatch events to different handlers. -data Mode = Navigation - | KeyInfo - | Tutorial - | ContextPanel - | AdvanceInstallPanel - | CompileGHCPanel - | CompileHLSPanel - deriving (Eq, Show, Ord) +import Optics.TH (makeLenses) installedSign :: String | isWindows = "I " @@ -209,6 +64,14 @@ frontwardLayer layer_name = . Brick.withBorderStyle Border.unicode . Border.borderWithLabel (Brick.txt layer_name) +smallerOverlayLayer :: T.Text -> Brick.Widget n -> Brick.Widget n +smallerOverlayLayer layer_name = + Brick.centerLayer + . Brick.hLimitPercent 50 + . Brick.vLimitPercent 65 + . Brick.withBorderStyle Border.unicode + . Border.borderWithLabel (Brick.txt layer_name) + -- | puts a cursor at the line beginning so It can be read by screen readers enableScreenReader :: n -> Brick.Widget n -> Brick.Widget n enableScreenReader n = Brick.putCursor n (Brick.Location (0,0)) @@ -218,17 +81,47 @@ enableScreenReader n = Brick.putCursor n (Brick.Location (0,0)) -- | 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] +data MenuKeyBindings = MenuKeyBindings + { _mKbUp :: KeyCombination + , _mKbDown :: KeyCombination + , _mKbQuit :: KeyCombination } - deriving Show - -makeLenses ''BrickData - -data BrickSettings = BrickSettings { _showAllVersions :: Bool} - --deriving Show - -makeLenses ''BrickSettings - -defaultAppSettings :: BrickSettings -defaultAppSettings = BrickSettings False + deriving (Show) + +makeLenses ''MenuKeyBindings + +toMenuKeyBindings :: KeyBindings -> MenuKeyBindings +toMenuKeyBindings KeyBindings {..} = MenuKeyBindings { _mKbUp = bUp, _mKbDown = bDown, _mKbQuit = bQuit} + +-- | highlights a widget (using List.listSelectedFocusedAttr) +highlighted :: Brick.Widget n -> Brick.Widget n +highlighted = Brick.withAttr L.listSelectedFocusedAttr + +-- | Given a text, crates a highlighted label on focus. An amplifier can be passed +renderAslabel :: T.Text -> Bool -> Brick.Widget n +renderAslabel t focus = + if focus + then highlighted $ Brick.txt t + else Brick.txt t + +-- | Creates a left align column. +-- Example: |- col2 is align dispite the length of col1 +-- row1_col1 row1_col2 +-- row2_col1_large row2_col2 +leftify :: Int -> Brick.Widget n -> Brick.Widget n +leftify i = Brick.hLimit i . Brick.padRight Brick.Max + +-- | Creates a right align column. +-- Example: |- col2 is align dispite the length of col1 +-- row1_col1 row1_col2 +-- row2_col1_large row2_col2 +rightify :: Int -> Brick.Widget n -> Brick.Widget n +rightify i = Brick.hLimit i . Brick.padLeft Brick.Max + +-- | render some Text using helpMsgAttr +renderAsHelpMsg :: T.Text -> Brick.Widget n +renderAsHelpMsg = Brick.withAttr Attributes.helpMsgAttr . Brick.txt + +-- | render some Text using errMsgAttr +renderAsErrMsg :: T.Text -> Brick.Widget n +renderAsErrMsg = Brick.withAttr Attributes.errMsgAttr . Brick.txt diff --git a/lib-tui/GHCup/Brick/Widgets/BaseWidget.hs b/lib-tui/GHCup/Brick/Widgets/BaseWidget.hs new file mode 100644 index 000000000..fba59dbe1 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/BaseWidget.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} + +module GHCup.Brick.Widgets.BaseWidget where + +import qualified GHCup.Brick.Common as Common + +import Brick + ( BrickEvent(..), + EventM, + Widget(..)) +import qualified Brick + +import Control.Monad +import Control.Monad.Reader +import Data.Some +import Optics (Lens', (^.), (%)) + +-- | This helps model a tree of widgets where each node has an instance of the BaseWidget +-- The root of the tree is the topmost widget. +-- Each BaseWidget can have zero or one of of its child widgets open at a given time +-- When a child widget is open, it will be rendered as an overlay on top of the +-- parent and the child's handleEvent will receive all the events. +-- The nesting can be arbitrarily deep. +class BaseWidget n a | a -> n where + draw :: a -> Widget n + + -- | This will be invoked only if hasOverlay is Nothing + -- in case of an overlay is open, the event will be passed to the child widget + -- A widget need to handle their own events, decide whether it needs to open a + -- child widget, or close itself. + handleEvent :: BrickEvent n () -> EventM n a (Maybe HandleEventResult) + + -- | Indicates whether a child widget is open + hasOverlay :: a -> Maybe (Some (IsSubWidget n a)) + hasOverlay _ = Nothing + + -- | This should modify 'a' to close any open overlay + closeOverlay :: EventM n a () + closeOverlay = pure () + + {-# MINIMAL (draw, handleEvent) #-} + +-- | This is returned by the child to the parent widget and indicates whether +-- the child widget should be closed +data HandleEventResult + -- | Closes child (the widget which returns this event) + = CloseOverlay + -- | Close all widgets till the root (top widget) + | CloseAllOverlays + deriving (Eq, Show) + +-- | A widget 'b' which has 'a' as its parent, typically is structured in way +-- such that 'a' contains 'b' as a record field. +-- The `Lens' a b` allows us to `zoom` +data IsSubWidget n a b where + IsSubWidget :: (BaseWidget n b) => Lens' a b -> IsSubWidget n a b + +-- | Draw all the widgets, child is overlayed on top of parent widget +drawBaseWidget :: (BaseWidget n a) => a -> [Widget n] +drawBaseWidget a = overlays ++ [draw a] + where + overlays = case hasOverlay a of + Nothing -> [] + Just (Some (IsSubWidget accessor)) -> drawBaseWidget $ a ^. accessor + +-- | Pass through the event to the leaf widget (if it is open) +-- and does closing of overlay(s) by calling `closeOverlay` of parent widget(s) +handleEventBaseWidget :: (BaseWidget n a) => BrickEvent n () -> EventM n a (Maybe HandleEventResult) +handleEventBaseWidget ev = do + a <- Brick.get + case hasOverlay a of + Nothing -> handleEvent ev + Just (Some (IsSubWidget accessor)) -> do + res <- Common.zoom accessor $ handleEventBaseWidget ev + case res of + Just CloseOverlay -> do + closeOverlay + pure Nothing + Just CloseAllOverlays -> do + closeOverlay + pure $ Just CloseAllOverlays + Nothing -> pure Nothing diff --git a/lib-tui/GHCup/Brick/Widgets/BasicOverlay.hs b/lib-tui/GHCup/Brick/Widgets/BasicOverlay.hs new file mode 100644 index 000000000..edefd4159 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/BasicOverlay.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Brick.Widgets.BasicOverlay where + +import qualified GHCup.Brick.Common as Common +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Types (KeyCombination (KeyCombination)) + +import Brick + ( BrickEvent(..), + EventM, + Widget(..)) +import qualified Brick + +import Control.Monad +import Control.Monad.Reader +import Data.List (find) +import Data.Some +import qualified Graphics.Vty as Vty +import Optics (Lens', (^.), (%)) +import Optics.TH (makeLenses) + +-- | This does the boilerplate of `quitKey` event handling +data BasicOverlay n a = BasicOverlay + { _innerWidget :: a + , _quitKey :: [KeyCombination] + , _overlayLayer :: Brick.Widget n -> Brick.Widget n + } + +makeLenses ''BasicOverlay + +instance (BaseWidget n a) => BaseWidget n (BasicOverlay n a) where + draw (BasicOverlay { .. }) = _overlayLayer (draw _innerWidget) + handleEvent ev = do + (BasicOverlay { .. }) <- Brick.get + case ev of + VtyEvent (Vty.EvKey key mods) -> + case find ((==) $ KeyCombination key mods) _quitKey of + Just _ -> pure $ Just CloseOverlay + _ -> Common.zoom innerWidget $ handleEvent ev + _ -> Common.zoom innerWidget $ handleEvent ev + hasOverlay (BasicOverlay { .. }) = case hasOverlay _innerWidget of + Nothing -> Nothing + Just (Some (IsSubWidget accessor)) -> Just $ Some (IsSubWidget (innerWidget % accessor)) + closeOverlay = Common.zoom innerWidget closeOverlay diff --git a/lib-tui/GHCup/Brick/Widgets/GenericMenu.hs b/lib-tui/GHCup/Brick/Widgets/GenericMenu.hs new file mode 100644 index 000000000..fe231d8f3 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/GenericMenu.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHCup.Brick.Widgets.GenericMenu where + +import qualified GHCup.Brick.Common as Common +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.InputField.Class +import GHCup.Types (KeyCombination (KeyCombination)) + +import Brick + ( BrickEvent(..), + EventM, + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import qualified Brick.Focus as F + +import Control.Monad +import Control.Monad.Reader +import Data.Maybe +import Data.List (find, foldl') +import Data.Some +import qualified Data.Text as T + +import GHC.Generics (Generic, Rep, from, to) + +import qualified Graphics.Vty as Vty +import Optics (Lens', lens, (^.), (%)) +import Optics.State.Operators ((%=), (.=), (?=)) +import Optics.TH (makeLenses) + + +data GenericMenu n fs s a = GenericMenu + { _fields :: fs n + , _focusRing :: F.FocusRing n + , _getOutput :: fs n -> Either ErrorMessage a + , _menuKeys :: Common.MenuKeyBindings + , _state :: s + , _submitAction :: s -> a -> EventM n (GenericMenu n fs s a) (Maybe HandleEventResult) + , _submitButton :: Button n + , _name :: n + , _title :: T.Text + , _overlay :: Maybe (Some (IsSubWidget n (GenericMenu n fs s a))) + } + +data Button n = Button + { _buttonName :: n + , _label :: T.Text + , _helpMessage :: HelpMessage + } + +makeLenses ''GenericMenu + +mkGenericMenu :: (Generic (fs n), GInputFields n (Rep (fs n))) + => n + -> fs n + -> (fs n -> Either ErrorMessage a) + -> s + -> (s -> a -> EventM n (GenericMenu n fs s a) (Maybe HandleEventResult)) + -> Common.MenuKeyBindings + -> T.Text + -> Button n + -> GenericMenu n fs s a +mkGenericMenu n fs getOutput initState action kb title submitButton = GenericMenu + { _fields = fs + , _focusRing = F.focusRing $ (_buttonName submitButton) : (map fst $ getLabels $ GHC.Generics.from fs) + , _getOutput = getOutput + , _menuKeys = kb + , _state = initState + , _submitAction = action + , _submitButton = submitButton + , _name = n + , _title = title + , _overlay = Nothing + } + + +instance (Generic (fs n), GInputFields n (Rep (fs n)), Ord n, Show n) => BaseWidget n (GenericMenu n fs s a) where + draw (GenericMenu { .. }) = Brick.vBox + [ Brick.vBox buttonWidgets + , Common.separator + , Brick.vLimit (length fieldLabels) $ Brick.withVScrollBars Brick.OnRight + $ Brick.viewport _name Brick.Vertical + $ Brick.vBox fieldWidgetsWithLabels + , Brick.txt " " + , Brick.padRight Brick.Max $ + Brick.txt "Press " + <+> Common.keyToWidget (_menuKeys ^. Common.mKbQuit) + <+> Brick.txt " to go back, Press Enter to edit the highlighted field" + ] + where + gFields = GHC.Generics.from _fields + fieldLabels = getLabels gFields + + maxWidth = foldl' max 5 (fmap Brick.textWidth $ map snd fieldLabels) + + fieldWidgetsWithLabels = zipWith drawOneField fieldLabels (gDrawInputFields currentFocus ampF gFields) + drawOneField (n, l) f = Common.rightify (maxWidth + 1) (Common.renderAslabel l (n == currentFocus) <+> Brick.txt " ") <+> f + + ampF fieldName True field = Common.enableScreenReader fieldName $ Brick.visible field + ampF _ _ field = field + + submitButtonName = _buttonName $ _submitButton + currentFocus = fromMaybe submitButtonName $ F.focusGetCurrent _focusRing + + buttonWidgets = + let focused = submitButtonName == currentFocus + submitButton = ampF submitButtonName focused $ Common.renderAslabel "Submit" focused + errMsg = case _getOutput _fields of + Right _ -> Common.renderAsHelpMsg (_helpMessage _submitButton) + Left msg -> Common.renderAsErrMsg msg + in [drawOneField (submitButtonName, _label _submitButton) errMsg] + + handleEvent ev = do + (GenericMenu { .. }) <- Brick.get + let + gFields = GHC.Generics.from _fields + submitButtonName = _buttonName $ _submitButton + currentFocus = fromMaybe submitButtonName $ F.focusGetCurrent _focusRing + + case ev of + VtyEvent (Vty.EvKey k m) + | KeyCombination k m == _menuKeys ^. Common.mKbUp -> do + focusRing %= F.focusPrev + pure Nothing + | KeyCombination k m == _menuKeys ^. Common.mKbDown -> do + focusRing %= F.focusNext + pure Nothing + VtyEvent (Vty.EvKey Vty.KEnter []) + | currentFocus == submitButtonName -> case _getOutput _fields of + Right v -> _submitAction _state v + Left _ -> pure Nothing + _ -> do + (_, (newFields, res)) <- Brick.nestEventM gFields $ gHandleEvent currentFocus gFields ev + Brick.modify $ \s -> s { _fields = GHC.Generics.to newFields } + pure Nothing + + hasOverlay (GenericMenu { .. }) = case gHasOverlay (GHC.Generics.from _fields) of + Nothing -> _overlay + Just (Some (IsSubWidget accessor)) -> Just (Some (IsSubWidget $ fields % lens GHC.Generics.from (const GHC.Generics.to) % accessor)) + + closeOverlay = do + (GenericMenu { .. }) <- Brick.get + (_, newFields) <- Brick.nestEventM (GHC.Generics.from _fields) $ gCloseOverlay + Brick.modify $ \s -> s { _fields = GHC.Generics.to newFields } + overlay .= Nothing + pure () diff --git a/lib-tui/GHCup/Brick/Widgets/InputField/CheckBox.hs b/lib-tui/GHCup/Brick/Widgets/InputField/CheckBox.hs new file mode 100644 index 000000000..d250ad9b1 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/InputField/CheckBox.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Brick.Widgets.InputField.CheckBox where + +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Common as Common + +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.InputField.Class + +import Brick + ( BrickEvent(..), + EventM, + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import qualified Data.Text as T + +import qualified Graphics.Vty as Vty +import Optics (Lens', lens, (^.), (%)) +import Optics.State.Operators ((%=), (.=), (?=)) +import Optics.TH (makeLenses) + +data CheckBoxInput n a = CheckBoxInput + { _name :: n + , _label :: T.Text + , _helpMessage :: HelpMessage + , _checked :: Bool + } + +makeLenses ''CheckBoxInput + +instance (Ord n, Show n) => BaseWidget n (CheckBoxInput n Bool) where + -- This is not used. See drawInputField + draw = const $ Brick.txt "CheckBoxInput draw" + + handleEvent ev = do + case ev of + VtyEvent (Vty.EvKey Vty.KEnter []) -> Common.zoom checked (Brick.modify not) + _ -> pure () + pure Nothing + +instance (Ord n, Show n) => InputField n (CheckBoxInput n Bool) where + getLabel e = (_name e, _label e) + drawInputField focus f (CheckBoxInput {..}) = if focus + then core + else core <+> (Brick.padLeft (Brick.Pad 1) . Common.renderAsHelpMsg $ _helpMessage) + where + core = f $ drawBool _checked + border w = Brick.txt "[" <+> (Brick.padRight (Brick.Pad 1) $ Brick.padLeft (Brick.Pad 2) w) <+> Brick.txt "]" + drawBool b = + if b + then border . Brick.withAttr Attributes.installedAttr $ Brick.str Common.checkBoxSelectedSign + else border . Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign diff --git a/lib-tui/GHCup/Brick/Widgets/InputField/Class.hs b/lib-tui/GHCup/Brick/Widgets/InputField/Class.hs new file mode 100644 index 000000000..2be69e39c --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/InputField/Class.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE UndecidableInstances #-} + +module GHCup.Brick.Widgets.InputField.Class where + +import GHCup.Brick.Widgets.BaseWidget + +import Brick + ( BrickEvent(..), + EventM, + Widget(..), + (<+>)) +import qualified Brick +import Control.Applicative ( (<|>) ) +import Data.Some +import qualified Data.Text as T +import Optics (lens, (%)) + +import GHC.Generics ((:*:)(..), K1(..), M1(..), from, to, Generic, Rep) + +-- | An error message +type ErrorMessage = T.Text +type HelpMessage = T.Text + +-- | This is a specialized class designed for use of input fields in GenericMenu +class (BaseWidget n a) => InputField n a | a -> n where + -- | Draw the field, which is rendered on the right side of the generic menu + drawInputField :: Bool -- ^ Is focused + -> (Widget n -> Widget n) -- ^ a modifier / amplifier + -> a + -> Widget n + + getLabel :: a -> (n, T.Text) + +-- | A collection of APIs for use in GenericMenu, +-- The input fields are part of a "product" data type, and this allows us to make use of +-- Generics to do various operations of the BaseWidget +class GInputFields n a | a -> n where + getLabels :: a p -> [(n, T.Text)] + gDrawInputFields :: n -> (n -> Bool -> Widget n -> Widget n) -> a p -> [Widget n] + gHandleEvent :: n -> a p -> BrickEvent n () -> EventM n (a p) (a p, Maybe HandleEventResult) + gHasOverlay :: a p -> Maybe (Some (IsSubWidget n (a p))) + gCloseOverlay :: EventM n (a p) (a p) + +instance (GInputFields n f, GInputFields n g, Eq n) => GInputFields n (f :*: g) where + getLabels (x :*: y) = getLabels x ++ getLabels y + gDrawInputFields n f (x :*: y) = gDrawInputFields n f x ++ gDrawInputFields n f y + gHandleEvent n (x :*: y) ev = do + (_, (x', res1)) <- Brick.nestEventM x $ gHandleEvent n x ev + (_, (y', res2)) <- Brick.nestEventM y $ gHandleEvent n y ev + pure ((x' :*: y'), res1 <|> res2) + gHasOverlay (x :*: y) = case gHasOverlay x of + Nothing -> case gHasOverlay y of + Nothing -> Nothing + Just (Some (IsSubWidget accessor)) -> Just (Some (IsSubWidget $ lens (\(_ :*: y) -> y) (\(x :*: _) y -> (x :*: y)) % accessor)) + Just (Some (IsSubWidget accessor)) -> Just (Some (IsSubWidget $ lens (\(x :*: _) -> x) (\(_ :*: y) x -> (x :*: y)) % accessor)) + gCloseOverlay = do + (x :*: y) <- Brick.get + (_, x') <- Brick.nestEventM x $ gCloseOverlay + (_, y') <- Brick.nestEventM y $ gCloseOverlay + pure (x' :*: y') + +instance (InputField n a, Eq n) => GInputFields n (K1 i a) where + getLabels (K1 x) = [getLabel x] + gDrawInputFields n f (K1 x) = + let focused = n == name + name = fst (getLabel x) + in [drawInputField focused (f name focused) x] + gHandleEvent n (K1 x) ev = if fst (getLabel x) == n + then do + (x', res) <- Brick.nestEventM x $ handleEvent ev + pure (K1 x', res) + else pure (K1 x, Nothing) + gHasOverlay (K1 x) = case hasOverlay x of + Nothing -> Nothing + Just (Some (IsSubWidget accessor)) -> Just (Some (IsSubWidget $ lens (\(K1 x) -> x) (\_ x -> (K1 x)) % accessor)) + gCloseOverlay = do + (K1 x) <- Brick.get + (x', _) <- Brick.nestEventM x $ closeOverlay + pure (K1 x') + +instance (GInputFields n a, Eq n) => GInputFields n (M1 i t a) where + getLabels (M1 x) = getLabels x + gDrawInputFields n f (M1 x) = gDrawInputFields n f x + gHandleEvent n (M1 x) ev = do + (_, (x', res)) <- Brick.nestEventM x $ gHandleEvent n x ev + pure (M1 x', res) + gHasOverlay (M1 x) = case gHasOverlay x of + Nothing -> Nothing + Just (Some (IsSubWidget accessor)) -> Just (Some (IsSubWidget $ lens (\(M1 x) -> x) (\_ x -> (M1 x)) % accessor)) + gCloseOverlay = do + (M1 x) <- Brick.get + (_, x') <- Brick.nestEventM x $ gCloseOverlay + pure (M1 x') diff --git a/lib-tui/GHCup/Brick/Widgets/InputField/EditInput.hs b/lib-tui/GHCup/Brick/Widgets/InputField/EditInput.hs new file mode 100644 index 000000000..6f6090a8c --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/InputField/EditInput.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Brick.Widgets.InputField.EditInput where + +import GHCup.Types (KeyCombination(..)) +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Common as Common + +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.BasicOverlay +import GHCup.Brick.Widgets.InputField.Class + +import Brick + ( BrickEvent(..), + EventM, + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import qualified Brick.Widgets.Border as Border +import qualified Brick.Widgets.Edit as Edit + +import Data.Some +import qualified Data.Text as T + +import qualified Graphics.Vty as Vty +import Optics (Lens', lens, (^.), (%)) +import Optics.State.Operators ((%=), (.=), (?=)) +import Optics.TH (makeLenses) + +data EditInput n a = EditInput + { _name :: n + , _label :: T.Text + , _overlay :: Maybe (Some (IsSubWidget n (EditInput n a))) + , _editInputOverlay :: BasicOverlay n (EditInputOverlay n a) + } + +data EditInputOverlay n a = EditInputOverlay + { _editor :: Edit.Editor T.Text n + , _validator :: T.Text -> Either T.Text a + , _helpMessage :: HelpMessage + } + +concat <$> mapM makeLenses [''EditInputOverlay, ''EditInput] + +create :: (Eq n, Show n) + => n + -> T.Text + -> HelpMessage + -> (T.Text -> Either T.Text a) + -> T.Text + -> EditInput n a +create name label helpMsg validator initVal = + EditInput name label Nothing + (BasicOverlay (EditInputOverlay (Edit.editor name (Just 1) initVal) validator helpMsg) [KeyCombination Vty.KEnter []] (Common.frontwardLayer label)) + +editInputTextAndValue :: EditInput n a -> Either ErrorMessage (a, T.Text) +editInputTextAndValue e' = either Left (\a -> Right (a, editorContents)) $ _validator e editorContents + where editorContents = T.unlines $ Edit.getEditContents $ _editor e + e = _innerWidget $ _editInputOverlay e' + +editInputText :: EditInput n a -> Either ErrorMessage T.Text +editInputText e = snd <$> editInputTextAndValue e + +editInputValue :: EditInput n a -> Either ErrorMessage a +editInputValue e = fst <$> editInputTextAndValue e + +instance (Ord n, Show n) => BaseWidget n (EditInput n a) where + -- This is not used. See drawInputField + draw = const $ Brick.txt "EditInput draw" + + handleEvent ev = do + (EditInput {..}) <- Brick.get + case ev of + VtyEvent (Vty.EvKey Vty.KEnter []) -> overlay ?= Some (IsSubWidget editInputOverlay) + _ -> pure () + pure Nothing + + hasOverlay = _overlay + closeOverlay = overlay .= Nothing + +instance (Ord n, Show n) => InputField n (EditInput n a) where + getLabel e = (_name e, _label e) + drawInputField focus f (EditInput {..}) = + let + borderBox w = f (Brick.vLimit 1 $ Border.vBorder <+> Brick.padRight Brick.Max w <+> Border.vBorder) + editorContents = T.unlines $ Edit.getEditContents edi + edi = _editor $ _innerWidget _editInputOverlay + isEditorEmpty = Edit.getEditContents edi == [mempty] + help = (_helpMessage $ _innerWidget _editInputOverlay) + in borderBox $ case (_validator $ _innerWidget _editInputOverlay) editorContents of + Right _ + | isEditorEmpty -> Common.renderAsHelpMsg help + | otherwise -> Brick.txt $ editorContents + Left errMsg + | focus && isEditorEmpty -> Common.renderAsHelpMsg help + | focus -> Brick.txt $ editorContents + | otherwise -> Common.renderAsErrMsg errMsg + +instance (Ord n, Show n) => BaseWidget n (EditInputOverlay n a) where + draw e = Brick.vBox $ + [ Brick.txtWrap (_helpMessage e) + , Border.border $ Edit.renderEditor (Brick.txt . T.unlines) True edi + , case _validator e editorContents of + Left msg -> Common.renderAsErrMsg msg + _ -> Brick.txt " " + , Brick.padRight Brick.Max $ + Brick.txt "Press Enter to go back" + ] + where + edi = _editor e + editorContents = T.unlines $ Edit.getEditContents edi + + handleEvent ev = do + Common.zoom editor $ Edit.handleEditorEvent ev + pure Nothing diff --git a/lib-tui/GHCup/Brick/Widgets/InputField/SelectInput.hs b/lib-tui/GHCup/Brick/Widgets/InputField/SelectInput.hs new file mode 100644 index 000000000..dd457827b --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/InputField/SelectInput.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} + +module GHCup.Brick.Widgets.InputField.SelectInput where + +import GHCup.Types (KeyCombination(..)) +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Common as Common + +import GHCup.Brick.Widgets.BaseWidget +import GHCup.Brick.Widgets.BasicOverlay +import GHCup.Brick.Widgets.InputField.Class +import qualified GHCup.Brick.Widgets.InputField.EditInput as EditInput + +import Brick + ( BrickEvent(..), + EventM, + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import qualified Brick.Focus as F +import qualified Brick.Widgets.Border as Border +import qualified Brick.Widgets.Edit as Edit + +import Data.Maybe +import Data.List (find) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.List.NonEmpty as NE +import Data.Some +import qualified Data.Text as T + +import qualified Graphics.Vty as Vty +import Optics (Lens', lens, to, over, use, _1, (^.), (%), (&), (%~), (.~)) +import Optics.State.Operators ((%=), (.=), (?=)) +import Optics.TH (makeLenses) + +data SelectInput n i a = SelectInput + { _name :: n + , _overlay :: Maybe (Some (IsSubWidget n (SelectInput n i a))) + , _selectInputOverlay :: BasicOverlay n (SelectInputOverlay n i a) + , _label :: T.Text + , _helpMessage :: HelpMessage + } + +data SelectInputOverlay n i a = SelectInputOverlay + { -- | All items along with their selected state + -- And Bool to indicate if editable field is selected + _items :: ([(Int, (i, Bool))], Bool) + -- | Editable text field + , _editInput :: Maybe (EditInput.EditInput n a) + -- | Focus ring using integral values assigned to each item, text field is always last + , _focusRing :: F.FocusRing Int + , _showItem :: (i -> T.Text) + -- | Update the selection; Int value is the focus ring's value when user pressed 'Enter' + , _update :: (Int -> ([(Int, (i, Bool))], Bool) -> (([(Int, (i, Bool))]), Bool)) + , _menuKeys :: Common.MenuKeyBindings + , _viewportName :: n + } + +concat <$> mapM makeLenses [''SelectInputOverlay, ''SelectInput] + +createSelectInput :: (Eq n, Show n) + => n + -> T.Text + -> HelpMessage + -> NonEmpty i + -> (i -> T.Text) + -> Common.MenuKeyBindings + -> SelectInput n i () +createSelectInput name label helpMsg items showItem kb = + SelectInput name Nothing + (BasicOverlay overlay [kb ^. Common.mKbQuit] (Common.smallerOverlayLayer label)) + label helpMsg + where + overlay = SelectInputOverlay initState Nothing (F.focusRing [1.. totalRows]) showItem singleSelect kb name + totalRows = length items + initState = (zip [1..] $ fmap (,False) $ NE.toList items, False) + + singleSelect :: Int -> ([(Int, (i, Bool))], a) -> ([(Int, (i, Bool))], a) + singleSelect ix = over _1 $ fmap (\(ix', (i, b)) -> if ix' == ix then (ix', (i, True)) else (ix', (i, False))) + +createMultiSelectInput :: (Eq n, Show n) + => n + -> T.Text + -> HelpMessage + -> NonEmpty i + -> (i -> T.Text) + -> Common.MenuKeyBindings + -> SelectInput n i () +createMultiSelectInput name label helpMsg items showItem kb = + SelectInput name Nothing + (BasicOverlay overlay [kb ^. Common.mKbQuit] (Common.smallerOverlayLayer label)) + label helpMsg + where + overlay = SelectInputOverlay initState Nothing (F.focusRing [1.. totalRows]) showItem multiSelect kb name + totalRows = length items + initState = (zip [1..] $ fmap (,False) $ NE.toList items, False) + + multiSelect :: Int -> ([(Int, (i, Bool))], a) -> ([(Int, (i, Bool))], a) + multiSelect ix = over _1 $ fmap (\(ix', (i, b)) -> if ix' == ix then (ix', (i, not b)) else (ix', (i, b))) + +createSelectInputWithEditable :: (Eq n, Show n) + => n + -> n + -> T.Text + -> HelpMessage + -> [i] + -> (i -> T.Text) + -> (T.Text -> Either ErrorMessage a) + -> Common.MenuKeyBindings + -> SelectInput n i a +createSelectInputWithEditable name editName label helpMsg items showItem validator kb = + SelectInput name Nothing + (BasicOverlay overlay [kb ^. Common.mKbQuit] (Common.smallerOverlayLayer label)) + label helpMsg + where + overlay = SelectInputOverlay initState (Just editInp) (F.focusRing [1..totalRows]) showItem singleSelect kb name + totalRows = length items + 1 + initState = (zip [1..] $ fmap (,False) $ items, False) + + editInp = EditInput.create editName label helpMsg validator "" + + singleSelect :: Int -> ([(Int, (i, Bool))], Bool) -> ([(Int, (i, Bool))], Bool) + singleSelect ix (ne, a) = (fmap (\(ix', (i, b)) -> if ix' == ix then (ix', (i, True)) else (ix', (i, False))) ne, ix == length ne + 1) + +createMultiSelectInputWithEditable :: (Eq n, Show n) + => n + -> n + -> T.Text + -> HelpMessage + -> [i] + -> (i -> T.Text) + -> (T.Text -> Either ErrorMessage a) + -> Common.MenuKeyBindings + -> SelectInput n i a +createMultiSelectInputWithEditable name editName label helpMsg items showItem validator kb = + SelectInput name Nothing + (BasicOverlay overlay [kb ^. Common.mKbQuit] (Common.smallerOverlayLayer label)) + label helpMsg + where + overlay = SelectInputOverlay initState (Just editInp) (F.focusRing [1..totalRows]) showItem multiSelect kb name + totalRows = length items + 1 + initState = (zip [1..] $ fmap (,False) $ items, False) + + editInp = EditInput.create editName label helpMsg validator "" + + multiSelect :: Int -> ([(Int, (i, Bool))], Bool) -> ([(Int, (i, Bool))], Bool) + multiSelect ix (ne, a) = (fmap (\(ix', (i, b)) -> if ix' == ix then (ix', (i, True)) else (ix', (i, b))) ne, ix == length ne + 1) + +instance (Ord n, Show n) => BaseWidget n (SelectInput n i a) where + -- This is not used. See drawInputField + draw = const $ Brick.txt "SelectInput draw" + + handleEvent ev = do + case ev of + VtyEvent (Vty.EvKey Vty.KEnter []) -> overlay ?= Some (IsSubWidget selectInputOverlay) + _ -> pure () + pure Nothing + + hasOverlay = _overlay + closeOverlay = overlay .= Nothing + +instance (Ord n, Show n) => InputField n (SelectInput n i a) where + getLabel e = (_name e, _label e) + drawInputField focus f (SelectInput {..}) = + let showItem = _showItem $ _innerWidget $ _selectInputOverlay + in f $ case getSelection' (_innerWidget $ _selectInputOverlay) of + ([], Nothing) -> (Brick.padLeft (Brick.Pad 1) . Common.renderAsHelpMsg $ _helpMessage) + (_, Just (Left msg)) -> Brick.padLeft (Brick.Pad 1) $ Common.renderAsErrMsg msg + (xs, Just (Right (_, txt))) -> Brick.hBox $ + fmap (Brick.padRight (Brick.Pad 1) . Brick.txt . showItem) xs + ++ [Brick.txt txt] + (xs, Nothing) -> Brick.hBox $ fmap (Brick.padRight (Brick.Pad 1) . Brick.txt . showItem) xs + +instance (Ord n, Show n) => BaseWidget n (SelectInputOverlay n i a) where + draw (SelectInputOverlay {..}) = Brick.vBox $ + [ Brick.txt "Press " + <+> Common.keyToWidget (_menuKeys ^. Common.mKbQuit) + <+> Brick.txt " to go back, Press Enter to select" + <+> Brick.txt (if txtFieldFocused then ", Press e to edit" else "") + , Brick.vLimit (totalRows) $ Brick.withVScrollBars Brick.OnRight + $ Brick.viewport _viewportName Brick.Vertical + $ Brick.vBox $ mEditableField ++ (fmap (mkSelectRow focused) (fst _items)) + ] + where + focused = fromMaybe 1 $ F.focusGetCurrent _focusRing + txtFieldFocused = focused == totalRows + mEditableField = case _editInput of + Just e -> [ mkEditTextRow txtFieldFocused e (snd _items) ] + Nothing -> [] + + totalRows = (if isJust _editInput then (+) 1 else id) $ length (fst _items) + + mkSelectRow focused (ix, (item, selected)) = (if focused == ix then Brick.visible else id) $ + Brick.txt "[" <+> (Brick.padRight (Brick.Pad 1) $ Brick.padLeft (Brick.Pad 1) m) <+> Brick.txt "] " + <+> (Common.renderAslabel (_showItem item) (focused == ix)) + where m = if selected then Brick.txt "*" else Brick.txt " " + + mkEditTextRow focused e selected = (if focused then Brick.visible else id) $ + Brick.txt "[" <+> (Brick.padRight (Brick.Pad 1) $ Brick.padLeft (Brick.Pad 1) m) <+> Brick.txt "] " + <+> if Edit.getEditContents edi == [mempty] + then Common.renderAslabel "(Specify custom text value)" focused + else case EditInput.editInputText e of + Left err -> Common.renderAsErrMsg err + Right v -> Common.renderAslabel v focused + where + m = if selected then Brick.txt "*" else Brick.txt " " + edi = EditInput._editor $ _innerWidget $ EditInput._editInputOverlay e + + handleEvent ev = do + focused <- use (focusRing % Optics.to F.focusGetCurrent) + (SelectInputOverlay {..}) <- Brick.get + let totalRows = (if isJust _editInput then (+) 1 else id) $ length (fst _items) + case ev of + VtyEvent (Vty.EvKey k m) + | KeyCombination k m == _menuKeys ^. Common.mKbUp -> focusRing %= F.focusPrev + | KeyCombination k m == _menuKeys ^. Common.mKbDown -> focusRing %= F.focusNext + VtyEvent (Vty.EvKey Vty.KEnter []) -> + items %= _update (fromMaybe 1 focused) + VtyEvent (Vty.EvKey (Vty.KChar 'e') []) -> case (focused, _editInput) of + (Just ix, Just editInput) + | ix == totalRows -> Common.zoom selectInputOverlayEditInputJust $ EditInput.overlay ?= Some (IsSubWidget EditInput.editInputOverlay) + _ -> pure () + _ -> pure () + pure Nothing + + hasOverlay (SelectInputOverlay {..}) = case hasOverlay =<< _editInput of + Nothing -> Nothing + Just (Some (IsSubWidget accessor)) -> Just (Some (IsSubWidget (selectInputOverlayEditInputJust % accessor))) + + closeOverlay = do + (SelectInputOverlay {..}) <- Brick.get + case _editInput of + Nothing -> pure () + Just edi -> do + Common.zoom selectInputOverlayEditInputJust closeOverlay + -- Also select the text field entry + let txtFieldRow = length (fst _items) + 1 + items %= _update txtFieldRow + +-- Useful lens when we know the editInput is a Just value +selectInputOverlayEditInputJust = editInput % lens (\(Just v) -> v) (\_ v -> Just v) + +getSelection :: SelectInput n i a -> ([i], Maybe (Either ErrorMessage (a, T.Text))) +getSelection = getSelection' . _innerWidget . _selectInputOverlay + +getSelection' :: SelectInputOverlay n i a -> ([i], Maybe (Either ErrorMessage (a, T.Text))) +getSelection' (SelectInputOverlay {..}) = + (map fst . filter snd . map snd $ fst _items + , f (snd _items, _editInput)) + where + f (True, Just edi) = Just $ EditInput.editInputTextAndValue edi + f _ = Nothing + +-- | Replaces the list of items with the new one, while maintaining the selection from the old +updateItems :: forall n i a . (Eq i) => [i] -> SelectInput n i a -> SelectInput n i a +updateItems new s = s + & selectInputOverlay % innerWidget % items % _1 %~ selectFromOld + & selectInputOverlay % innerWidget % focusRing .~ F.focusRing [1..totalRows] + where + selectFromOld :: [(Int, (i, Bool))] -> [(Int, (i, Bool))] + selectFromOld old = zip [1..] $ fmap (\i -> (i, isSelected i)) new + where isSelected i = fromMaybe False $ fmap (snd . snd) $ find (\(_,(i', b)) -> i == i') old + + totalRows = length new + (if isJust (s ^. selectInputOverlay % innerWidget % editInput) then 1 else 0) diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs deleted file mode 100644 index fedfaac96..000000000 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ /dev/null @@ -1,613 +0,0 @@ -{-# 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 #-} -{-# LANGUAGE GADTs #-} - - -{- ************** - -A general system inspired by Brick.Form. It uses optics instead of microlenses and it is less generic than -Brick.Form, but generic enough to serve our purpose. - -A Menu consists in - a) A state value - b) A list of fields. Each field is capable of modifying a part of the state - c) some metadata - -A field (type MenuField) consists in - a) a Lens to a part of the Menu state, so the Menu can call that lens to modify its own state - b) an input widget - -An input (type FieldInput) consist in - a) some state - b) a validator function - c) a handler and a renderer - -We have to use existential types to achive a composable API since every FieldInput has a different -internal type, and every MenuField has a different Lens. For example: - - The menu state is a record (MyRecord {uri: URI, flag : Bool}) - - Then, there are two MenuField: - - One MenuField has (Lens' MyRecord URI) and the other has (Lens' MyRecord Bool) - - The MenuFields has FieldInputs with internal state Text and Bool, respectively - - Obviously, the MenuField has to be polimorphic in the Lens' and in the Input internal state, - But we must hide that polimorphisim (existential), in order to store all MenuField in a List - -************** -} - -module GHCup.Brick.Widgets.Menu where - -import qualified GHCup.Brick.Attributes as Attributes -import qualified GHCup.Brick.Common as Common - -import Brick - ( BrickEvent(..), - EventM, - Widget(..), - (<+>)) -import qualified Brick -import qualified Brick.Widgets.Border as Border -import qualified Brick.Widgets.Border.Style as Border -import qualified Brick.Widgets.Center as Brick -import qualified Brick.Widgets.List as L -import qualified Brick.Widgets.Edit as Edit -import Brick.Focus (FocusRing) -import qualified Brick.Focus as F -import Data.Function ( (&)) -import Prelude hiding ( appendFile ) - -import Data.Maybe -import qualified Data.Text as T - - -import Optics.TH (makeLensesFor) -import qualified Graphics.Vty as Vty -import Optics.State.Operators ((%=), (.=)) -import Optics.Optic ((%)) -import Optics.State (use, assign) -import GHCup.Types (KeyCombination(..)) -import Optics (Lens', to, lens, _1, over) -import Optics.Operators ( (^.), (.~) ) -import Data.Foldable (find, foldl') -import Data.List.NonEmpty ( NonEmpty (..) ) -import qualified Data.List.NonEmpty as NE - - --- | Just some type synonym to make things explicit -type Formatter n = Bool -> Widget n -> Widget n --- | A label -type Label = T.Text --- | A help message of an entry -type HelpMessage = T.Text --- | A button name -type ButtonName n = n - -idFormatter :: Formatter n -idFormatter = const id - - --- | An error message -type ErrorMessage = T.Text -data ErrorStatus = Valid | Invalid ErrorMessage deriving (Eq) - --- | A lens which does nothing. Usefull to defined no-op fields -emptyLens :: Lens' s () -emptyLens = lens (const ()) (\s _ -> s) - --- | A FieldInput is a pair label-content --- a - is the type of the field it manipulates --- b - is its internal state (modified in the gui) --- n - your application's resource name type -data FieldInput a b n = - FieldInput - { inputState :: b -- ^ The state of the input field (what's rendered in the screen) - , inputValidator :: b -> Either ErrorMessage a -- ^ A validator function - , inputHelp :: HelpMessage -- ^ The input helpMessage - , inputRender :: Bool - -> ErrorStatus - -> HelpMessage - -> Label - -> b - -> (Widget n -> Widget n) - -> (Widget n, Maybe (Widget n)) -- ^ How to draw the input and optionally an overlay, with focus a help message and input. - -- A extension function can be applied too - , inputHandler :: BrickEvent n () -> EventM n b () -- ^ The handler - } - -makeLensesFor - [ ("inputState", "inputStateL") - , ("inputValidator", "inputValidatorL") - , ("inputName", "inputNameL") - , ("inputHelp", "inputHelpL") - ] - ''FieldInput - --- | The MenuField is an existential type which stores a Lens' to a part of the Menu state. --- In also contains a Field input which internal state is hidden -data MenuField s n where - MenuField :: - { fieldAccesor :: Lens' s a -- ^ A Lens pointing to some part of the state - , fieldInput :: FieldInput a b n -- ^ The input which modifies the state - , fieldLabel :: Label -- ^ The label - , fieldStatus :: ErrorStatus -- ^ Whether the current is valid or not. - , fieldName :: n - } -> MenuField s n - -isValidField :: MenuField s n -> Bool -isValidField = (== Valid) . fieldStatus - -makeLensesFor - [ ("fieldLabel", "fieldLabelL") - , ("fieldStatus", "fieldStatusL") - ] - ''MenuField - -data SelectState i n = SelectState - { selectStateItems :: (NonEmpty (Int, (i, Bool)), Bool) -- ^ All items along with their selected state - -- And Bool to indicate if editable field is selected - , selectStateEditState :: Maybe (Edit.Editor T.Text n) -- ^ Editable field's editor state - , selectStateFocusRing :: FocusRing Int -- ^ Focus ring using integeral values assigned to each item - , selectStateOverlayOpen :: Bool -- ^ Whether the select menu is open - } - -makeLensesFor - [ ("selectStateItems", "selectStateItemsL") - , ("selectStateEditState", "selectStateEditStateL") - , ("selectStateFocusRing", "selectStateFocusRingL") - , ("selectStateOverlayOpen", "selectStateOverlayOpenL") - ] - ''SelectState - -data EditState n = EditState - { editState :: Edit.Editor T.Text n - , editStateOverlayOpen :: Bool -- ^ Whether the edit menu is open - } - -makeLensesFor - [ ("editState", "editStateL") - , ("editStateOverlayOpen", "editStateOverlayOpenL") - ] - ''EditState - -data MenuKeyBindings = MenuKeyBindings - { mKbUp :: KeyCombination - , mKbDown :: KeyCombination - , mKbQuit :: KeyCombination - } - deriving (Show) - -makeLensesFor - [ ("mKbUp", "mKbUpL") - , ("mKbDown", "mKbDownL") - , ("mKbQuit", "mKbQuitL") - ] - ''MenuKeyBindings - --- | A fancy lens to the help message -fieldHelpMsgL :: Lens' (MenuField s n) HelpMessage -fieldHelpMsgL = lens g s - where g (MenuField {..})= fieldInput ^. inputHelpL - s (MenuField{..}) msg = MenuField {fieldInput = fieldInput & inputHelpL .~ msg , ..} - --- | How to draw a field given a formater -drawField :: Formatter n -> Bool -> MenuField s n -> Widget n -drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) = - let (input, overlay) = inputRender focus fieldStatus inputHelp fieldLabel inputState (amp focus) - in case (focus, overlay) of - (True, Nothing) -> Common.enableScreenReader fieldName $ Brick.visible input - _ -> input - -drawFieldOverlay :: MenuField s n -> Maybe (Widget n) -drawFieldOverlay (MenuField { fieldInput = FieldInput {..}, ..}) = - snd $ inputRender True fieldStatus inputHelp fieldLabel inputState id - -instance Brick.Named (MenuField s n) n where - getName :: MenuField s n -> n - getName entry = entry & fieldName - - -{- ***************** - CheckBox widget -***************** -} - -type CheckBoxField = MenuField - -createCheckBoxInput :: FieldInput Bool Bool n -createCheckBoxInput = FieldInput False Right "" checkBoxRender checkBoxHandler - where - border w = Brick.txt "[" <+> (Brick.padRight (Brick.Pad 1) $ Brick.padLeft (Brick.Pad 2) w) <+> Brick.txt "]" - drawBool b = - if b - then border . Brick.withAttr Attributes.installedAttr $ Brick.str Common.checkBoxSelectedSign - else border . Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign - checkBoxRender focus _ help _ check f = (, Nothing) $ - let core = f $ drawBool check - in if focus - then core - else core <+> (Brick.padLeft (Brick.Pad 1) . renderAsHelpMsg $ help) - checkBoxHandler = \case - VtyEvent (Vty.EvKey Vty.KEnter []) -> Brick.modify not - _ -> pure () - -createCheckBoxField :: n -> Lens' s Bool -> CheckBoxField s n -createCheckBoxField name access = MenuField access createCheckBoxInput "" Valid name - -{- ***************** - Editable widget -***************** -} - -type EditableField = MenuField - -createEditableInput :: (Ord n, Show n) => T.Text -> n -> (T.Text -> Either ErrorMessage a) -> FieldInput a (EditState n) n -createEditableInput initText name validator = FieldInput initEdit validateEditContent "" drawEdit handler - where - drawEdit focus errMsg help label (EditState edi overlayOpen) amp = (field, mOverlay) - where - field = - let - borderBox w = amp (Brick.vLimit 1 $ Border.vBorder <+> Brick.padRight Brick.Max w <+> Border.vBorder) - editorContents = Brick.txt $ T.unlines $ Edit.getEditContents edi - isEditorEmpty = Edit.getEditContents edi == [mempty] - || Edit.getEditContents edi == [initText] - - in case errMsg of - Valid | isEditorEmpty -> borderBox $ renderAsHelpMsg help - | otherwise -> borderBox editorContents - Invalid msg - | focus && isEditorEmpty -> borderBox $ renderAsHelpMsg help - | focus -> borderBox editorContents - | otherwise -> borderBox $ renderAsErrMsg msg - mOverlay = if overlayOpen - then Just (overlayLayer ("Edit " <> label) $ overlay) - else Nothing - overlay = Brick.vBox $ - [ Brick.txtWrap help - , Border.border $ Edit.renderEditor (Brick.txt . T.unlines) focus edi - , case errMsg of - Invalid msg -> renderAsErrMsg msg - _ -> Brick.txt " " - , Brick.padRight Brick.Max $ - Brick.txt "Press Enter to go back" - ] - handler ev = do - (EditState edi overlayOpen) <- Brick.get - if overlayOpen - then case ev of - VtyEvent (Vty.EvKey Vty.KEnter []) -> editStateOverlayOpenL .= False - _ -> Common.zoom editStateL $ Edit.handleEditorEvent ev - else case ev of - VtyEvent (Vty.EvKey Vty.KEnter []) -> editStateOverlayOpenL .= True - _ -> pure () - validateEditContent = validator . T.init . T.unlines . Edit.getEditContents . editState - initEdit = EditState (Edit.editorText name (Just 1) initText) False - -createEditableField' :: (Eq n, Ord n, Show n) => T.Text -> n -> (T.Text -> Either ErrorMessage a) -> Lens' s a -> EditableField s n -createEditableField' initText name validator access = MenuField access input "" Valid name - where - input = createEditableInput initText name validator - -createEditableField :: (Eq n, Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> Lens' s a -> EditableField s n -createEditableField = createEditableField' "" - -{- ***************** - Button widget -***************** -} - -type Button = MenuField - -createButtonInput :: FieldInput () () n -createButtonInput = FieldInput () Right "" drawButton (const $ pure ()) - where - drawButton True (Invalid err) _ _ _ amp = (amp . renderAsErrMsg $ err, Nothing) - drawButton _ _ help _ _ amp = - let pad = if length (T.lines help) == 1 then Brick.padTop (Brick.Pad 1) else id - in (amp . pad . renderAsHelpMsg $ help, Nothing) - -createButtonField :: n -> Button s n -createButtonField = MenuField emptyLens createButtonInput "" Valid - -{- ***************** - Select widget -***************** -} - -type SelectField = MenuField - -createSelectInput :: (Ord n, Show n) - => NonEmpty i - -> (i -> T.Text) - -> (Int -> (NonEmpty (Int, (i, Bool)), Bool) -> ((NonEmpty (Int, (i, Bool))), Bool)) - -> (([i], Maybe T.Text) -> Either ErrorMessage k) - -> n - -> Maybe n - -> MenuKeyBindings - -> FieldInput k (SelectState i n) n -createSelectInput items showItem updateSelection validator viewportFieldName mEditFieldName kb - = FieldInput initState (validator . getSelectedItems) "" selectRender selectHandler - where - totalRows = (if isJust mEditFieldName then (+) 1 else id) $ length items - initState = SelectState - (NE.zip (1 NE.:| [2..]) $ fmap (,False) items, False) - ((\n -> Edit.editorText n (Just 1) "") <$> mEditFieldName) - (F.focusRing [1.. totalRows]) - False - getSelectedItems (SelectState {..}) = - ( fmap (fst . snd) . (filter (snd . snd)) . NE.toList . fst $ selectStateItems - , if snd selectStateItems then (T.init . T.unlines . Edit.getEditContents <$> selectStateEditState) else Nothing) - - border w = Brick.txt "[" <+> (Brick.padRight (Brick.Pad 1) $ Brick.padLeft (Brick.Pad 1) w) <+> Brick.txt "]" - selectRender focus errMsg help label s amp = (field, mOverlay) - where - field = - let mContents = case getSelectedItems s of - ([], Nothing) -> Nothing - (xs, mTxt) -> Just $ fmap (Brick.padRight (Brick.Pad 1) . Brick.txt . showItem) xs - ++ (case mTxt of Just t -> [Brick.txt t]; Nothing -> []) - in amp $ case (errMsg, mContents) of - (Valid, Nothing) -> (Brick.padLeft (Brick.Pad 1) . renderAsHelpMsg $ help) - (Valid, Just contents) -> border $ Brick.hBox contents - (Invalid msg, Nothing) - | focus -> Brick.padLeft (Brick.Pad 1) . renderAsHelpMsg $ help - | otherwise -> Brick.padLeft (Brick.Pad 1) $ renderAsErrMsg msg - (Invalid msg, Just contents) - | focus -> border $ Brick.hBox contents - | otherwise -> Brick.padLeft (Brick.Pad 1) $ renderAsErrMsg msg - - mOverlay = if selectStateOverlayOpen s - then Just (overlayLayer ("Select " <> label) $ overlay s errMsg help) - else Nothing - overlay (SelectState {..}) errMsg help = Brick.vBox $ - [ if txtFieldFocused - then Brick.txtWrap "Press Enter to finish editing and select custom value. Press Up/Down keys to navigate" - else Brick.txt "Press " - <+> Common.keyToWidget (kb ^. mKbQuitL) - <+> Brick.txt " to go back, Press Enter to select" - , case errMsg of Invalid msg -> renderAsErrMsg msg; _ -> Brick.emptyWidget - , Brick.vLimit (totalRows) $ Brick.withVScrollBars Brick.OnRight - $ Brick.viewport viewportFieldName Brick.Vertical - $ Brick.vBox $ mEditableField ++ (NE.toList $ fmap (mkSelectRow focused) (fst selectStateItems)) - ] - where focused = fromMaybe 1 $ F.focusGetCurrent selectStateFocusRing - txtFieldFocused = focused == totalRows - mEditableField = case selectStateEditState of - Just edi -> [ mkEditTextRow txtFieldFocused edi (snd selectStateItems) help ] - Nothing -> [] - - mkSelectRow focused (ix, (item, selected)) = (if focused == ix then Brick.visible else id) $ - Brick.txt "[" <+> (Brick.padRight (Brick.Pad 1) $ Brick.padLeft (Brick.Pad 1) m) <+> Brick.txt "] " - <+> (renderAslabel (showItem item) (focused == ix)) - where m = if selected then Brick.txt "*" else Brick.txt " " - - mkEditTextRow focused edi selected help = (if focused then Brick.visible else id) $ - Brick.txt "[" <+> (Brick.padRight (Brick.Pad 1) $ Brick.padLeft (Brick.Pad 1) m) <+> Brick.txt "] " - <+> if not focused && Edit.getEditContents edi == [mempty] - then Brick.txt "(Specify custom text value)" - else Brick.vLimit 1 $ Border.vBorder <+> Brick.padRight Brick.Max (Edit.renderEditor (Brick.txt . T.unlines) focused edi) <+> Border.vBorder - where m = if selected then Brick.txt "*" else Brick.txt " " - - selectHandler ev = do - s <- Brick.get - if selectStateOverlayOpen s - then do - focused <- use (selectStateFocusRingL % to F.focusGetCurrent) - mEditState <- use selectStateEditStateL - case (focused, mEditState) of - (Just ix, Just edi) - | ix == totalRows -> case ev of - VtyEvent (Vty.EvKey Vty.KEnter []) -> do - selectStateItemsL %= updateSelection ix - selectStateFocusRingL %= F.focusNext - VtyEvent (Vty.EvKey Vty.KDown []) -> selectStateFocusRingL %= F.focusNext - VtyEvent (Vty.EvKey Vty.KUp []) -> selectStateFocusRingL %= F.focusPrev - _ -> do - newEdi <- Brick.nestEventM' edi $ Edit.handleEditorEvent ev - assign selectStateEditStateL (Just newEdi) - selectStateItemsL %= updateSelection ix - _ -> case ev of - VtyEvent (Vty.EvKey k m) - | KeyCombination k m == kb ^. mKbQuitL -> selectStateOverlayOpenL .= False - | KeyCombination k m == kb ^. mKbUpL -> selectStateFocusRingL %= F.focusPrev - | KeyCombination k m == kb ^. mKbDownL -> selectStateFocusRingL %= F.focusNext - VtyEvent (Vty.EvKey Vty.KEnter []) -> do - selectStateItemsL %= updateSelection (fromMaybe 1 focused) - _ -> pure () - else case ev of - VtyEvent (Vty.EvKey Vty.KEnter []) -> selectStateOverlayOpenL .= True - _ -> pure () - --- | Select Field with only single selection possible, aka radio button -createSelectField :: (Ord n, Show n) => n -> Lens' s (Maybe i) -> NonEmpty i -> (i -> T.Text) -> MenuKeyBindings -> SelectField s n -createSelectField name access items showItem keyBindings = MenuField access (createSelectInput items showItem singleSelect getSelection name Nothing keyBindings) "" Valid name - where - singleSelect :: Int -> (NonEmpty (Int, (i, Bool)), a) -> (NonEmpty (Int, (i, Bool)), a) - singleSelect ix = over _1 $ fmap (\(ix', (i, b)) -> if ix' == ix then (ix', (i, True)) else (ix', (i, False))) - - getSelection = Right . fmap NE.head . NE.nonEmpty . fst - --- | Select Field with multiple selections possible -createMultiSelectField :: (Ord n, Show n) => n -> Lens' s [i] -> NonEmpty i -> (i -> T.Text) -> MenuKeyBindings -> SelectField s n -createMultiSelectField name access items showItem keyBindings = MenuField access (createSelectInput items showItem multiSelect (Right . fst) name Nothing keyBindings) "" Valid name - where - multiSelect :: Int -> (NonEmpty (Int, (i, Bool)), a) -> (NonEmpty (Int, (i, Bool)), a) - multiSelect ix = over _1 $ fmap (\(ix', (i, b)) -> if ix' == ix then (ix', (i, not b)) else (ix', (i, b))) - --- | Select Field with only single selection possible, along with an editable field -createSelectFieldWithEditable :: (Ord n, Show n) => n -> n -> Lens' s (Either a i) -> (T.Text -> Either ErrorMessage a) -> NonEmpty i -> (i -> T.Text) -> MenuKeyBindings -> SelectField s n -createSelectFieldWithEditable name editFieldName access validator items showItem keyBindings = MenuField access (createSelectInput items showItem singleSelect getSelection name (Just editFieldName) keyBindings) "" Valid name - where - singleSelect :: Int -> (NonEmpty (Int, (i, Bool)), Bool) -> (NonEmpty (Int, (i, Bool)), Bool) - singleSelect ix (ne, a) = (fmap (\(ix', (i, b)) -> if ix' == ix then (ix', (i, True)) else (ix', (i, False))) ne, ix == length ne + 1) - - getSelection (_, Just txt) = either Left (Right . Left) $ validator txt - getSelection (ls, _) = maybe (either Left (Right . Left) $ validator "") (Right . Right . NE.head) $ NE.nonEmpty ls - - -{- ***************** - Utilities -***************** -} - --- | highlights a widget (using List.listSelectedFocusedAttr) -highlighted :: Widget n -> Widget n -highlighted = Brick.withAttr L.listSelectedFocusedAttr - --- | Given a text, crates a highlighted label on focus. An amplifier can be passed -renderAslabel :: T.Text -> Bool -> Widget n -renderAslabel t focus = - if focus - then highlighted $ Brick.txt t - else Brick.txt t - --- | Creates a left align column. --- Example: |- col2 is align dispite the length of col1 --- row1_col1 row1_col2 --- row2_col1_large row2_col2 -leftify :: Int -> Brick.Widget n -> Brick.Widget n -leftify i = Brick.hLimit i . Brick.padRight Brick.Max - --- | Creates a right align column. --- Example: |- col2 is align dispite the length of col1 --- row1_col1 row1_col2 --- row2_col1_large row2_col2 -rightify :: Int -> Brick.Widget n -> Brick.Widget n -rightify i = Brick.hLimit i . Brick.padLeft Brick.Max - --- | render some Text using helpMsgAttr -renderAsHelpMsg :: T.Text -> Widget n -renderAsHelpMsg = Brick.withAttr Attributes.helpMsgAttr . Brick.txt - --- | render some Text using errMsgAttr -renderAsErrMsg :: T.Text -> Widget n -renderAsErrMsg = Brick.withAttr Attributes.errMsgAttr . Brick.txt - --- | Used to create a layer on top of menu -overlayLayer :: T.Text -> Brick.Widget n -> Brick.Widget n -overlayLayer layer_name = - Brick.centerLayer - . Brick.hLimitPercent 50 - . Brick.vLimitPercent 65 - . Brick.withBorderStyle Border.unicode - . Border.borderWithLabel (Brick.txt layer_name) - -{- ***************** - Menu widget -***************** -} - --- | A menu is a list of Fields and a state. Informally we can think about s in terms of the record type returned by --- a form. -data Menu s n - = Menu - { menuFields :: [MenuField s n] -- ^ The datatype representing the list of entries. Precisely, any array-like data type is highly unconvinient. - , menuState :: s - , menuValidator :: s -> Maybe ErrorMessage -- ^ A validator function - , menuButtons :: [Button s n] -- ^ The buttons. Commonly, the handlers for buttons are defined outside the menu handler. - , menuFocusRing :: FocusRing n -- ^ The focus ring with the resource name for each entry and each button, in the order you want to loop them. - , menuKeyBindings :: MenuKeyBindings -- ^ KeyBindings for navigation - , menuName :: n -- ^ The resource Name. - , menuTitle :: T.Text -- ^ Menu title. - } - -makeLensesFor - [ ("menuFields", "menuFieldsL"), ("menuState", "menuStateL"), ("menuValidator", "menuValidatorL") - , ("menuButtons", "menuButtonsL"), ("menuFocusRing", "menuFocusRingL") - , ("menuKeyBindings", "menuKeyBindingsL"), ("menuName", "menuNameL") - , ("menuTitle", "menuTitleL") - ] - ''Menu - -isValidMenu :: Menu s n -> Bool -isValidMenu m = (all isValidField $ menuFields m) - && (case (menuValidator m) (menuState m) of { Nothing -> True; _ -> False }) - -createMenu :: n -> s -> T.Text -> (s -> Maybe ErrorMessage) - -> MenuKeyBindings -> [Button s n] -> [MenuField s n] -> Menu s n -createMenu n initial title validator keys buttons fields = Menu fields initial validator buttons ring keys n title - where ring = F.focusRing $ [field & fieldName | field <- fields] ++ [button & fieldName | button <- buttons] - -handlerMenu :: forall n e s. Eq n => BrickEvent n e -> EventM n (Menu s n) () -handlerMenu ev = do - fields <- use menuFieldsL - kb <- use menuKeyBindingsL - focused <- use $ menuFocusRingL % to F.focusGetCurrent - let focusedField = (\n -> find (\x -> Brick.getName x == n) fields) =<< focused - propagateEvent e = case focused of - Nothing -> pure () - Just n -> do - updated_fields <- updateFields n (VtyEvent e) fields - validator <- use menuValidatorL - state <- use menuStateL - if all isValidField updated_fields - then case validator state of - Nothing -> menuButtonsL %= fmap (fieldStatusL .~ Valid) - Just err -> menuButtonsL %= fmap (fieldStatusL .~ Invalid err) - else menuButtonsL %= fmap (fieldStatusL .~ Invalid "Some fields are invalid") - menuFieldsL .= updated_fields - case (drawFieldOverlay =<< focusedField) of - Just _ -> case ev of - VtyEvent e -> propagateEvent e - _ -> pure () - Nothing -> case ev of - VtyEvent (Vty.EvKey k m) - | KeyCombination k m == kb ^. mKbUpL -> menuFocusRingL %= F.focusPrev - | KeyCombination k m == kb ^. mKbDownL -> menuFocusRingL %= F.focusNext - VtyEvent e -> propagateEvent e - _ -> pure () - where - -- runs the Event with the inner handler of MenuField. - updateFields :: n -> BrickEvent n () -> [MenuField s n] -> EventM n (Menu s n) [MenuField s n] - updateFields n e = traverse $ \x@(MenuField {fieldInput = FieldInput {..}, ..}) -> - if Brick.getName x == n - then do - newb <- Brick.nestEventM' inputState (inputHandler e) - let newField = MenuField {fieldInput = (FieldInput {inputState=newb, ..}) , ..} - case inputValidator newb of - Left errmsg -> pure $ newField & fieldStatusL .~ Invalid errmsg - Right a -> menuStateL % fieldAccesor .= a >> pure (newField & fieldStatusL .~ Valid) - else pure x - - -drawMenu :: (Eq n, Ord n, Show n, Brick.Named (MenuField s n) n) => Menu s n -> [Widget n] -drawMenu menu = - overlays ++ - [Common.frontwardLayer (menu ^. menuTitleL) mainLayer] - where - mainLayer = Brick.vBox - [ Brick.vBox buttonWidgets - , Common.separator - , Brick.vLimit (length fieldLabels) $ Brick.withVScrollBars Brick.OnRight - $ Brick.viewport (menu ^. menuNameL) Brick.Vertical - $ Brick.vBox fieldWidgets - , Brick.txt " " - , Brick.padRight Brick.Max $ - Brick.txt "Press " - <+> Common.keyToWidget (menu ^. menuKeyBindingsL % mKbQuitL) - <+> Brick.txt " to go back, Press Enter to edit the highlighted field" - ] - fieldLabels = [field & fieldLabel | field <- menu ^. menuFieldsL] - buttonLabels = [button & fieldLabel | button <- menu ^. menuButtonsL] - allLabels = fieldLabels ++ buttonLabels - - maxWidth = foldl' max 5 (fmap Brick.textWidth allLabels) - - -- A list of functions which draw a highlighted label with right padding at the left of a widget. - amplifiers = - let labelsWidgets = fmap renderAslabel fieldLabels - in fmap (\f b -> ((rightify (maxWidth + 1) (f b <+> Brick.txt " ")) <+>) ) labelsWidgets - drawFields = fmap drawField amplifiers - fieldWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawFields (menu ^. menuFieldsL) - - buttonAmplifiers = - let buttonAsWidgets = fmap renderAslabel buttonLabels - in fmap (\f b -> ((leftify (maxWidth + 2) . Border.border $ f b) <+>) ) buttonAsWidgets - drawButtons = fmap drawField buttonAmplifiers - buttonWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawButtons (menu ^. menuButtonsL) - - overlays = catMaybes $ fmap drawFieldOverlay (menu ^. menuFieldsL) diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs deleted file mode 100644 index 571bd8010..000000000 --- a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs +++ /dev/null @@ -1,135 +0,0 @@ -{-# 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 #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - -module GHCup.Brick.Widgets.Menus.AdvanceInstall ( - InstallOptions (..), - AdvanceInstallMenu, - create, - handler, - draw, - instBindistL, - instSetL, - instVersionL, - isolateDirL, - forceInstallL, - addConfArgsL, - installTargetsL, -) where - -import GHCup.Types (GHCTargetVersion(..)) -import GHCup.Brick.Widgets.Menu (Menu, MenuKeyBindings) -import qualified GHCup.Brick.Widgets.Menu as Menu -import GHCup.Brick.Common(Name(..)) -import Brick - ( BrickEvent(..), - EventM, - Widget(..)) -import Prelude hiding ( appendFile ) -import Optics.TH (makeLensesFor) -import qualified GHCup.Brick.Common as Common -import URI.ByteString (URI) -import qualified Data.Text as T -import Data.Bifunctor (Bifunctor(..)) -import Data.Function ((&)) -import Optics ((.~)) -import Data.Char (isSpace) -import qualified GHCup.Utils.Parsers as Utils - -data InstallOptions = InstallOptions - { instBindist :: Maybe URI - , instSet :: Bool - , instVersion :: Maybe GHCTargetVersion - -- ^ User specified version to override default - , isolateDir :: Maybe FilePath - , forceInstall :: Bool - , addConfArgs :: [T.Text] - , installTargets :: T.Text - } deriving (Eq, Show) - -makeLensesFor [ - ("instBindist", "instBindistL") - , ("instSet", "instSetL") - , ("instVersion", "instVersionL") - , ("isolateDir", "isolateDirL") - , ("forceInstall", "forceInstallL") - , ("addConfArgs", "addConfArgsL") - , ("installTargets", "installTargetsL") - ] - ''InstallOptions - -type AdvanceInstallMenu = Menu InstallOptions Name - -create :: MenuKeyBindings -> AdvanceInstallMenu -create k = Menu.createMenu AdvanceInstallBox initialState "Advance Install" validator k [ok] fields - where - initialInstallTargets = "install" - initialState = InstallOptions Nothing False Nothing Nothing False [] initialInstallTargets - validator InstallOptions {..} = case (instSet, isolateDir) of - (True, Just _) -> Just "Cannot set active when doing an isolated install" - _ -> Nothing - -- Brick's internal editor representation is [mempty]. - emptyEditor i = T.null i || (i == "\n") - - whenEmpty :: a -> (T.Text -> Either Menu.ErrorMessage a) -> T.Text -> Either Menu.ErrorMessage a - whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval - - uriValidator :: T.Text -> Either Menu.ErrorMessage (Maybe URI) - uriValidator = whenEmpty Nothing (second Just . readUri) - where readUri = first T.pack . Utils.uriParser . T.unpack - - filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) - filepathValidator = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . T.unpack) - - toolVersionValidator :: T.Text -> Either Menu.ErrorMessage (Maybe GHCTargetVersion) - toolVersionValidator = whenEmpty Nothing (bimap T.pack Just . Utils.ghcVersionEither . T.unpack) - - additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] - additionalValidator = Right . T.split isSpace - - fields = - [ Menu.createEditableField (Common.MenuElement Common.UrlEditBox) uriValidator instBindistL - & Menu.fieldLabelL .~ "url" - & Menu.fieldHelpMsgL .~ "Install the specified version from this bindist" - , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) instSetL - & Menu.fieldLabelL .~ "set" - & Menu.fieldHelpMsgL .~ "Set as active version after install" - , Menu.createEditableField (Common.MenuElement Common.ToolVersionBox) toolVersionValidator instVersionL - & Menu.fieldLabelL .~ "version" - & Menu.fieldHelpMsgL .~ "Specify a custom version" - , Menu.createEditableField' initialInstallTargets (Common.MenuElement Common.GHCInstallTargets) Right installTargetsL - & Menu.fieldLabelL .~ "install-targets" - & Menu.fieldHelpMsgL .~ "Specify space separated list of make install targets" - , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathValidator isolateDirL - & Menu.fieldLabelL .~ "isolated" - & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one" - , Menu.createCheckBoxField (Common.MenuElement Common.ForceCheckBox) forceInstallL - & Menu.fieldLabelL .~ "force" - & Menu.fieldHelpMsgL .~ "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)" - , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgsL - & Menu.fieldLabelL .~ "CONFIGURE_ARGS" - & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure" - ] - - ok = Menu.createButtonField (Common.MenuElement Common.OkButton) - & Menu.fieldLabelL .~ "Advance Install" - & Menu.fieldHelpMsgL .~ "Install with options below" - -handler :: BrickEvent Name e -> EventM Name AdvanceInstallMenu () -handler = Menu.handlerMenu - - -draw :: AdvanceInstallMenu -> [Widget Name] -draw = Menu.drawMenu diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs deleted file mode 100644 index 2f476fc63..000000000 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# 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 #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - -module GHCup.Brick.Widgets.Menus.CompileGHC ( - CompileGHCOptions, - CompileGHCMenu, - create, - handler, - draw, - bootstrapGhc, - hadrianGhc, - jobs, - buildConfig, - patches, - crossTarget, - addConfArgs, - setCompile, - overwriteVer, - buildFlavour, - buildSystem, - isolateDir, - gitRef, - installTargets, -) where - -import GHCup.Brick.Widgets.Menu (Menu, MenuKeyBindings) -import qualified GHCup.Brick.Widgets.Menu as Menu -import GHCup.Brick.Common(Name(..)) -import Brick - ( BrickEvent(..), - EventM, - Widget(..)) -import Prelude hiding ( appendFile ) -import Optics.TH (makeLenses) -import qualified GHCup.Brick.Common as Common -import GHCup.Types - ( BuildSystem(..), VersionPattern ) -import URI.ByteString (URI) -import Control.Monad (join) -import qualified Data.Text as T -import Data.Bifunctor (Bifunctor(..)) -import Data.Function ((&)) -import Optics ((.~), iso, (%)) -import Data.Char (isSpace) -import Data.List.NonEmpty ( NonEmpty (..) ) -import qualified Data.List.NonEmpty as NE -import Data.Versions (Version, version) -import System.FilePath (isPathSeparator) -import Control.Applicative (Alternative((<|>))) -import Text.Read (readEither) -import qualified GHCup.Utils.Parsers as Utils -import Text.PrettyPrint.HughesPJClass ( prettyShow ) - -data CompileGHCOptions = CompileGHCOptions - { _bootstrapGhc :: Either Version FilePath - , _hadrianGhc :: Maybe (Either Version FilePath) - , _jobs :: Maybe Int - , _buildConfig :: Maybe FilePath - , _patches :: Maybe (Either FilePath [URI]) - , _crossTarget :: Maybe T.Text - , _addConfArgs :: [T.Text] - , _setCompile :: Bool - , _overwriteVer :: Maybe [VersionPattern] - , _buildFlavour :: Maybe String - , _buildSystem :: Maybe BuildSystem - , _isolateDir :: Maybe FilePath - , _gitRef :: Maybe String - , _installTargets :: T.Text - } deriving (Eq, Show) - -makeLenses ''CompileGHCOptions - -type CompileGHCMenu = Menu CompileGHCOptions Name - -create :: MenuKeyBindings -> [Version] -> CompileGHCMenu -create k availableGHCs = Menu.createMenu CompileGHCBox initialState "Compile GHC" validator k buttons fields - where - initialInstallTargets = "install" - initialState = - CompileGHCOptions - (Right "") - Nothing - Nothing - Nothing - Nothing - Nothing - [] - False - Nothing - Nothing - Nothing - Nothing - Nothing - initialInstallTargets - validator CompileGHCOptions {..} = case (_setCompile, _isolateDir) of - (True, Just _) -> Just "Cannot set active when doing an isolated install" - _ -> case (_buildConfig, _buildSystem) of - (Just _, Just Hadrian) -> Just "Build config can be specified only for make build system" - _ -> Nothing - -- Brick's internal editor representation is [mempty]. - emptyEditor i = T.null i || (i == "\n") - whenEmpty :: a -> (T.Text -> Either Menu.ErrorMessage a) -> T.Text -> Either Menu.ErrorMessage a - whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval - - bootstrapV :: T.Text -> Either Menu.ErrorMessage (Either Version FilePath) - bootstrapV i = - case not $ emptyEditor i of - True -> - let readVersion = bimap (const "Not a valid version") Left (version i) - readPath = do - mfilepath <- filepathV i - case mfilepath of - Nothing -> Left "Invalid path" - Just f -> Right (Right f) - in if T.any isPathSeparator i - then readPath - else readVersion - False -> Left "No version selected / no path specified" - - hadrianstrapV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either Version FilePath)) - hadrianstrapV i' = - let readVersion = bimap (const "Not a valid version") (Just . Left) . version - readPath = bimap T.pack (Just . Right) . Utils.absolutePathParser . T.unpack - in if T.any isPathSeparator i' - then whenEmpty Nothing readPath i' - else whenEmpty Nothing readVersion i' - - versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) - versionV = whenEmpty Nothing (bimap T.pack Just . Utils.overWriteVersionParser . T.unpack) - - jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int) - jobsV = - let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack - in whenEmpty Nothing parseInt - - patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) - patchesV = whenEmpty Nothing readPatches - where - readPatches j = - let - x = second (Just . Left) $ Utils.absolutePathParser (T.unpack j) - y = second (Just . Right) $ traverse (Utils.uriParser . T.unpack) (T.split isSpace j) - in first T.pack $ x <|> y - - filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) - filepathV = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . T.unpack) - - additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] - additionalValidator = Right . T.split isSpace - - showMaybeBuildSystem :: Maybe BuildSystem -> T.Text - showMaybeBuildSystem = \case - Nothing -> "Auto select (prefer hadrian if available, and build config is not specified)" - Just Hadrian -> "hadrian" - Just Make -> "make" - - bootstrapGHCFields = case NE.nonEmpty availableGHCs of - Just ne -> - let bootstrapGhc' = bootstrapGhc % (iso (either (Left . Left) (Left . Right)) (either id Left)) - in [ Menu.createSelectFieldWithEditable (Common.MenuElement Common.BootstrapGhcSelectBox) (Common.MenuElement Common.BootstrapGhcEditBox) bootstrapGhc' bootstrapV ne (T.pack . prettyShow) k - & Menu.fieldLabelL .~ "bootstrap-ghc" - & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to bootstrap with (must be installed)" - & Menu.fieldStatusL .~ Menu.Invalid "No version selected / no path specified" - ] - _ -> [ Menu.createEditableField (Common.MenuElement Common.BootstrapGhcEditBox) bootstrapV bootstrapGhc - & Menu.fieldLabelL .~ "bootstrap-ghc" - & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to bootstrap with (must be installed)" - & Menu.fieldStatusL .~ Menu.Invalid "Invalid empty value" - ] - - hadrianGHCFields = case NE.nonEmpty availableGHCs of - Just ne -> - let hadrianGhc' = hadrianGhc % (iso Left (either id (Just . Left))) - in [ Menu.createSelectFieldWithEditable (Common.MenuElement Common.HadrianGhcSelectBox) (Common.MenuElement Common.HadrianGhcEditBox) hadrianGhc' hadrianstrapV ne (T.pack . prettyShow) k - & Menu.fieldLabelL .~ "hadrian-ghc" - & Menu.fieldHelpMsgL .~ "The GHC version (or full path) that will be used to compile hadrian (must be installed)" - ] - _ -> [ Menu.createEditableField (Common.MenuElement Common.HadrianGhcEditBox) hadrianstrapV hadrianGhc - & Menu.fieldLabelL .~ "hadrian-ghc" - & Menu.fieldHelpMsgL .~ "The GHC version (or full path) that will be used to compile hadrian (must be installed)" - ] - - fields = bootstrapGHCFields ++ hadrianGHCFields ++ - [ Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs - & Menu.fieldLabelL .~ "jobs" - & Menu.fieldHelpMsgL .~ "How many jobs to use for make" - , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile - & Menu.fieldLabelL .~ "set" - & Menu.fieldHelpMsgL .~ "Set as active version after install" - , Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour - & Menu.fieldLabelL .~ "flavour" - & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')" - , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgs - & Menu.fieldLabelL .~ "CONFIGURE_ARGS" - & Menu.fieldHelpMsgL .~ "Additional arguments to compile configure" - , Menu.createEditableField (Common.MenuElement Common.BuildConfigEditBox) filepathV buildConfig - & Menu.fieldLabelL .~ "build config" - & Menu.fieldHelpMsgL .~ "Absolute path to build config file (make build system only)" - , Menu.createEditableField (Common.MenuElement Common.PatchesEditBox) patchesV patches - & Menu.fieldLabelL .~ "patches" - & Menu.fieldHelpMsgL .~ "Either a URI to a patch (https/http/file) or Absolute path to patch directory" - , Menu.createEditableField (Common.MenuElement Common.CrossTargetEditBox) (Right . Just) crossTarget - & Menu.fieldLabelL .~ "cross target" - & Menu.fieldHelpMsgL .~ "Build cross-compiler for this platform" - , Menu.createSelectField (Common.MenuElement Common.BuildSystemEditBox) (buildSystem % (iso Just join)) (Nothing :| [Just Hadrian, Just Make]) showMaybeBuildSystem k - & Menu.fieldLabelL .~ "build system" - & Menu.fieldHelpMsgL .~ "Select the build system" - , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV overwriteVer - & Menu.fieldLabelL .~ "overwrite-version" - & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one. Allows to specify patterns: %v (version), %b (branch name), %h (short commit hash), %H (long commit hash), %g ('git describe' output)" - , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir - & Menu.fieldLabelL .~ "isolated" - & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one" - , Menu.createEditableField (Common.MenuElement Common.GitRefEditBox) (Right . Just . T.unpack) gitRef - & Menu.fieldLabelL .~ "git-ref" - & Menu.fieldHelpMsgL .~ "The git commit/branch/ref to build from" - , Menu.createEditableField' initialInstallTargets (Common.MenuElement Common.GHCInstallTargets) Right installTargets - & Menu.fieldLabelL .~ "install-targets" - & Menu.fieldHelpMsgL .~ "Specify space separated list of make install targets" - ] - - buttons = [ - Menu.createButtonField (Common.MenuElement Common.OkButton) - & Menu.fieldLabelL .~ "Compile" - & Menu.fieldHelpMsgL .~ "Compile GHC from source with options below\nRequired fields: bootstrap-ghc" - & Menu.fieldStatusL .~ Menu.Invalid "bootstrap GHC is mandatory" - ] - -handler :: BrickEvent Name e -> EventM Name CompileGHCMenu () -handler = Menu.handlerMenu - - -draw :: CompileGHCMenu -> [Widget Name] -draw = Menu.drawMenu diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs deleted file mode 100644 index 97b8711be..000000000 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs +++ /dev/null @@ -1,203 +0,0 @@ -{-# 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 #-} -{-# OPTIONS_GHC -Wno-incomplete-patterns #-} - -module GHCup.Brick.Widgets.Menus.CompileHLS ( - CompileHLSOptions, - CompileHLSMenu, - create, - handler, - draw, - jobs, - setCompile, - updateCabal, - overwriteVer, - isolateDir, - cabalProject, - cabalProjectLocal, - patches, - targetGHCs, - cabalArgs, - gitRef, -) -where - -import GHCup.Brick.Widgets.Menu (Menu, MenuKeyBindings) -import qualified GHCup.Brick.Widgets.Menu as Menu -import GHCup.Brick.Common(Name(..)) -import Brick - ( BrickEvent(..), - EventM, - Widget(..)) -import Prelude hiding ( appendFile ) -import Optics.TH (makeLenses) -import qualified GHCup.Brick.Common as Common -import GHCup.Types (VersionPattern, ToolVersion(..)) -import URI.ByteString (URI) -import qualified Data.Text as T -import Data.Bifunctor (Bifunctor(..)) -import qualified Data.List.NonEmpty as NE -import Data.Function ((&)) -import Optics ((.~)) -import Data.Char (isSpace) -import Data.Versions -import Control.Applicative (Alternative((<|>))) -import Text.Read (readEither) -import qualified GHCup.Utils.Parsers as Utils -import Text.PrettyPrint.HughesPJClass ( prettyShow ) - -data CompileHLSOptions = CompileHLSOptions - { _jobs :: Maybe Int - , _setCompile :: Bool - , _updateCabal :: Bool - , _overwriteVer :: Maybe [VersionPattern] - , _isolateDir :: Maybe FilePath - , _cabalProject :: Maybe (Either FilePath URI) - , _cabalProjectLocal :: Maybe URI - , _patches :: Maybe (Either FilePath [URI]) - , _targetGHCs :: [ToolVersion] - , _cabalArgs :: [T.Text] - , _gitRef :: Maybe String - } deriving (Eq, Show) - -makeLenses ''CompileHLSOptions - -type CompileHLSMenu = Menu CompileHLSOptions Name - -create :: MenuKeyBindings -> [Version] -> CompileHLSMenu -create k availableGHCs = Menu.createMenu CompileGHCBox initialState "Compile HLS" validator k buttons fields - where - initialState = - CompileHLSOptions - Nothing - False - False - Nothing - Nothing - Nothing - Nothing - Nothing - [] - [] - Nothing - - validator CompileHLSOptions {..} = case (_setCompile, _isolateDir) of - (True, Just _) -> Just "Cannot set active when doing an isolated install" - _ -> if null _targetGHCs - then Just "Specify at least one valid target GHC" - else Nothing - -- Brick's internal editor representation is [mempty]. - emptyEditor i = T.null i || (i == "\n") - whenEmpty :: a -> (T.Text -> Either Menu.ErrorMessage a) -> T.Text -> Either Menu.ErrorMessage a - whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval - - readUri :: T.Text -> Either Menu.ErrorMessage URI - readUri = first T.pack . Utils.uriParser . T.unpack - - cabalProjectV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath URI)) - cabalProjectV = whenEmpty Nothing parseFileOrUri - where - parseFileOrUri i = - let x = bimap T.unpack Right (readUri i) - y = Right . Left . T.unpack $ i - in bimap T.pack Just $ x <|> y - - cabalProjectLocalV :: T.Text -> Either Menu.ErrorMessage (Maybe URI) - cabalProjectLocalV = whenEmpty Nothing (second Just . readUri) - - ghcVersionTagEither :: T.Text -> Either Menu.ErrorMessage [ToolVersion] - ghcVersionTagEither = whenEmpty [] $ first T.pack . traverse (Utils.ghcVersionTagEither . T.unpack) . T.split isSpace - - overWriteVersionParser :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) - overWriteVersionParser = whenEmpty Nothing $ bimap T.pack Just . Utils.overWriteVersionParser . T.unpack - - jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int) - jobsV = - let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack - in whenEmpty Nothing parseInt - - patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) - patchesV = whenEmpty Nothing readPatches - where - readPatches j = - let - x = second (Just . Left) $ Utils.absolutePathParser (T.unpack j) - y = second (Just . Right) $ traverse (Utils.uriParser . T.unpack) (T.split isSpace j) - in first T.pack $ x <|> y - - filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) - filepathV = whenEmpty Nothing (bimap T.pack Just . Utils.isolateParser . T.unpack) - - additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] - additionalValidator = Right . T.split isSpace - - targetGHCsField = - let label = "target GHC(s)" - in case NE.nonEmpty (fmap ToolVersion availableGHCs) of - Just ne -> Menu.createMultiSelectField (Common.MenuElement Common.TargetGhcEditBox) targetGHCs ne (T.pack . prettyShow) k - & Menu.fieldLabelL .~ label - & Menu.fieldHelpMsgL .~ "GHC versions to compile for (Press Enter to edit)" - & Menu.fieldStatusL .~ Menu.Invalid "No version selected" - _ -> Menu.createEditableField (Common.MenuElement Common.TargetGhcEditBox) ghcVersionTagEither targetGHCs - & Menu.fieldLabelL .~ label - & Menu.fieldHelpMsgL .~ "space separated list of GHC versions to compile for" - & Menu.fieldStatusL .~ Menu.Invalid "Invalid empty value" - - fields = - [ targetGHCsField - , Menu.createCheckBoxField (Common.MenuElement Common.UpdateCabalCheckBox) updateCabal - & Menu.fieldLabelL .~ "cabal update" - & Menu.fieldHelpMsgL .~ "Run 'cabal update' before the build" - , Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs - & Menu.fieldLabelL .~ "jobs" - & Menu.fieldHelpMsgL .~ "How many jobs to use for make" - , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile - & Menu.fieldLabelL .~ "set" - & Menu.fieldHelpMsgL .~ "Set as active version after install" - , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator cabalArgs - & Menu.fieldLabelL .~ "CABAL_ARGS" - & Menu.fieldHelpMsgL .~ "Additional arguments to cabal install" - , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir - & Menu.fieldLabelL .~ "isolated" - & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one" - , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) overWriteVersionParser overwriteVer - & Menu.fieldLabelL .~ "overwrite version" - & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one. Allows to specify patterns: %v (version), %b (branch name), %h (short commit hash), %H (long commit hash), %g ('git describe' output)" - , Menu.createEditableField (Common.MenuElement Common.PatchesEditBox) patchesV patches - & Menu.fieldLabelL .~ "patches" - & Menu.fieldHelpMsgL .~ "Either a URI to a patch (https/http/file) or Absolute path to patch directory" - , Menu.createEditableField (Common.MenuElement Common.CabalProjectEditBox) cabalProjectV cabalProject - & Menu.fieldLabelL .~ "cabal project" - & Menu.fieldHelpMsgL .~ "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme." - , Menu.createEditableField (Common.MenuElement Common.CabalProjectLocalEditBox) cabalProjectLocalV cabalProjectLocal - & Menu.fieldLabelL .~ "cabal project local" - & Menu.fieldHelpMsgL .~ "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over." - , Menu.createEditableField (Common.MenuElement Common.GitRefEditBox) (Right . Just . T.unpack) gitRef - & Menu.fieldLabelL .~ "git-ref" - & Menu.fieldHelpMsgL .~ "The git commit/branch/ref to build from" - ] - - buttons = [ - Menu.createButtonField (Common.MenuElement Common.OkButton) - & Menu.fieldLabelL .~ "Compile" - & Menu.fieldHelpMsgL .~ "Compile HLS from source with options below\nRequired fields: target GHC(s)" - ] - -handler :: BrickEvent Name e -> EventM Name CompileHLSMenu () -handler = Menu.handlerMenu - - -draw :: CompileHLSMenu -> [Widget Name] -draw = Menu.drawMenu diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs deleted file mode 100644 index 7807cecf1..000000000 --- a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs +++ /dev/null @@ -1,83 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module GHCup.Brick.Widgets.Menus.Context (ContextMenu, create, draw, handler) where - -import Brick ( - Widget (..), BrickEvent, EventM, - ) -import Data.Function ((&)) -import Prelude hiding (appendFile) - -import Data.Versions (prettyVer) -import GHCup.List ( ListResult(..) ) -import GHCup.Types (Tool (..)) - -import qualified GHCup.Brick.Common as Common -import qualified GHCup.Brick.Widgets.Menu as Menu -import GHCup.Brick.Common (Name (..)) -import GHCup.Brick.Widgets.Menu (Menu, MenuKeyBindings) -import qualified Brick.Widgets.Core as Brick -import qualified Brick.Widgets.Border as Border -import qualified Brick.Focus as F -import Brick.Widgets.Core ((<+>)) - -import Optics (to) -import Optics.Operators ((.~), (^.)) -import Optics.Optic ((%)) -import Data.Foldable (foldl') - -type ContextMenu = Menu ListResult Name - -create :: ListResult -> MenuKeyBindings -> ContextMenu -create lr keyBindings = Menu.createMenu Common.ContextBox lr "" validator keyBindings buttons [] - where - advInstallButton = - Menu.createButtonField (MenuElement Common.AdvanceInstallButton) - & Menu.fieldLabelL .~ "Install" - & Menu.fieldHelpMsgL .~ "Advance Installation Settings" - compileGhcButton = - Menu.createButtonField (MenuElement Common.CompileGHCButton) - & Menu.fieldLabelL .~ "Compile" - & Menu.fieldHelpMsgL .~ "Compile GHC from source" - compileHLSButton = - Menu.createButtonField (MenuElement Common.CompileHLSButton) - & Menu.fieldLabelL .~ "Compile" - & Menu.fieldHelpMsgL .~ "Compile HLS from source" - buttons = - case lTool lr of - GHC -> [advInstallButton, compileGhcButton] - HLS -> [advInstallButton, compileHLSButton] - _ -> [advInstallButton] - validator = const Nothing - -draw :: ContextMenu -> Widget Name -draw menu = - Common.frontwardLayer - ("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ menu ^. Menu.menuStateL)) - $ Brick.vBox - [ Brick.vBox buttonWidgets - , Brick.txt " " - , Brick.padRight Brick.Max $ - Brick.txt "Press " - <+> Common.keyToWidget (menu ^. Menu.menuKeyBindingsL % Menu.mKbQuitL) - <+> Brick.txt " to go back" - ] - where - buttonLabels = [button & Menu.fieldLabel | button <- menu ^. Menu.menuButtonsL] - maxWidth = foldl' max 5 (fmap Brick.textWidth buttonLabels) - - buttonAmplifiers = - let buttonAsWidgets = fmap Menu.renderAslabel buttonLabels - in fmap (\f b -> ((Menu.leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets - drawButtons = fmap Menu.drawField buttonAmplifiers - buttonWidgets = zipWith (F.withFocusRing (menu ^. Menu.menuFocusRingL)) drawButtons (menu ^. Menu.menuButtonsL) - tool_str = - case menu ^. Menu.menuStateL % to lTool of - GHC -> "GHC" - GHCup -> "GHCup" - Cabal -> "Cabal" - HLS -> "HLS" - Stack -> "Stack" - -handler :: BrickEvent Name e -> EventM Name ContextMenu () -handler = Menu.handlerMenu diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs deleted file mode 100644 index 35e214d1d..000000000 --- a/lib-tui/GHCup/Brick/Widgets/Navigation.hs +++ /dev/null @@ -1,155 +0,0 @@ -{-# 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 listIx 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 - active = if b then Common.enableScreenReader (Common.ListItem lTool listIx) else id - in Brick.clickable (Common.ListItem lTool listIx) $ hooray $ active $ 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 Experimental = Just $ Brick.withAttr Attributes.latestNightlyAttr $ Brick.str "experimental" - 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 ' ') - -instance SectionList.ListItemSectionNameIndex Common.Name where - getListItemSectionNameIndex = \case - Common.ListItem tool ix -> Just (Common.Singular tool, ix) - _ -> Nothing diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index f1399c15d..1d53dbda2 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -15,71 +15,53 @@ This module contains the entrypoint for the brick application and nothing else. module GHCup.BrickMain where -import GHCup.List ( ListResult (..)) import GHCup.Types - ( Settings(noColor), Tool (GHC), - AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings(..) ) + ( Settings(noColor), + AppState(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.App.Common as Common +import qualified GHCup.Brick.App.Navigation as Navigation +import qualified GHCup.Brick.Widgets.BaseWidget as BaseWidget import qualified GHCup.Brick.Attributes as Attributes -import qualified GHCup.Brick.BrickState as AppState -import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu -import qualified GHCup.Brick.Widgets.SectionList as Navigation -import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall -import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC -import GHCup.Brick.Widgets.Menu (MenuKeyBindings(..)) import qualified Brick import qualified Graphics.Vty as Vty -import Control.Monad.Reader ( ReaderT(runReaderT) ) +import Control.Monad +import Control.Monad.Reader ( ReaderT(runReaderT), liftIO ) import Data.Functor ( ($>) ) -import Data.IORef (writeIORef) -import Prelude hiding ( appendFile ) +import Data.List.NonEmpty ( NonEmpty (..) ) import System.Exit ( ExitCode(ExitFailure), exitWith ) -import qualified Data.Text as T -import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS - - brickMain :: AppState -> IO () brickMain s = do - writeIORef Actions.settings' s - - eAppData <- Actions.getAppData (Just $ ghcupInfo s) - case eAppData of - Right ad -> do - let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing - current_element = Navigation.sectionListSelectedElement initial_list - exit_key = - let KeyBindings {..} = keyBindings s - in MenuKeyBindings { mKbUp = bUp, mKbDown = bDown, mKbQuit = bQuit} - case current_element of - Nothing -> do - flip runReaderT s $ logError "Error building app state: empty ResultList" - exitWith $ ExitFailure 2 - Just (_, e) -> - let initapp = - BrickApp.app - (Attributes.defaultAttributes $ noColor $ settings s) - (Attributes.dimAttributes $ noColor $ settings s) - installedGHCs = fmap lVer $ - filter (\(ListResult {..}) -> lInstalled && lTool == GHC && lCross == Nothing) (Common._lr ad) - initstate = - AppState.BrickState ad - Common.defaultAppSettings - initial_list - (ContextMenu.create e exit_key) - (AdvanceInstall.create exit_key) - (CompileGHC.create exit_key installedGHCs) - (CompileHLS.create exit_key installedGHCs) - (keyBindings s) - Common.Navigation - in Brick.defaultMain initapp initstate - $> () - Left e -> do - flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) + ls <- Actions.getListResults s + case ls of + [] -> do + flip runReaderT s $ logError "Error building app state: empty [ListResult]" exitWith $ ExitFailure 2 + (x:xs) -> do + let nav_widget = Navigation.create (x :| xs) + (Attributes.dimAttributes $ noColor $ settings s) + (keyBindings s) s + let initapp = brickApp (Attributes.defaultAttributes $ noColor $ settings s) + Brick.defaultMain initapp nav_widget $> () + +brickApp :: Brick.AttrMap -> Brick.App Navigation.Navigation () Common.Name +brickApp attrs = + Brick.App { appDraw = BaseWidget.drawBaseWidget + , appHandleEvent = void . BaseWidget.handleEventBaseWidget + , appStartEvent = setupVtyMode + , appAttrMap = const attrs + , appChooseCursor = Brick.showFirstCursor + } + +-- | Enable mouse mode if supported by the terminal +setupVtyMode :: Brick.EventM Common.Name s () +setupVtyMode = do + vty <- Brick.getVtyHandle + let output = Vty.outputIface vty + when (Vty.supportsMode output Vty.Mouse) $ + liftIO $ Vty.setMode output Vty.Mouse True