From add75de909886f6a2dd79385490e345837e6a23a Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 10 Jan 2024 07:14:59 +0100 Subject: [PATCH 01/33] Move tui code into its own library. --- app/ghcup/Main.hs | 3 +- ghcup.cabal | 52 +++ hie.yaml | 4 + lib-tui/GHCup/Brick/Actions.hs | 462 +++++++++++++++++++++ lib-tui/GHCup/Brick/App.hs | 118 ++++++ lib-tui/GHCup/Brick/Attributes.hs | 82 ++++ lib-tui/GHCup/Brick/BrickState.hs | 46 ++ lib-tui/GHCup/Brick/Common.hs | 112 +++++ lib-tui/GHCup/Brick/Widgets/KeyInfo.hs | 80 ++++ lib-tui/GHCup/Brick/Widgets/Navigation.hs | 148 +++++++ lib-tui/GHCup/Brick/Widgets/SectionList.hs | 192 +++++++++ lib-tui/GHCup/Brick/Widgets/Tutorial.hs | 84 ++++ lib-tui/GHCup/BrickMain.hs | 60 +++ 13 files changed, 1442 insertions(+), 1 deletion(-) create mode 100644 lib-tui/GHCup/Brick/Actions.hs create mode 100644 lib-tui/GHCup/Brick/App.hs create mode 100644 lib-tui/GHCup/Brick/Attributes.hs create mode 100644 lib-tui/GHCup/Brick/BrickState.hs create mode 100644 lib-tui/GHCup/Brick/Common.hs create mode 100644 lib-tui/GHCup/Brick/Widgets/KeyInfo.hs create mode 100644 lib-tui/GHCup/Brick/Widgets/Navigation.hs create mode 100644 lib-tui/GHCup/Brick/Widgets/SectionList.hs create mode 100644 lib-tui/GHCup/Brick/Widgets/Tutorial.hs create mode 100644 lib-tui/GHCup/BrickMain.hs diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index fd5fa06f..c0dc84e2 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -11,7 +11,8 @@ module Main where #if defined(BRICK) -import BrickMain ( brickMain ) +-- import BrickMain ( brickMain ) +import GHCup.BrickMain (brickMain) #endif import qualified GHCup.GHC as GHC diff --git a/ghcup.cabal b/ghcup.cabal index 3873442e..e115d61d 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -322,6 +322,57 @@ library ghcup-optparse else build-depends: unix ^>=2.7 || ^>=2.8 +library ghcup-tui + import: app-common-depends + exposed-modules: + GHCup.BrickMain + GHCup.Brick.Widgets.Navigation + GHCup.Brick.Widgets.Tutorial + GHCup.Brick.Widgets.KeyInfo + GHCup.Brick.Widgets.SectionList + GHCup.Brick.Actions + GHCup.Brick.App + GHCup.Brick.BrickState + GHCup.Brick.Attributes + GHCup.Brick.Common + + hs-source-dirs: lib-tui + default-language: Haskell2010 + default-extensions: + LambdaCase + MultiWayIf + NamedFieldPuns + PackageImports + RecordWildCards + ScopedTypeVariables + StrictData + TupleSections + + ghc-options: + -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns + -fwarn-incomplete-record-updates + + build-depends: + , ghcup + , ghcup-optparse + , optics ^>=0.4 + , brick ^>=2.1 + , transformers ^>=0.5 + , vty ^>=6.0 + , optics ^>=0.4 + + if flag(internal-downloader) + cpp-options: -DINTERNAL_DOWNLOADER + + if flag(tui) + cpp-options: -DBRICK + + if os(windows) + cpp-options: -DIS_WINDOWS + + else + build-depends: unix ^>=2.7 + executable ghcup import: app-common-depends main-is: Main.hs @@ -345,6 +396,7 @@ executable ghcup build-depends: , ghcup , ghcup-optparse + , ghcup-tui if flag(internal-downloader) cpp-options: -DINTERNAL_DOWNLOADER diff --git a/hie.yaml b/hie.yaml index 2c739206..ec8d0caf 100644 --- a/hie.yaml +++ b/hie.yaml @@ -2,6 +2,10 @@ cradle: cabal: - component: "ghcup:lib:ghcup" path: ./lib + - component: "ghcup:lib:ghcup-optparse" + path: ./lib-opt + - component: "ghcup:lib:ghcup-tui" + path: ./lib-tui - component: "ghcup:exe:ghcup" path: ./app/ghcup - component: "ghcup:lib:ghcup-optparse" diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs new file mode 100644 index 00000000..3521da93 --- /dev/null +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -0,0 +1,462 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module GHCup.Brick.Actions where + +import GHCup +import GHCup.Download +import GHCup.Errors +import GHCup.Types.Optics ( getDirs, getPlatformReq ) +import GHCup.Types hiding ( LeanAppState(..) ) +import GHCup.Utils +import GHCup.OptParse.Common (logGHCPostRm) +import GHCup.Prelude ( decUTF8Safe ) +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prompts +import GHCup.Brick.Common (BrickData(..), BrickSettings(..), Name(..), Mode(..)) +import qualified GHCup.Brick.Common as Common +import GHCup.Brick.BrickState +import GHCup.Brick.Widgets.SectionList +import GHCup.Brick.Widgets.Navigation (BrickInternalState) + +import qualified Brick +import qualified Brick.Widgets.List as L +import qualified Brick.Focus as F +import Codec.Archive +import Control.Applicative +import Control.Exception.Safe +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Except +import Control.Monad.Trans.Resource +import Data.Bool +import Data.Functor +import Data.Function ( (&), on) +import Data.List +import Data.Maybe +import Data.IORef (IORef, readIORef, newIORef, modifyIORef) +import Data.Versions hiding (Lens') +import Haskus.Utils.Variant.Excepts +import Prelude hiding ( appendFile ) +import System.Exit +import System.IO.Unsafe +import System.Process ( system ) +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import URI.ByteString + +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy as L +import qualified Graphics.Vty as Vty +import qualified Data.Vector as V +import System.Environment (getExecutablePath) +#if !IS_WINDOWS +import GHCup.Prelude.File +import System.FilePath +import qualified System.Posix.Process as SPP +#endif + +import Optics.State (use) +import Optics.State.Operators ( (.=)) +import Optics.Operators ((.~),(%~)) +import Optics.Getter (view) + + +{- Core Logic. + +This module defines the IO actions we can execute within the Brick App: + - Install + - Set + - UnInstall + - Launch the Changelog + +-} + +-- | Update app data and list internal state based on new evidence. +-- This synchronises @BrickInternalState@ with @BrickData@ +-- and @BrickSettings@. +updateList :: BrickData -> BrickState -> BrickState +updateList appD BrickState{..} = + let newInternalState = constructList appD _appSettings (Just _appState) + in BrickState { _appState = newInternalState + , _appData = appD + , _appSettings = _appSettings + , _appKeys = _appKeys + , _mode = Navigation + } + +constructList :: BrickData + -> BrickSettings + -> Maybe BrickInternalState + -> BrickInternalState +constructList appD settings = + replaceLR (filterVisible (_showAllVersions settings)) + (_lr appD) + +-- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0 +selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState +selectBy tool predicate internal_state = + let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state) + tool_lens = sectionL (Singular tool) + in internal_state + & sectionListFocusRingL .~ new_focus + & tool_lens %~ L.listMoveTo 0 -- We move to 0 first + & tool_lens %~ L.listFindBy predicate -- The lookup by the predicate. + +-- | Select the latests GHC tool +selectLatest :: BrickInternalState -> BrickInternalState +selectLatest = selectBy GHC (elem Latest . lTag) + + +-- | Replace the @appState@ or construct it based on a filter function +-- and a new @[ListResult]@ evidence. +-- When passed an existing @appState@, tries to keep the selected element. +replaceLR :: (ListResult -> Bool) + -> [ListResult] + -> Maybe BrickInternalState + -> BrickInternalState +replaceLR filterF list_result s = + let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e) + newVec = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] + newSectionList = sectionList AllTools newVec 1 + in case oldElem of + Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList + Nothing -> selectLatest newSectionList + where + toolEqual e1 e2 = + lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 + + +filterVisible :: Bool -> ListResult -> Bool +filterVisible v e | lInstalled e = True + | v + , Nightly `notElem` lTag e = True + | not v + , Old `notElem` lTag e + , Nightly `notElem` lTag e = True + | otherwise = (Old `notElem` lTag e) && + (Nightly `notElem` lTag e) + +-- | Suspend the current UI and run an IO action in terminal. If the +-- IO action returns a Left value, then it's thrown as userError. +withIOAction :: (Ord n, Eq n) + => ( (Int, ListResult) -> ReaderT AppState IO (Either String a)) + -> Brick.EventM n BrickState () +withIOAction action = do + as <- Brick.get + case sectionListSelectedElement (view appState as) of + Nothing -> pure () + Just (curr_ix, e) -> do + Brick.suspendAndResume $ do + settings <- readIORef settings' + flip runReaderT settings $ action (curr_ix, e) >>= \case + Left err -> liftIO $ putStrLn ("Error: " <> err) + Right _ -> liftIO $ putStrLn "Success" + getAppData Nothing >>= \case + Right data' -> do + putStrLn "Press enter to continue" + _ <- getLine + pure (updateList data' as) + Left err -> throwIO $ userError err + +install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => (Int, ListResult) + -> m (Either String ()) +install' (_, ListResult {..}) = do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + + let run = + runResourceT + . runE + @'[ AlreadyInstalled + , ArchiveResult + , UnknownArchive + , FileDoesNotExistError + , CopyError + , NoDownload + , NotInstalled + , BuildFailed + , TagNotFound + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , DirNotEmpty + , NoUpdate + , TarDirDoesNotExist + , FileAlreadyExistsError + , ProcessError + , ToolShadowed + , UninstallFailed + , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch + ] + + run (do + ce <- liftIO $ fmap (either (const Nothing) Just) $ + try @_ @SomeException $ getExecutablePath >>= canonicalizePath + dirs <- lift getDirs + case lTool of + GHC -> do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls + liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce) + Cabal -> do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls + liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) + GHCup -> do + let vi = snd <$> getLatest dls GHCup + liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) + HLS -> do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls + liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) + Stack -> do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls + liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) + ) + >>= \case + VRight (vi, Dirs{..}, Just ce) -> do + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + case lTool of + GHCup -> do +#if !IS_WINDOWS + up <- liftIO $ fmap (either (const Nothing) Just) + $ try @_ @SomeException $ canonicalizePath (binDir "ghcup" <.> exeExt) + when ((normalise <$> up) == Just (normalise ce)) $ + -- TODO: track cli arguments of previous invocation + liftIO $ SPP.executeFile ce False ["tui"] Nothing +#else + logInfo "Please restart 'ghcup' for the changes to take effect" +#endif + _ -> pure () + pure $ Right () + VRight (vi, _, _) -> do + forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg + logInfo "Please restart 'ghcup' for the changes to take effect" + pure $ Right () + VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () + VLeft (V NoUpdate) -> pure $ Right () + VLeft e -> pure $ Left $ prettyHFError e <> "\n" + <> "Also check the logs in ~/.ghcup/logs" + + +set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => (Int, ListResult) + -> m (Either String ()) +set' input@(_, ListResult {..}) = do + settings <- liftIO $ readIORef settings' + + let run = + flip runReaderT settings + . runResourceT + . runE + @'[ AlreadyInstalled + , ArchiveResult + , UnknownArchive + , FileDoesNotExistError + , CopyError + , NoDownload + , NotInstalled + , BuildFailed + , TagNotFound + , DigestError + , ContentLengthError + , GPGError + , DownloadFailed + , DirNotEmpty + , NoUpdate + , TarDirDoesNotExist + , FileAlreadyExistsError + , ProcessError + , ToolShadowed + , UninstallFailed + , MergeFileTreeError + , NoCompatiblePlatform + , GHCup.Errors.ParseError + , UnsupportedSetupCombo + , DistroNotFound + , NoCompatibleArch + ] + + run (do + case lTool of + GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> () + Cabal -> liftE $ setCabal lVer $> () + HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> () + Stack -> liftE $ setStack lVer $> () + GHCup -> do + promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: " + case promptAnswer of + PromptYes -> do + void $ liftE $ upgradeGHCup Nothing False False + PromptNo -> pure () + ) + >>= \case + VRight _ -> pure $ Right () + VLeft e -> case e of + (V (NotInstalled tool _)) -> do + promptAnswer <- getUserPromptResponse userPrompt + case promptAnswer of + PromptYes -> do + res <- install' input + case res of + (Left err) -> pure $ Left err + (Right _) -> do + logInfo "Setting now..." + set' input + + PromptNo -> pure $ Left (prettyHFError e) + where + userPrompt = L.toStrict . B.toLazyText . B.fromString $ + "This Version of " + <> show tool + <> " you are trying to set is not installed.\n" + <> "Would you like to install it first? [Y/N]: " + + _ -> pure $ Left (prettyHFError e) + + + +del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) + => (Int, ListResult) + -> m (Either String ()) +del' (_, ListResult {..}) = do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + + let run = runE @'[NotInstalled, UninstallFailed] + + run (do + let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls + case lTool of + GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi + Cabal -> liftE $ rmCabalVer lVer $> vi + HLS -> liftE $ rmHLSVer lVer $> vi + Stack -> liftE $ rmStackVer lVer $> vi + GHCup -> pure Nothing + ) + >>= \case + VRight vi -> do + when (lTool == GHC) $ logGHCPostRm (mkTVer lVer) + forM_ (_viPostRemove =<< vi) $ \msg -> + logInfo msg + pure $ Right () + VLeft e -> pure $ Left (prettyHFError e) + + +changelog' :: (MonadReader AppState m, MonadIO m) + => (Int, ListResult) + -> m (Either String ()) +changelog' (_, ListResult {..}) = do + AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + case getChangeLog dls lTool (ToolVersion lVer) of + Nothing -> pure $ Left $ + "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer) + Just uri -> do + case _rPlatform pfreq of + Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing + Windows -> do + let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri) + c <- liftIO $ system $ args + case c of + (ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args] + ExitSuccess -> pure $ Right () + + >>= \case + Right _ -> pure $ Right () + Left e -> pure $ Left $ prettyHFError e + + +settings' :: IORef AppState +{-# NOINLINE settings' #-} +settings' = unsafePerformIO $ do + dirs <- getAllDirs + let loggerConfig = LoggerConfig { lcPrintDebug = False + , consoleOutter = \_ -> pure () + , fileOutter = \_ -> pure () + , fancyColors = True + } + newIORef $ AppState defaultSettings + dirs + defaultKeyBindings + (GHCupInfo mempty mempty Nothing) + (PlatformRequest A_64 Darwin Nothing) + loggerConfig + + +getGHCupInfo :: IO (Either String GHCupInfo) +getGHCupInfo = do + settings <- readIORef settings' + + r <- + flip runReaderT settings + . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError] + $ do + pfreq <- lift getPlatformReq + liftE $ getDownloadsF pfreq + + case r of + VRight a -> pure $ Right a + VLeft e -> pure $ Left (prettyHFError e) + + +getAppData :: Maybe GHCupInfo + -> IO (Either String BrickData) +getAppData mgi = runExceptT $ do + r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi + liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r }) + settings <- liftIO $ readIORef settings' + + flip runReaderT settings $ do + lV <- listVersions Nothing [] False True (Nothing, Nothing) + pure $ BrickData (reverse lV) + +-- + +keyHandlers :: KeyBindings + -> [ ( KeyCombination + , BrickSettings -> String + , Brick.EventM Name BrickState () + ) + ] +keyHandlers KeyBindings {..} = + [ (bQuit, const "Quit" , Brick.halt) + , (bInstall, const "Install" , withIOAction install') + , (bUninstall, const "Uninstall", withIOAction del') + , (bSet, const "Set" , withIOAction set') + , (bChangelog, const "ChangeLog", withIOAction changelog') + , ( bShowAllVersions + , \BrickSettings {..} -> + if _showAllVersions then "Don't show all versions" else "Show all versions" + , hideShowHandler' (not . _showAllVersions) + ) + , (bUp, const "Up", Common.zoom appState moveUp) + , (bDown, const "Down", Common.zoom appState moveDown) + , (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo) + ] + where + --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () + hideShowHandler' f = do + app_settings <- use appSettings + let + vers = f app_settings + newAppSettings = app_settings & Common.showAllVersions .~ vers + ad <- use appData + current_app_state <- use appState + appSettings .= newAppSettings + appState .= constructList ad newAppSettings (Just current_app_state) \ No newline at end of file diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs new file mode 100644 index 00000000..eaa0923c --- /dev/null +++ b/lib-tui/GHCup/Brick/App.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module defines the brick App. The pattern is very simple: + +- Pattern match on the Mode +- Dispatch drawing/events to the corresponding widget/s + +In general each widget should know how to draw itself and how to handle its own events, so this +module should only contain: + +- how to draw non-widget information. For example the footer +- how to change between modes (widgets aren't aware of the whole application state) + +-} + +module GHCup.Brick.App where + +import GHCup.Types ( AppState(AppState, keyBindings), KeyCombination(KeyCombination) ) +import GHCup.Brick.Common ( Name(..), Mode(..)) +import qualified GHCup.Brick.Common as Common +import GHCup.Brick.BrickState (BrickState(..), appState, mode, appKeys, appSettings) +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Widgets.Navigation as Navigation +import qualified GHCup.Brick.Widgets.Tutorial as Tutorial +import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo +import qualified GHCup.Brick.Actions as Actions + +import Brick + ( BrickEvent(VtyEvent), + App(..), + AttrMap, + EventM, + Widget(..), + (<=>)) +import qualified Brick +import Control.Monad.Reader + ( void, MonadIO(liftIO) ) +import Data.List ( find, intercalate) +import Data.IORef (readIORef) +import Prelude hiding ( appendFile ) + +import qualified Graphics.Vty as Vty + +import Optics.State (use) +import Optics.State.Operators ( (.=)) +import Optics.Operators ((^.)) +import qualified Data.Text as T + +app :: AttrMap -> AttrMap -> App BrickState () Name +app attrs dimAttrs = + App { appDraw = drawUI dimAttrs + , appHandleEvent = eventHandler + , appStartEvent = return () + , appAttrMap = const attrs + , appChooseCursor = Brick.showFirstCursor + } + +drawUI :: AttrMap -> BrickState -> [Widget Name] +drawUI dimAttrs st = + let + footer = Brick.withAttr Attributes.helpAttr + . Brick.txtWrap + . T.pack + . foldr1 (\x y -> x <> " " <> y) + . fmap (\(KeyCombination key mods, pretty_setting, _) + -> intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) <> ":" <> pretty_setting (st ^. appSettings) + ) + $ Actions.keyHandlers (st ^. appKeys) + navg = Navigation.draw dimAttrs (st ^. appState) <=> footer + in case st ^. mode of + Navigation -> [navg] + Tutorial -> [Tutorial.draw, navg] + KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] +-- InstallPopUp -> [drawCompilePopUp (st ^. popUp), navg] + +-- | On q, go back to navigation. +-- On Enter, to go to tutorial +keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState () +keyInfoHandler ev = case ev of + VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation + VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial + _ -> pure () + +-- | On q, go back to navigation. Else, do nothing +tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () +tutorialHandler ev = + case ev of + VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation + _ -> pure () + +-- | Tab/Arrows to navigate. +navigationHandler :: BrickEvent Name e -> EventM Name BrickState () +navigationHandler ev = do + AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings' + case ev of + inner_event@(VtyEvent (Vty.EvKey key _)) -> + case find (\(key', _, _) -> key' == KeyCombination key []) (Actions.keyHandlers kb) of + Just (_, _, handler) -> handler + Nothing -> void $ Common.zoom appState $ Navigation.handler inner_event + inner_event -> Common.zoom appState $ Navigation.handler inner_event + + +eventHandler :: BrickEvent Name e -> EventM Name BrickState () +eventHandler ev = do + m <- use mode + case m of + KeyInfo -> keyInfoHandler ev + Tutorial -> tutorialHandler ev + Navigation -> navigationHandler ev +-- InstallPopUp -> compilePopUpHandler ev diff --git a/lib-tui/GHCup/Brick/Attributes.hs b/lib-tui/GHCup/Brick/Attributes.hs new file mode 100644 index 00000000..194bbed9 --- /dev/null +++ b/lib-tui/GHCup/Brick/Attributes.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module defined the attributes. Despite of brick's capability to have a hierarchy of attributes, here +we go for the most-simple-approach: a plain hierarchy +-} + +module GHCup.Brick.Attributes where + +import Brick ( AttrMap) +import qualified Brick +import qualified Brick.Widgets.List as L +import qualified Graphics.Vty as Vty + +defaultAttributes :: Bool -> AttrMap +defaultAttributes no_color = Brick.attrMap + Vty.defAttr + [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) + , (L.listSelectedAttr , Vty.defAttr) + , (notInstalledAttr , Vty.defAttr `withForeColor` Vty.red) + , (setAttr , Vty.defAttr `withForeColor` Vty.green) + , (installedAttr , Vty.defAttr `withForeColor` Vty.green) + , (recommendedAttr , Vty.defAttr `withForeColor` Vty.green) + , (hlsPoweredAttr , Vty.defAttr `withForeColor` Vty.green) + , (latestAttr , Vty.defAttr `withForeColor` Vty.yellow) + , (latestPrereleaseAttr , Vty.defAttr `withForeColor` Vty.red) + , (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red) + , (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red) + , (nightlyAttr , Vty.defAttr `withForeColor` Vty.red) + , (compiledAttr , Vty.defAttr `withForeColor` Vty.blue) + , (strayAttr , Vty.defAttr `withForeColor` Vty.blue) + , (dayAttr , Vty.defAttr `withForeColor` Vty.blue) + , (helpAttr , Vty.defAttr `withStyle` Vty.italic) + , (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite) + ] + where + withForeColor | no_color = const + | otherwise = Vty.withForeColor + + withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo + | otherwise = Vty.withBackColor + + withStyle = Vty.withStyle + + +notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr:: Brick.AttrName +latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr:: Brick.AttrName +compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr:: Brick.AttrName + +notInstalledAttr = Brick.attrName "not-installed" +setAttr = Brick.attrName "set" +installedAttr = Brick.attrName "installed" +recommendedAttr = Brick.attrName "recommended" +hlsPoweredAttr = Brick.attrName "hls-powered" +latestAttr = Brick.attrName "latest" +latestPrereleaseAttr = Brick.attrName "latest-prerelease" +latestNightlyAttr = Brick.attrName "latest-nightly" +prereleaseAttr = Brick.attrName "prerelease" +nightlyAttr = Brick.attrName "nightly" +compiledAttr = Brick.attrName "compiled" +strayAttr = Brick.attrName "stray" +dayAttr = Brick.attrName "day" +helpAttr = Brick.attrName "help" +hoorayAttr = Brick.attrName "hooray" + +dimAttributes :: Bool -> AttrMap +dimAttributes no_color = Brick.attrMap + (Vty.defAttr `Vty.withStyle` Vty.dim) + [ (Brick.attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ?? + , (Brick.attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) + ] + where + withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo + | otherwise = Vty.withBackColor diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs new file mode 100644 index 00000000..5356a6e8 --- /dev/null +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE InstanceSigs #-} + +{- +This module contains the BrickState. One could be tempted to include this data structure in GHCup.Brick.Common, +but it is better to make a separated module in order to avoid cyclic dependencies. + +This happens because the BrickState is sort of a container for all widgets, +but widgets depends on common functionality, hence: + + BrickState `depends on` Widgets.XYZ `depends on` Common + +The linear relation above breaks if BrickState is defined in Common. + +-} + +module GHCup.Brick.BrickState where + +import GHCup.Types ( KeyBindings ) +import GHCup.Brick.Common ( BrickData(..), BrickSettings(..), Mode(..)) +import GHCup.Brick.Widgets.Navigation ( BrickInternalState) +import Optics.TH (makeLenses) + + +data BrickState = BrickState + { _appData :: BrickData + , _appSettings :: BrickSettings + , _appState :: BrickInternalState + , _appKeys :: KeyBindings + , _mode :: Mode + } + --deriving Show + +makeLenses ''BrickState diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs new file mode 100644 index 00000000..2f6d33d4 --- /dev/null +++ b/lib-tui/GHCup/Brick/Common.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# OPTIONS_GHC -Wno-missing-signatures #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE InstanceSigs #-} + +{- +This module contains common values used across the library. Crucially it contains two important types for the brick app: + +- Name: List all resources (widgets) used by the app. see https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst#resource-names +- Mode: Use to dispatch events and drawings. see: https://github.com/jtdaugherty/brick/issues/476#issuecomment-1629151920 + +-} + +module GHCup.Brick.Common where + +import GHCup.List ( ListResult ) +import GHCup.Types ( Tool ) +import Prelude hiding ( appendFile ) +import qualified Graphics.Vty as Vty +import Optics.TH (makeLenses) +import Optics.Lens (toLensVL) +import qualified Brick + +-- | Some verbosity. A FocusRing (to loop through advance options), needs an set of resource names to be able to +-- dtermine focus. See https://hackage.haskell.org/package/brick-2.1.1/docs/Brick-Focus.html#t:FocusRing +{- data PopUpResources + = UrlEditBox + | SetCheckBox + | IsolateEditBox + | ForceCheckBox + | AdditionalEditBox + | RegularInstallButton + | AdvanceInstallButton + | CancellInstallButton + deriving (Eq, Ord, Show) +-} + +-- | Name data type. Uniquely identifies each widget in the TUI. +-- some constructors might end up unused, but still is a good practise +-- to have all of them defined, just in case +data Name = AllTools -- ^ The main list widget + | Singular Tool -- ^ The particular list for each tool + | KeyInfoBox -- ^ The text box widget with action informacion + | TutorialBox -- ^ The tutorial widget +-- | PopUpBox -- ^ The whole popUp widget +-- | PopUpElement PopUpResources -- ^ each element in the popUp + deriving (Eq, Ord, Show) + +-- | Mode type. It helps to dispatch events to different handlers. +data Mode = Navigation | KeyInfo | Tutorial deriving (Eq, Show, Ord) + +installedSign :: String +#if IS_WINDOWS +installedSign = "I " +#else +installedSign = "✓ " +#endif + +setSign :: String +#if IS_WINDOWS +setSign = "IS" +#else +setSign = "✔✔" +#endif + +notInstalledSign :: String +#if IS_WINDOWS +notInstalledSign = "X " +#else +notInstalledSign = "✗ " +#endif + +showKey :: Vty.Key -> String +showKey (Vty.KChar c) = [c] +showKey Vty.KUp = "↑" +showKey Vty.KDown = "↓" +showKey key = tail (show key) + +showMod :: Vty.Modifier -> String +showMod = tail . show + + +-- I refuse to give this a type signature. + +-- | Given a lens, zoom on it. It is needed because Brick uses microlens but GHCup uses optics. +zoom l = Brick.zoom (toLensVL l) + +data BrickData = BrickData + { _lr :: [ListResult] + } + deriving Show + +makeLenses ''BrickData + +data BrickSettings = BrickSettings { _showAllVersions :: Bool} + --deriving Show + +makeLenses ''BrickSettings + +defaultAppSettings :: BrickSettings +defaultAppSettings = BrickSettings { _showAllVersions = False} diff --git a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs new file mode 100644 index 00000000..bc89acfc --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +A very simple information-only widget with no handler. +-} + +module GHCup.Brick.Widgets.KeyInfo where + +import GHCup.Types ( KeyBindings(..), KeyCombination(KeyCombination) ) +import qualified GHCup.Brick.Common as Common + + +import Brick + ( Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( borderWithLabel) +import Brick.Widgets.Border.Style ( unicode ) +import Brick.Widgets.Center ( center, centerLayer ) +import Data.List ( intercalate ) +import Prelude hiding ( appendFile ) + + + +draw :: KeyBindings -> Widget Common.Name +draw KeyBindings {..} = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) + in centerLayer + $ Brick.hLimitPercent 75 + $ Brick.vLimitPercent 50 + $ Brick.withBorderStyle unicode + $ borderWithLabel (Brick.txt "Key Actions") + $ Brick.vBox [ + center $ + mkTextBox [ + Brick.hBox [ + Brick.txt "Press " + , keyToWidget bUp, Brick.txt " and ", keyToWidget bDown + , Brick.txtWrap " to navigate the list of tools" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bInstall + , Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bSet + , Brick.txtWrap " to set a tool as the one for use" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bUninstall + , Brick.txtWrap " to uninstall a tool" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bChangelog + , Brick.txtWrap " to open the tool's changelog. It will open a web browser" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bShowAllVersions + , Brick.txtWrap " to show older version of each tool" + ] + ] + ] + <=> Brick.hBox [Brick.txt "Press q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"] diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs new file mode 100644 index 00000000..f4826ebf --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Navigation.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- Brick's navigation widget: +It is a FocusRing over many list's. Each list contains the information for each tool. Each list has an internal name (for Brick's runtime) +and a label which we can use in rendering. This data-structure helps to reuse Brick.Widget.List and to navegate easily across + +-} + + +module GHCup.Brick.Widgets.Navigation (BrickInternalState, create, handler, draw) where + +import GHCup.List ( ListResult(..) ) +import GHCup.Types + ( GHCTargetVersion(GHCTargetVersion), + Tool(..), + Tag(..), + tVerToText, + tagToString ) +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.Widgets.SectionList as SectionList +import Brick + ( BrickEvent(..), + Padding(Max, Pad), + AttrMap, + EventM, + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( hBorder, borderWithLabel) +import Brick.Widgets.Border.Style ( unicode ) +import Brick.Widgets.Center ( center ) +import qualified Brick.Widgets.List as L +import Data.List ( intercalate, sort ) +import Data.Maybe ( mapMaybe ) +import Data.Vector ( Vector) +import Data.Versions ( prettyPVP, prettyVer ) +import Prelude hiding ( appendFile ) +import qualified Data.Text as T +import qualified Data.Vector as V + + +type BrickInternalState = SectionList.SectionList Common.Name ListResult + +-- | How to create a navigation widget +create :: Common.Name -- The name of the section list + -> [(Common.Name, Vector ListResult)] -- a list of tuples (section name, collection of elements) + -> Int -- The height of each item in a list. Commonly 1 + -> BrickInternalState +create = SectionList.sectionList + +-- | How the navigation handler handle events +handler :: BrickEvent Common.Name e -> EventM Common.Name BrickInternalState () +handler = SectionList.handleGenericListEvent + +-- | How to draw the navigation widget +draw :: AttrMap -> BrickInternalState -> Widget Common.Name +draw dimAttrs section_list + = Brick.padBottom Max + ( Brick.withBorderStyle unicode + $ borderWithLabel (Brick.str "GHCup") + (center (header <=> hBorder <=> renderList' section_list)) + ) + where + header = + minHSize 2 Brick.emptyWidget + <+> Brick.padLeft (Pad 2) (minHSize 6 $ Brick.str "Tool") + <+> minHSize 15 (Brick.str "Version") + <+> Brick.padLeft (Pad 1) (minHSize 25 $ Brick.str "Tags") + <+> Brick.padLeft (Pad 5) (Brick.str "Notes") + renderList' bis = + let allElements = V.concatMap L.listElements $ SectionList.sectionListElements bis + minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) allElements + minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) allElements + in Brick.withDefAttr L.listAttr $ SectionList.renderSectionList (renderItem minTagSize minVerSize) True bis + renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} = + let marks = if + | lSet -> (Brick.withAttr Attributes.setAttr $ Brick.str Common.setSign) + | lInstalled -> (Brick.withAttr Attributes.installedAttr $ Brick.str Common.installedSign) + | otherwise -> (Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign) + ver = case lCross of + Nothing -> T.unpack . prettyVer $ lVer + Just c -> T.unpack (c <> "-" <> prettyVer lVer) + dim + | lNoBindist && not lInstalled + && not b -- TODO: overloading dim and active ignores active + -- so we hack around it here + = Brick.updateAttrMap (const dimAttrs) . Brick.withAttr (Brick.attrName "no-bindist") + | otherwise = id + hooray + | elem Latest lTag' && not lInstalled = + Brick.withAttr Attributes.hoorayAttr + | otherwise = id + in hooray $ dim + ( marks + <+> Brick.padLeft (Pad 2) + ( minHSize 6 + (printTool lTool) + ) + <+> minHSize minVerSize (Brick.str ver) + <+> (let l = mapMaybe printTag $ sort lTag' + in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l + then Brick.emptyWidget + else foldr1 (\x y -> x <+> Brick.str "," <+> y) l + ) + <+> Brick.padLeft (Pad 5) + ( let notes = printNotes listResult + in if null notes + then Brick.emptyWidget + else foldr1 (\x y -> x <+> Brick.str "," <+> y) notes + ) + <+> Brick.vLimit 1 (Brick.fill ' ') + ) + + printTag Recommended = Just $ Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended" + printTag Latest = Just $ Brick.withAttr Attributes.latestAttr $ Brick.str "latest" + printTag Prerelease = Just $ Brick.withAttr Attributes.prereleaseAttr $ Brick.str "prerelease" + printTag Nightly = Just $ Brick.withAttr Attributes.nightlyAttr $ Brick.str "nightly" + printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp'')) + printTag Old = Nothing + printTag LatestPrerelease = Just $ Brick.withAttr Attributes.latestPrereleaseAttr $ Brick.str "latest-prerelease" + printTag LatestNightly = Just $ Brick.withAttr Attributes.latestNightlyAttr $ Brick.str "latest-nightly" + printTag (UnknownTag t) = Just $ Brick.str t + + printTool Cabal = Brick.str "cabal" + printTool GHC = Brick.str "GHC" + printTool GHCup = Brick.str "GHCup" + printTool HLS = Brick.str "HLS" + printTool Stack = Brick.str "Stack" + + printNotes ListResult {..} = + (if hlsPowered then [Brick.withAttr Attributes.hlsPoweredAttr $ Brick.str "hls-powered"] else mempty + ) + ++ (if lStray then [Brick.withAttr Attributes.strayAttr $ Brick.str "stray"] else mempty) + ++ (case lReleaseDay of + Nothing -> mempty + Just d -> [Brick.withAttr Attributes.dayAttr $ Brick.str (show d)]) + + minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') \ No newline at end of file diff --git a/lib-tui/GHCup/Brick/Widgets/SectionList.hs b/lib-tui/GHCup/Brick/Widgets/SectionList.hs new file mode 100644 index 00000000..071b1a36 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/SectionList.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE InstanceSigs #-} + +{- A general system for lists with sections + +Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing +the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). + +- To build a SectionList use the safe constructor sectionList +- To access sections use the lens provider sectionL and the name of the section you'd like to access +- You can modify Brick.Widget.List.GenericList within GenericSectionList via sectionL but do not + modify the vector length + +-} + + +module GHCup.Brick.Widgets.SectionList where + + +import Brick + ( BrickEvent(VtyEvent, MouseDown), + EventM, + Size(..), + Widget(..), + ViewportType (Vertical), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( hBorder) +import qualified Brick.Widgets.List as L +import Brick.Focus (FocusRing) +import qualified Brick.Focus as F +import Data.Function ( (&)) +import Data.Maybe ( fromMaybe ) +import Data.Vector ( Vector ) +import qualified GHCup.Brick.Common as Common +import Prelude hiding ( appendFile ) + +import qualified Graphics.Vty as Vty +import qualified Data.Vector as V + +import Optics.TH (makeLensesFor) +import Optics.State (use) +import Optics.State.Operators ( (%=), (<%=)) +import Optics.Operators ((.~), (^.)) +import Optics.Lens (Lens', lens) + +data GenericSectionList n t e + = GenericSectionList + { sectionListFocusRing :: FocusRing n -- ^ The FocusRing for all sections + , sectionListElements :: !(Vector (L.GenericList n t e)) -- ^ A vector of brick's built-in list + , sectionListName :: n -- ^ The section list name + } + +makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListElements", "sectionListElementsL"), ("sectionListName", "sectionListNameL")] ''GenericSectionList + +type SectionList n e = GenericSectionList n V.Vector e + + +-- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses. +sectionList :: Foldable t + => n -- The name of the section list + -> [(n, t e)] -- a list of tuples (section name, collection of elements) + -> Int + -> GenericSectionList n t e +sectionList name elements height + = GenericSectionList + { sectionListFocusRing = F.focusRing [section_name | (section_name, _) <- elements] + , sectionListElements = V.fromList [L.list section_name els height | (section_name, els) <- elements] + , sectionListName = name + } +-- | This lens constructor, takes a name and looks if a section has such a name. +-- Used to dispatch events to sections. It is a partial function only meant to +-- be used with the FocusRing inside GenericSectionList +sectionL :: Eq n => n -> Lens' (GenericSectionList n t e) (L.GenericList n t e) +sectionL section_name = lens g s + where is_section_name = (== section_name) . L.listName + g section_list = + let elms = section_list ^. sectionListElementsL + zeroth = elms V.! 0 -- TODO: This crashes for empty vectors. + in fromMaybe zeroth (V.find is_section_name elms) + s gl@(GenericSectionList _ elms _) list = + case V.findIndex is_section_name elms of + Nothing -> gl + Just i -> let new_elms = V.update elms (V.fromList [(i, list)]) + in gl & sectionListElementsL .~ new_elms + +moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () +moveDown = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> do -- If it is the last element, move to the first element of the next focus; else, just handle regular list event. + current_list <- use (sectionL l) + let current_idx = L.listSelected current_list + list_length = current_list & length + if current_idx == Just (list_length - 1) + then do + new_focus <- sectionListFocusRingL <%= F.focusNext + case F.focusGetCurrent new_focus of + Nothing -> pure () -- |- Optic.Zoom.zoom doesn't typecheck but Lens.Micro.Mtl.zoom does. It is re-exported by Brick + Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToBeginning) + else Common.zoom (sectionL l) $ Brick.modify L.listMoveDown + +moveUp :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () +moveUp = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> do -- If it is the first element, move to the last element of the prev focus; else, just handle regular list event. + current_list <- use (sectionL l) + let current_idx = L.listSelected current_list + if current_idx == Just 0 + then do + new_focus <- sectionListFocusRingL <%= F.focusPrev + case F.focusGetCurrent new_focus of + Nothing -> pure () + Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToEnd) + else Common.zoom (sectionL l) $ Brick.modify L.listMoveUp + +-- | Handle events for list cursor movement. Events handled are: +-- +-- * Up (up arrow key). If first element of section, then jump prev section +-- * Down (down arrow key). If last element of section, then jump next section +-- * Page Up (PgUp) +-- * Page Down (PgDown) +-- * Go to next section (Tab) +-- * Go to prev section (BackTab) +handleGenericListEvent :: (Foldable t, L.Splittable t, Ord n) + => BrickEvent n a + -> EventM n (GenericSectionList n t e) () +handleGenericListEvent (VtyEvent (Vty.EvResize _ _)) = pure () +handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab [])) = sectionListFocusRingL %= F.focusPrev +handleGenericListEvent (MouseDown _ Vty.BScrollDown _ _) = moveDown +handleGenericListEvent (MouseDown _ Vty.BScrollUp _ _) = moveUp +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KDown [])) = moveDown +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KUp [])) = moveUp +handleGenericListEvent (VtyEvent ev) = do + ring <- use sectionListFocusRingL + case F.focusGetCurrent ring of + Nothing -> pure () + Just l -> Common.zoom (sectionL l) $ L.handleListEvent ev +handleGenericListEvent _ = pure () + +-- This re-uses Brick.Widget.List.renderList +renderSectionList :: (Traversable t, Ord n, Show n, Eq n, L.Splittable t) + => (Bool -> e -> Widget n) -- ^ Rendering function of the list element, True for the selected element + -> Bool -- ^ Whether the section list has focus + -> GenericSectionList n t e -- ^ The section list to render + -> Widget n +renderSectionList render_elem section_focus (GenericSectionList focus elms sl_name) = + Brick.Widget Brick.Greedy Brick.Greedy $ do + c <- Brick.getContext + let -- A section is focused if the whole thing is focused, and the inner list has focus + section_is_focused l = section_focus && (Just (L.listName l) == F.focusGetCurrent focus) + -- We need to limit the widget size when the length of the list is higher than the size of the terminal + limit = min (Brick.windowHeight c) (Brick.availHeight c) + s_idx = fromMaybe 0 $ V.findIndex section_is_focused elms + render_inner_list has_focus l = Brick.vLimit (length l) $ L.renderList (\b -> render_elem (b && has_focus)) has_focus l + (widget, off) = + V.ifoldl' (\wacc i list -> + let has_focus_list = section_is_focused list + (!acc_widget, !acc_off) = wacc + new_widget = if i == 0 then render_inner_list has_focus_list list else hBorder <=> render_inner_list has_focus_list list + new_off + | i < s_idx = 1 + L.listItemHeight list * length list + | i == s_idx = 1 + L.listItemHeight list * fromMaybe 0 (L.listSelected list) + | otherwise = 0 + in (acc_widget <=> new_widget, acc_off + new_off) + ) + (Brick.emptyWidget, 0) + elms + Brick.render $ Brick.viewport sl_name Brick.Vertical $ Brick.translateBy (Brick.Location (0, min 0 (limit-off))) widget + +-- | Equivalent to listSelectedElement +sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) +sectionListSelectedElement generic_section_list = do + current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent + let current_section = generic_section_list ^. sectionL current_focus + L.listSelectedElement current_section diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs new file mode 100644 index 00000000..447f1d07 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +A very simple information-only widget with no handler. +-} + +module GHCup.Brick.Widgets.Tutorial (draw) where + +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.Attributes as Attributes + +import Brick + ( Padding(Max), + Widget(..), + (<+>), + (<=>)) +import qualified Brick +import Brick.Widgets.Border ( hBorder, borderWithLabel) +import Brick.Widgets.Border.Style ( unicode ) +import Brick.Widgets.Center ( center, centerLayer ) +import Prelude hiding ( appendFile ) + + + +draw :: Widget Common.Name +draw = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + txt_separator = hBorder <+> Brick.str " o " <+> hBorder + in centerLayer + $ Brick.hLimitPercent 75 + $ Brick.vLimitPercent 50 + $ Brick.withBorderStyle unicode + $ borderWithLabel (Brick.txt "Tutorial") + $ Brick.vBox + (fmap center + [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] + , txt_separator + , mkTextBox [ + Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.installedAttr (Brick.str Common.installedSign) + , Brick.txtWrap " means that the tool is installed but not in used" + ] + , Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.setAttr (Brick.str Common.setSign) + , Brick.txtWrap " means that the tool is installed and in used" + ] + , Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr Attributes.notInstalledAttr (Brick.str Common.notInstalledSign) + , Brick.txt " means that the tool isn't installed" + ] + ] + , txt_separator + , mkTextBox [ + Brick.hBox [ + Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended" + , Brick.txtWrap " tag is based on community adoption, known bugs, etc... So It makes this version the least experimental" + ] + , Brick.hBox [ + Brick.withAttr Attributes.latestAttr $ Brick.str "latest" + , Brick.txtWrap " tag is for the latest distributed version of the tool" + ] + , Brick.hBox [ + Brick.withAttr Attributes.latestAttr $ Brick.str "hls-powered" + , Brick.txt " denotes the compiler version supported by the currently set (" + , Brick.withAttr Attributes.setAttr (Brick.str Common.setSign) + , Brick.txt ") hls" + ] + , Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" + ] + , Brick.txt " " + ]) + <=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial") diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs new file mode 100644 index 00000000..fcb65546 --- /dev/null +++ b/lib-tui/GHCup/BrickMain.hs @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{- +This module contains the entrypoint for the brick application and nothing else. + +-} + +module GHCup.BrickMain where + +import GHCup.Types + ( Settings(noColor), + AppState(ghcupInfo, settings, keyBindings, loggerConfig) ) +import GHCup.Prelude.Logger ( logError ) +import qualified GHCup.Brick.Actions as Actions +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.App as BrickApp +import qualified GHCup.Brick.Attributes as Attributes +import qualified GHCup.Brick.BrickState as AppState +import qualified Brick + +import Control.Monad.Reader ( ReaderT(runReaderT) ) +import Data.Functor ( ($>) ) +import Data.IORef (writeIORef) +import Prelude hiding ( appendFile ) +import System.Exit ( ExitCode(ExitFailure), exitWith ) + +import qualified Data.Text as T + + + +brickMain :: AppState + -> IO () +brickMain s = do + writeIORef Actions.settings' s + + eAppData <- Actions.getAppData (Just $ ghcupInfo s) + case eAppData of + Right ad -> + Brick.defaultMain + (BrickApp.app (Attributes.defaultAttributes (noColor $ settings s)) + (Attributes.dimAttributes (noColor $ settings s))) + (AppState.BrickState ad + Common.defaultAppSettings + (Actions.constructList ad Common.defaultAppSettings Nothing) + (keyBindings (s :: AppState)) + Common.Navigation + + ) + $> () + Left e -> do + flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) + exitWith $ ExitFailure 2 From d59b37c2602a917d7a3700117d3983a2607206fc Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Thu, 15 Feb 2024 08:12:00 +0100 Subject: [PATCH 02/33] Create Menu system. Similar to Brick.Forms --- ghcup.cabal | 1 + lib-tui/GHCup/Brick/Actions.hs | 1 - lib-tui/GHCup/Brick/Attributes.hs | 10 +- lib-tui/GHCup/Brick/Common.hs | 12 +- lib-tui/GHCup/Brick/Widgets/Menu.hs | 359 ++++++++++++++++++++++++++++ 5 files changed, 378 insertions(+), 5 deletions(-) create mode 100644 lib-tui/GHCup/Brick/Widgets/Menu.hs diff --git a/ghcup.cabal b/ghcup.cabal index e115d61d..fc1024b4 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -330,6 +330,7 @@ library ghcup-tui GHCup.Brick.Widgets.Tutorial GHCup.Brick.Widgets.KeyInfo GHCup.Brick.Widgets.SectionList + GHCup.Brick.Widgets.Menu GHCup.Brick.Actions GHCup.Brick.App GHCup.Brick.BrickState diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 3521da93..aa16dc5a 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -31,7 +31,6 @@ import GHCup.Brick.Widgets.Navigation (BrickInternalState) import qualified Brick import qualified Brick.Widgets.List as L import qualified Brick.Focus as F -import Codec.Archive import Control.Applicative import Control.Exception.Safe #if !MIN_VERSION_base(4,13,0) diff --git a/lib-tui/GHCup/Brick/Attributes.hs b/lib-tui/GHCup/Brick/Attributes.hs index 194bbed9..46333af0 100644 --- a/lib-tui/GHCup/Brick/Attributes.hs +++ b/lib-tui/GHCup/Brick/Attributes.hs @@ -40,6 +40,8 @@ defaultAttributes no_color = Brick.attrMap , (dayAttr , Vty.defAttr `withForeColor` Vty.blue) , (helpAttr , Vty.defAttr `withStyle` Vty.italic) , (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite) + , (helpMsgAttr , Vty.defAttr `withForeColor` Vty.brightBlack) + , (errMsgAttr , Vty.defAttr `withForeColor` Vty.red) ] where withForeColor | no_color = const @@ -51,9 +53,9 @@ defaultAttributes no_color = Brick.attrMap withStyle = Vty.withStyle -notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr:: Brick.AttrName -latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr:: Brick.AttrName -compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr:: Brick.AttrName +notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr :: Brick.AttrName +latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr :: Brick.AttrName +compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr, helpMsgAttr, errMsgAttr :: Brick.AttrName notInstalledAttr = Brick.attrName "not-installed" setAttr = Brick.attrName "set" @@ -70,6 +72,8 @@ strayAttr = Brick.attrName "stray" dayAttr = Brick.attrName "day" helpAttr = Brick.attrName "help" hoorayAttr = Brick.attrName "hooray" +helpMsgAttr = Brick.attrName "helpMsg" +errMsgAttr = Brick.attrName "errMsg" dimAttributes :: Bool -> AttrMap dimAttributes no_color = Brick.attrMap diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 2f6d33d4..b5055b30 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -25,12 +25,15 @@ This module contains common values used across the library. Crucially it contain module GHCup.Brick.Common where import GHCup.List ( ListResult ) -import GHCup.Types ( Tool ) +import GHCup.Types ( Tool, KeyCombination (KeyCombination) ) +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.Border as Border +import Brick ((<+>)) -- | Some verbosity. A FocusRing (to loop through advance options), needs an set of resource names to be able to -- dtermine focus. See https://hackage.haskell.org/package/brick-2.1.1/docs/Brick-Focus.html#t:FocusRing @@ -90,6 +93,13 @@ showKey key = tail (show key) showMod :: Vty.Modifier -> String showMod = tail . show +-- | Given a KeyComb, produces a string widget with and user friendly text +keyToWidget :: KeyCombination -> Brick.Widget n +keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (showKey key : (showMod <$> mods)) + +-- | A section separator with max width. Looks like this: -------- o -------- +separator :: Brick.Widget n +separator = Border.hBorder <+> Brick.str " o " <+> Border.hBorder -- I refuse to give this a type signature. diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs new file mode 100644 index 00000000..9efa1bbf --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -0,0 +1,359 @@ +{-# 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.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 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) +import GHCup.Types (KeyCombination) +import Optics (Lens', to, lens) +import Optics.Operators ( (^.), (.~) ) +import Data.Foldable (foldl') + + +-- | 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 + +-- | 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 + -> b + -> (Widget n -> Widget n) + -> Widget n -- ^ How to draw the input, 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 + + +makeLensesFor + [ ("fieldLabel", "fieldLabelL") + , ("fieldStatus", "fieldStatusL") + ] + ''MenuField + +-- | 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 , ..} + +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 = Border.border . Brick.padRight (Brick.Pad 1) . Brick.padLeft (Brick.Pad 2) + drawBool b = + if b + then border . Brick.withAttr Attributes.installedAttr $ Brick.str Common.installedSign + else border . Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign + checkBoxRender focus _ help check f = + let core = f $ drawBool check + in if focus + then core + else core <+> (Brick.padLeft (Brick.Pad 1) . centerV . 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) => n -> (T.Text -> Either ErrorMessage a) -> FieldInput a (Edit.Editor T.Text n) n +createEditableInput name validator = FieldInput initEdit validateEditContent "" drawEdit Edit.handleEditorEvent + where + drawEdit focus errMsg help edi amp = + let + borderBox = amp . Border.border . Brick.padRight Brick.Max + editorRender = Edit.renderEditor (Brick.txt . T.unlines) focus edi + in case errMsg of + Valid -> + if Edit.getEditContents edi == [mempty] + then borderBox $ renderAsHelpMsg help + else borderBox editorRender + Invalid msg -> + if focus + then borderBox editorRender + else borderBox $ renderAsErrMsg msg + validateEditContent = validator . T.unlines . Edit.getEditContents + initEdit = Edit.editorText name (Just 1) "" + +createEditableField :: (Eq n, Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> Lens' s a -> EditableField s n +createEditableField name validator access = MenuField access input "" Valid name + where + input = createEditableInput name validator + +{- ***************** + Button widget +***************** -} + +type Button = MenuField + +createButtonInput :: FieldInput () () n +createButtonInput = FieldInput () Right "" drawButton (const $ pure ()) + where drawButton _ _ help _ amp = amp . centerV . renderAsHelpMsg $ help + +createButtonField :: n -> Button s n +createButtonField = MenuField emptyLens createButtonInput "" Valid + +{- ***************** + 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 + +-- | center a line in three rows. +centerV :: Widget n -> Widget n +centerV = Brick.padTopBottom 1 + +-- | 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 + +{- ***************** + 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 + , 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. + , menuExitKey :: KeyCombination -- ^ The key to exit the Menu + , menuName :: n -- ^ The resource Name. + } + + +makeLensesFor + [ ("menuFields", "menuFieldsL"), ("menuState", "menuStateL") + , ("menuButtons", "menuButtonsL"), ("menuFocusRing", "menuFocusRingL") + , ("menuExitKey", "menuExitKeyL"), ("menuName", "menuNameL") + ] + ''Menu + +createMenu :: n -> s -> KeyCombination -> [Button s n] -> [MenuField s n] -> Menu s n +createMenu n initial exitK buttons fields = Menu fields initial buttons ring exitK n + 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 = + case ev of + VtyEvent (Vty.EvKey (Vty.KChar '\t') []) -> menuFocusRingL %= F.focusNext + VtyEvent (Vty.EvKey Vty.KBackTab []) -> menuFocusRingL %= F.focusPrev + VtyEvent (Vty.EvKey Vty.KDown []) -> menuFocusRingL %= F.focusNext + VtyEvent (Vty.EvKey Vty.KUp []) -> menuFocusRingL %= F.focusPrev + VtyEvent e -> do + focused <- use $ menuFocusRingL % to F.focusGetCurrent + fields <- use menuFieldsL + case focused of + Nothing -> pure () + Just n -> do + updated_fields <- updateFields n (VtyEvent e) fields + menuFieldsL .= updated_fields + _ -> pure () + where + updateFields :: n -> BrickEvent n () -> [MenuField s n] -> EventM n (Menu s n) [MenuField s n] + updateFields n e [] = pure [] + updateFields n e (x@(MenuField {fieldInput = i@(FieldInput {..}) , ..}):xs) = + 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):xs + Right a -> menuStateL % fieldAccesor .= a >> pure ((newField & fieldStatusL .~ Valid):xs) + else fmap (x:) (updateFields n e xs) + + +drawMenu :: (Eq n, Ord n, Show n, Brick.Named (MenuField s n) n) => Menu s n -> Widget n +drawMenu menu = + Brick.vBox + [ Brick.vBox buttonWidgets + , Common.separator + , 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 ^. menuExitKeyL) + <+> Brick.txt " to go back" + ] + where + drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) = + let input = inputRender focus fieldStatus inputHelp inputState (amp focus) + in if focus + then Brick.visible input + else input + + 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 (\b -> renderAslabel b) fieldLabels + in fmap (\f b -> ((centerV . leftify (maxWidth + 10) $ f b) <+>) ) labelsWidgets + drawFields = fmap drawField amplifiers + fieldWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawFields (menu ^. menuFieldsL) + + buttonAmplifiers = + let buttonAsWidgets = fmap (\b -> renderAslabel b) buttonLabels + in fmap (\f b -> ((leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets + drawButtons = fmap drawField buttonAmplifiers + buttonWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawButtons (menu ^. menuButtonsL) + + From eeb2b3fade5ce92b66f3ab9200a0be67738ef1f2 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Tue, 27 Feb 2024 19:19:00 +0100 Subject: [PATCH 03/33] Extract common functionality --- lib-tui/GHCup/Brick/Common.hs | 43 ++++++++++++++++--------- lib-tui/GHCup/Brick/Widgets/KeyInfo.hs | 26 ++++++--------- lib-tui/GHCup/Brick/Widgets/Tutorial.hs | 17 ++++------ 3 files changed, 43 insertions(+), 43 deletions(-) diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index b5055b30..1bb3045e 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -13,6 +13,7 @@ {-# 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: @@ -34,20 +35,23 @@ import Optics.Lens (toLensVL) import qualified Brick 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 0 +pattern AdvanceInstallButton = ResourceId 100 +pattern CompilieButton = ResourceId 101 --- | Some verbosity. A FocusRing (to loop through advance options), needs an set of resource names to be able to --- dtermine focus. See https://hackage.haskell.org/package/brick-2.1.1/docs/Brick-Focus.html#t:FocusRing -{- data PopUpResources - = UrlEditBox - | SetCheckBox - | IsolateEditBox - | ForceCheckBox - | AdditionalEditBox - | RegularInstallButton - | AdvanceInstallButton - | CancellInstallButton - deriving (Eq, Ord, Show) --} -- | Name data type. Uniquely identifies each widget in the TUI. -- some constructors might end up unused, but still is a good practise @@ -56,8 +60,8 @@ data Name = AllTools -- ^ The main list widget | Singular Tool -- ^ The particular list for each tool | KeyInfoBox -- ^ The text box widget with action informacion | TutorialBox -- ^ The tutorial widget --- | PopUpBox -- ^ The whole popUp widget --- | PopUpElement PopUpResources -- ^ each element in the popUp + | ContextBox -- ^ The resource for the context menu + | MenuElement ResourceId -- ^ The resource for field/buttons in a menu deriving (Eq, Ord, Show) -- | Mode type. It helps to dispatch events to different handlers. @@ -101,6 +105,15 @@ keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (showKey key separator :: Brick.Widget n separator = Border.hBorder <+> Brick.str " o " <+> Border.hBorder +-- | Used to create a layer on top of the main navigation widget (tutorial, info, menus...) +frontwardLayer :: T.Text -> Brick.Widget n -> Brick.Widget n +frontwardLayer layer_name = + Brick.centerLayer + . Brick.hLimitPercent 75 + . Brick.vLimitPercent 50 + . Brick.withBorderStyle Border.unicode + . Border.borderWithLabel (Brick.txt layer_name) + -- I refuse to give this a type signature. -- | Given a lens, zoom on it. It is needed because Brick uses microlens but GHCup uses optics. diff --git a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs index bc89acfc..8d07546b 100644 --- a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs +++ b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs @@ -14,7 +14,7 @@ A very simple information-only widget with no handler. module GHCup.Brick.Widgets.KeyInfo where -import GHCup.Types ( KeyBindings(..), KeyCombination(KeyCombination) ) +import GHCup.Types ( KeyBindings(..) ) import qualified GHCup.Brick.Common as Common @@ -24,10 +24,7 @@ import Brick (<+>), (<=>)) import qualified Brick -import Brick.Widgets.Border ( borderWithLabel) -import Brick.Widgets.Border.Style ( unicode ) -import Brick.Widgets.Center ( center, centerLayer ) -import Data.List ( intercalate ) +import Brick.Widgets.Center ( center ) import Prelude hiding ( appendFile ) @@ -36,43 +33,38 @@ draw :: KeyBindings -> Widget Common.Name draw KeyBindings {..} = let mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) - in centerLayer - $ Brick.hLimitPercent 75 - $ Brick.vLimitPercent 50 - $ Brick.withBorderStyle unicode - $ borderWithLabel (Brick.txt "Key Actions") + in Common.frontwardLayer "Key Actions" $ Brick.vBox [ center $ mkTextBox [ Brick.hBox [ Brick.txt "Press " - , keyToWidget bUp, Brick.txt " and ", keyToWidget bDown + , Common.keyToWidget bUp, Brick.txt " and ", Common.keyToWidget bDown , Brick.txtWrap " to navigate the list of tools" ] , Brick.hBox [ Brick.txt "Press " - , keyToWidget bInstall + , Common.keyToWidget bInstall , Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards" ] , Brick.hBox [ Brick.txt "Press " - , keyToWidget bSet + , Common.keyToWidget bSet , Brick.txtWrap " to set a tool as the one for use" ] , Brick.hBox [ Brick.txt "Press " - , keyToWidget bUninstall + , Common.keyToWidget bUninstall , Brick.txtWrap " to uninstall a tool" ] , Brick.hBox [ Brick.txt "Press " - , keyToWidget bChangelog + , Common.keyToWidget bChangelog , Brick.txtWrap " to open the tool's changelog. It will open a web browser" ] , Brick.hBox [ Brick.txt "Press " - , keyToWidget bShowAllVersions + , Common.keyToWidget bShowAllVersions , Brick.txtWrap " to show older version of each tool" ] ] diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs index 447f1d07..3f62c22b 100644 --- a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs +++ b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs @@ -23,9 +23,8 @@ import Brick (<+>), (<=>)) import qualified Brick -import Brick.Widgets.Border ( hBorder, borderWithLabel) -import Brick.Widgets.Border.Style ( unicode ) -import Brick.Widgets.Center ( center, centerLayer ) +import Brick.Widgets.Border ( hBorder) +import Brick.Widgets.Center ( center ) import Prelude hiding ( appendFile ) @@ -34,16 +33,12 @@ draw :: Widget Common.Name draw = let mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - txt_separator = hBorder <+> Brick.str " o " <+> hBorder - in centerLayer - $ Brick.hLimitPercent 75 - $ Brick.vLimitPercent 50 - $ Brick.withBorderStyle unicode - $ borderWithLabel (Brick.txt "Tutorial") + + in Common.frontwardLayer "Tutorial" $ Brick.vBox (fmap center [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] - , txt_separator + , Common.separator , mkTextBox [ Brick.hBox [ Brick.txt "This symbol " @@ -61,7 +56,7 @@ draw = , Brick.txt " means that the tool isn't installed" ] ] - , txt_separator + , Common.separator , mkTextBox [ Brick.hBox [ Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended" From 06843bfe25ea7f372e363b8b924667feab62cf16 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 28 Feb 2024 09:37:17 +0100 Subject: [PATCH 04/33] Context Menu visuals --- ghcup.cabal | 1 + lib-tui/GHCup/Brick/Actions.hs | 26 ++++++--- lib-tui/GHCup/Brick/App.hs | 28 +++++++++- lib-tui/GHCup/Brick/BrickState.hs | 2 + lib-tui/GHCup/Brick/Common.hs | 2 +- lib-tui/GHCup/Brick/Widgets/Menu.hs | 6 +- lib-tui/GHCup/Brick/Widgets/Menus/Context.hs | 59 ++++++++++++++++++++ lib-tui/GHCup/Brick/Widgets/Tutorial.hs | 1 - lib-tui/GHCup/BrickMain.hs | 38 ++++++++----- 9 files changed, 135 insertions(+), 28 deletions(-) create mode 100644 lib-tui/GHCup/Brick/Widgets/Menus/Context.hs diff --git a/ghcup.cabal b/ghcup.cabal index fc1024b4..0cc06da0 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -331,6 +331,7 @@ library ghcup-tui GHCup.Brick.Widgets.KeyInfo GHCup.Brick.Widgets.SectionList GHCup.Brick.Widgets.Menu + GHCup.Brick.Widgets.Menus.Context GHCup.Brick.Actions GHCup.Brick.App GHCup.Brick.BrickState diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index aa16dc5a..78a7bf52 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -26,6 +26,7 @@ import GHCup.Brick.Common (BrickData(..), BrickSettings(..), Name(..), import qualified GHCup.Brick.Common as Common import GHCup.Brick.BrickState import GHCup.Brick.Widgets.SectionList +import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu import GHCup.Brick.Widgets.Navigation (BrickInternalState) import qualified Brick @@ -70,6 +71,8 @@ import Optics.State (use) import Optics.State.Operators ( (.=)) import Optics.Operators ((.~),(%~)) import Optics.Getter (view) +import Optics.Optic ((%)) +import Optics (to) {- Core Logic. @@ -86,14 +89,11 @@ This module defines the IO actions we can execute within the Brick App: -- This synchronises @BrickInternalState@ with @BrickData@ -- and @BrickSettings@. updateList :: BrickData -> BrickState -> BrickState -updateList appD BrickState{..} = +updateList appD st@BrickState{..} = let newInternalState = constructList appD _appSettings (Just _appState) - in BrickState { _appState = newInternalState - , _appData = appD - , _appSettings = _appSettings - , _appKeys = _appKeys - , _mode = Navigation - } + in st & appState .~ newInternalState + & appData .~ appD + & mode .~ Navigation constructList :: BrickData -> BrickSettings @@ -447,8 +447,20 @@ keyHandlers KeyBindings {..} = , (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 menus + contextMenu .= ContextMenu.create r bQuit + -- Set mode to context + mode .= ContextPanel + pure () + --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () hideShowHandler' f = do app_settings <- use appSettings diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index eaa0923c..c678c57f 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -26,11 +26,12 @@ module GHCup.Brick.App where import GHCup.Types ( AppState(AppState, keyBindings), KeyCombination(KeyCombination) ) import GHCup.Brick.Common ( Name(..), Mode(..)) import qualified GHCup.Brick.Common as Common -import GHCup.Brick.BrickState (BrickState(..), appState, mode, appKeys, appSettings) +import GHCup.Brick.BrickState (BrickState(..), appState, mode, appKeys, appSettings, contextMenu) import qualified GHCup.Brick.Attributes as Attributes import qualified GHCup.Brick.Widgets.Navigation as Navigation import qualified GHCup.Brick.Widgets.Tutorial as Tutorial import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo +import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu import qualified GHCup.Brick.Actions as Actions import Brick @@ -53,6 +54,11 @@ import Optics.State (use) import Optics.State.Operators ( (.=)) import Optics.Operators ((^.)) import qualified Data.Text as T +import qualified GHCup.Brick.Widgets.Menu as Menu +import Optics.Optic ((%)) +import qualified Brick.Focus as F +import Optics.Getter (to) + app :: AttrMap -> AttrMap -> App BrickState () Name app attrs dimAttrs = @@ -79,7 +85,7 @@ drawUI dimAttrs st = Navigation -> [navg] Tutorial -> [Tutorial.draw, navg] KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] --- InstallPopUp -> [drawCompilePopUp (st ^. popUp), navg] + ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg] -- | On q, go back to navigation. -- On Enter, to go to tutorial @@ -107,6 +113,22 @@ navigationHandler ev = do 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 + buttons = ctx ^. Menu.menuButtonsL + (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL + case (ev, focusedElement) of + (_ , Nothing) -> pure () + (VtyEvent (Vty.EvKey k m), Just n ) + | k == exitKey + && m == mods + && n `elem` [Menu.fieldName button | button <- buttons] + -> mode .= Navigation + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> pure () + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompilieButton) ) -> pure () + _ -> Common.zoom contextMenu $ ContextMenu.handler ev eventHandler :: BrickEvent Name e -> EventM Name BrickState () eventHandler ev = do @@ -115,4 +137,4 @@ eventHandler ev = do KeyInfo -> keyInfoHandler ev Tutorial -> tutorialHandler ev Navigation -> navigationHandler ev --- InstallPopUp -> compilePopUpHandler ev + ContextPanel -> contextMenuHandler ev diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs index 5356a6e8..abc7d546 100644 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -31,6 +31,7 @@ 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 Optics.TH (makeLenses) @@ -38,6 +39,7 @@ data BrickState = BrickState { _appData :: BrickData , _appSettings :: BrickSettings , _appState :: BrickInternalState + , _contextMenu :: ContextMenu , _appKeys :: KeyBindings , _mode :: Mode } diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 1bb3045e..8899fa92 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -65,7 +65,7 @@ data Name = AllTools -- ^ The main list widget deriving (Eq, Ord, Show) -- | Mode type. It helps to dispatch events to different handlers. -data Mode = Navigation | KeyInfo | Tutorial deriving (Eq, Show, Ord) +data Mode = Navigation | KeyInfo | Tutorial | ContextPanel deriving (Eq, Show, Ord) installedSign :: String #if IS_WINDOWS diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 9efa1bbf..2a2ad3fc 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -345,14 +345,14 @@ drawMenu menu = -- A list of functions which draw a highlighted label with right padding at the left of a widget. amplifiers = - let labelsWidgets = fmap (\b -> renderAslabel b) fieldLabels + let labelsWidgets = fmap renderAslabel fieldLabels in fmap (\f b -> ((centerV . leftify (maxWidth + 10) $ f b) <+>) ) labelsWidgets drawFields = fmap drawField amplifiers fieldWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawFields (menu ^. menuFieldsL) buttonAmplifiers = - let buttonAsWidgets = fmap (\b -> renderAslabel b) buttonLabels - in fmap (\f b -> ((leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets + let buttonAsWidgets = fmap renderAslabel buttonLabels + in fmap (\f b -> ((leftify (maxWidth + 10) . Border.border $ Brick.str (show b) <+> f b) <+>) ) buttonAsWidgets drawButtons = fmap drawField buttonAmplifiers buttonWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawButtons (menu ^. menuButtonsL) diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs new file mode 100644 index 00000000..9d6ed17d --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} + +module GHCup.Brick.Widgets.Menus.Context (ContextMenu, create, draw, handler) where + +import Brick ( + Widget (..), BrickEvent, EventM, + ) +import Data.Function ((&)) +import qualified GHCup.Brick.Common as Common +import qualified GHCup.Brick.Widgets.Menu as Menu +import Prelude hiding (appendFile) + +import qualified Data.Text as T + +import Data.Versions (prettyVer) +import GHCup (ListResult (..)) +import GHCup.Brick.Common (Name (..)) +import GHCup.Brick.Widgets.Menu (Menu) +import GHCup.Types (KeyCombination, Tool (..)) +import Optics (to) +import Optics.Operators ((.~), (^.)) +import Optics.Optic ((%)) + +type ContextMenu = Menu ListResult Name + +create :: ListResult -> KeyCombination -> ContextMenu +create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons [] + where + advInstallButton = + Menu.createButtonField (MenuElement Common.AdvanceInstallButton) + & Menu.fieldLabelL .~ "Install" + & Menu.fieldHelpMsgL .~ "Advance Installation Settings" + compileButton = + Menu.createButtonField (MenuElement Common.AdvanceInstallButton) + & Menu.fieldLabelL .~ "Compile" + & Menu.fieldHelpMsgL .~ "Compile tool from source (to be implemented)" + buttons = + case lTool lr of + GHC -> [advInstallButton, compileButton] + HLS -> [advInstallButton, compileButton] + _ -> [advInstallButton] + +draw :: ContextMenu -> Widget Name +draw ctx = + Common.frontwardLayer + ("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ ctx ^. Menu.menuStateL)) + (Menu.drawMenu ctx) + where + tool_str :: T.Text + tool_str = + case ctx ^. 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 \ No newline at end of file diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs index 3f62c22b..6c47b552 100644 --- a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs +++ b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs @@ -23,7 +23,6 @@ import Brick (<+>), (<=>)) import qualified Brick -import Brick.Widgets.Border ( hBorder) import Brick.Widgets.Center ( center ) import Prelude hiding ( appendFile ) diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index fcb65546..1c53bf54 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -17,13 +17,15 @@ module GHCup.BrickMain where import GHCup.Types ( Settings(noColor), - AppState(ghcupInfo, settings, keyBindings, loggerConfig) ) + AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (bQuit) ) import GHCup.Prelude.Logger ( logError ) import qualified GHCup.Brick.Actions as Actions import qualified GHCup.Brick.Common as Common import qualified GHCup.Brick.App as BrickApp import qualified GHCup.Brick.Attributes as Attributes import qualified GHCup.Brick.BrickState as AppState +import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu +import qualified GHCup.Brick.Widgets.SectionList as Navigation import qualified Brick import Control.Monad.Reader ( ReaderT(runReaderT) ) @@ -43,18 +45,28 @@ brickMain s = do eAppData <- Actions.getAppData (Just $ ghcupInfo s) case eAppData of - Right ad -> - Brick.defaultMain - (BrickApp.app (Attributes.defaultAttributes (noColor $ settings s)) - (Attributes.dimAttributes (noColor $ settings s))) - (AppState.BrickState ad - Common.defaultAppSettings - (Actions.constructList ad Common.defaultAppSettings Nothing) - (keyBindings (s :: AppState)) - Common.Navigation - - ) - $> () + Right ad -> do + let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing + current_element = Navigation.sectionListSelectedElement initial_list + exit_key = bQuit . keyBindings $ s + 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) + initstate = + AppState.BrickState ad + Common.defaultAppSettings + initial_list + (ContextMenu.create e exit_key) + (keyBindings s) + Common.Navigation + in Brick.defaultMain initapp initstate + $> () Left e -> do flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) exitWith $ ExitFailure 2 From 71a3b00d03f700e23d25241baee6aa6e3606563b Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 28 Feb 2024 10:29:39 +0100 Subject: [PATCH 05/33] Add visuals for Advance Install --- ghcup.cabal | 1 + lib-tui/GHCup/Brick/Actions.hs | 17 +-- lib-tui/GHCup/Brick/App.hs | 81 ++++++++----- lib-tui/GHCup/Brick/BrickState.hs | 14 ++- lib-tui/GHCup/Brick/Common.hs | 35 ++++-- lib-tui/GHCup/Brick/Widgets/Menu.hs | 2 +- .../Brick/Widgets/Menus/AdvanceInstall.hs | 107 ++++++++++++++++++ lib-tui/GHCup/Brick/Widgets/Menus/Context.hs | 2 +- lib-tui/GHCup/Brick/Widgets/Tutorial.hs | 1 - lib-tui/GHCup/BrickMain.hs | 4 +- 10 files changed, 208 insertions(+), 56 deletions(-) create mode 100644 lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs diff --git a/ghcup.cabal b/ghcup.cabal index 0cc06da0..ba3d7d25 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -332,6 +332,7 @@ library ghcup-tui GHCup.Brick.Widgets.SectionList GHCup.Brick.Widgets.Menu GHCup.Brick.Widgets.Menus.Context + GHCup.Brick.Widgets.Menus.AdvanceInstall GHCup.Brick.Actions GHCup.Brick.App GHCup.Brick.BrickState diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 78a7bf52..ae16aed9 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -72,7 +72,8 @@ import Optics.State.Operators ( (.=)) import Optics.Operators ((.~),(%~)) import Optics.Getter (view) import Optics.Optic ((%)) -import Optics (to) +import Optics ((^.), to) +import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall {- Core Logic. @@ -89,11 +90,12 @@ This module defines the IO actions we can execute within the Brick App: -- This synchronises @BrickInternalState@ with @BrickData@ -- and @BrickSettings@. updateList :: BrickData -> BrickState -> BrickState -updateList appD st@BrickState{..} = - let newInternalState = constructList appD _appSettings (Just _appState) - in st & appState .~ newInternalState - & appData .~ appD - & mode .~ Navigation +updateList appD bst = + let newInternalState = constructList appD (bst ^. appSettings) (Just (bst ^. appState)) + in bst + & appState .~ newInternalState + & appData .~ appD + & mode .~ Navigation constructList :: BrickData -> BrickSettings @@ -456,7 +458,8 @@ keyHandlers KeyBindings {..} = Nothing -> pure () Just (_, r) -> do -- Create new menus - contextMenu .= ContextMenu.create r bQuit + contextMenu .= ContextMenu.create r bQuit + advanceInstallMenu .= AdvanceInstall.create bQuit -- Set mode to context mode .= ContextPanel pure () diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index c678c57f..9132d407 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -23,42 +23,47 @@ module should only contain: module GHCup.Brick.App where -import GHCup.Types ( AppState(AppState, keyBindings), KeyCombination(KeyCombination) ) -import GHCup.Brick.Common ( Name(..), Mode(..)) -import qualified GHCup.Brick.Common as Common -import GHCup.Brick.BrickState (BrickState(..), appState, mode, appKeys, appSettings, contextMenu) +import qualified GHCup.Brick.Actions as Actions import qualified GHCup.Brick.Attributes as Attributes -import qualified GHCup.Brick.Widgets.Navigation as Navigation -import qualified GHCup.Brick.Widgets.Tutorial as Tutorial +import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode) +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.Actions as Actions +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 Brick - ( BrickEvent(VtyEvent), - App(..), - AttrMap, - EventM, - Widget(..), - (<=>)) +import GHCup.Types (AppState (AppState, keyBindings), KeyCombination (KeyCombination)) + +import qualified Brick.Focus as F +import Brick ( + App (..), + AttrMap, + BrickEvent (VtyEvent), + EventM, + Widget (..), + (<=>), + ) import qualified Brick -import Control.Monad.Reader - ( void, MonadIO(liftIO) ) -import Data.List ( find, intercalate) -import Data.IORef (readIORef) -import Prelude hiding ( appendFile ) +import Control.Monad.Reader ( + MonadIO (liftIO), + void, + ) +import Data.IORef (readIORef) +import Data.List (find, intercalate) +import Prelude hiding (appendFile) -import qualified Graphics.Vty as Vty +import qualified Graphics.Vty as Vty -import Optics.State (use) -import Optics.State.Operators ( (.=)) -import Optics.Operators ((^.)) import qualified Data.Text as T -import qualified GHCup.Brick.Widgets.Menu as Menu -import Optics.Optic ((%)) -import qualified Brick.Focus as F -import Optics.Getter (to) +import Optics.Getter (to) +import Optics.Operators ((^.)) +import Optics.Optic ((%)) +import Optics.State (use) +import Optics.State.Operators ((.=)) app :: AttrMap -> AttrMap -> App BrickState () Name app attrs dimAttrs = @@ -86,6 +91,8 @@ drawUI dimAttrs st = Tutorial -> [Tutorial.draw, navg] KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg] + AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg] + -- | On q, go back to navigation. -- On Enter, to go to tutorial @@ -121,14 +128,29 @@ contextMenuHandler ev = do (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL case (ev, focusedElement) of (_ , Nothing) -> pure () - (VtyEvent (Vty.EvKey k m), Just n ) + (VtyEvent (Vty.EvKey k m), Just n) | k == exitKey && m == mods && n `elem` [Menu.fieldName button | button <- buttons] -> mode .= Navigation - (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> pure () + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompilieButton) ) -> pure () _ -> Common.zoom contextMenu $ ContextMenu.handler ev +-- +advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState () +advanceInstallHandler ev = do + ctx <- use advanceInstallMenu + let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent + buttons = ctx ^. Menu.menuButtonsL + (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL + case (ev, focusedElement) of + (_ , Nothing) -> pure () + (VtyEvent (Vty.EvKey k m), Just n) + | k == exitKey + && m == mods + && n `elem` [Menu.fieldName button | button <- buttons] + -> mode .= ContextPanel + _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev eventHandler :: BrickEvent Name e -> EventM Name BrickState () eventHandler ev = do @@ -138,3 +160,4 @@ eventHandler ev = do Tutorial -> tutorialHandler ev Navigation -> navigationHandler ev ContextPanel -> contextMenuHandler ev + AdvanceInstallPanel -> advanceInstallHandler ev diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs index abc7d546..84583f45 100644 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -32,16 +32,18 @@ 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 Optics.TH (makeLenses) data BrickState = BrickState - { _appData :: BrickData - , _appSettings :: BrickSettings - , _appState :: BrickInternalState - , _contextMenu :: ContextMenu - , _appKeys :: KeyBindings - , _mode :: Mode + { _appData :: BrickData + , _appSettings :: BrickSettings + , _appState :: BrickInternalState + , _contextMenu :: ContextMenu + , _advanceInstallMenu :: AdvanceInstallMenu + , _appKeys :: KeyBindings + , _mode :: Mode } --deriving Show diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 8899fa92..7f08f57a 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -52,20 +52,34 @@ pattern OkButton = ResourceId 0 pattern AdvanceInstallButton = ResourceId 100 pattern CompilieButton = ResourceId 101 +pattern UrlEditBox = ResourceId 1 +pattern SetCheckBox = ResourceId 2 +pattern IsolateEditBox = ResourceId 3 +pattern ForceCheckBox = ResourceId 4 +pattern AdditionalEditBox = ResourceId 5 -- | Name data type. Uniquely identifies each widget in the TUI. -- some constructors might end up unused, but still is a good practise -- to have all of them defined, just in case -data Name = AllTools -- ^ The main list widget - | Singular Tool -- ^ The particular list for each tool - | KeyInfoBox -- ^ The text box widget with action informacion - | TutorialBox -- ^ The tutorial widget - | ContextBox -- ^ The resource for the context menu - | MenuElement ResourceId -- ^ The resource for field/buttons in a menu +data Name = AllTools -- ^ The main list widget + | Singular Tool -- ^ The particular list for each tool + | KeyInfoBox -- ^ The text box widget with action informacion + | TutorialBox -- ^ The tutorial widget + | ContextBox -- ^ The Context Menu for a Tool + | AdvanceInstallBox -- ^ The Menu for AdvanceInstall + | 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 deriving (Eq, Show, Ord) +data Mode = Navigation + | KeyInfo + | Tutorial + | ContextPanel + | AdvanceInstallPanel + deriving (Eq, Show, Ord) installedSign :: String #if IS_WINDOWS @@ -88,6 +102,7 @@ notInstalledSign = "X " notInstalledSign = "✗ " #endif + showKey :: Vty.Key -> String showKey (Vty.KChar c) = [c] showKey Vty.KUp = "↑" @@ -107,8 +122,8 @@ separator = Border.hBorder <+> Brick.str " o " <+> Border.hBorder -- | Used to create a layer on top of the main navigation widget (tutorial, info, menus...) frontwardLayer :: T.Text -> Brick.Widget n -> Brick.Widget n -frontwardLayer layer_name = - Brick.centerLayer +frontwardLayer layer_name = + Brick.centerLayer . Brick.hLimitPercent 75 . Brick.vLimitPercent 50 . Brick.withBorderStyle Border.unicode @@ -132,4 +147,4 @@ data BrickSettings = BrickSettings { _showAllVersions :: Bool} makeLenses ''BrickSettings defaultAppSettings :: BrickSettings -defaultAppSettings = BrickSettings { _showAllVersions = False} +defaultAppSettings = BrickSettings False diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 2a2ad3fc..6eef7157 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -352,7 +352,7 @@ drawMenu menu = buttonAmplifiers = let buttonAsWidgets = fmap renderAslabel buttonLabels - in fmap (\f b -> ((leftify (maxWidth + 10) . Border.border $ Brick.str (show b) <+> f b) <+>) ) buttonAsWidgets + in fmap (\f b -> ((leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets drawButtons = fmap drawField buttonAmplifiers buttonWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawButtons (menu ^. menuButtonsL) diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs new file mode 100644 index 00000000..343d9098 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -0,0 +1,107 @@ +{-# 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) where + +import GHCup.Brick.Widgets.Menu (Menu) +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 GHCup.Types (KeyCombination) +import URI.ByteString (URI) +import qualified Data.Text as T +import qualified Data.ByteString.UTF8 as UTF8 +import GHCup.Utils (parseURI) +import Data.Bifunctor (Bifunctor(..)) +import Data.Function ((&)) +import Optics ((.~)) +import Data.Char (isSpace) + +data InstallOptions = InstallOptions + { instBindist :: Maybe URI + , instSet :: Bool + , isolateDir :: Maybe FilePath + , forceInstall :: Bool + , addConfArgs :: [T.Text] + } deriving (Eq, Show) + +makeLensesFor [ + ("instBindist", "instBindistL") + , ("instSet", "instSetL") + , ("isolateDir", "isolateDirL") + , ("forceInstall", "forceInstallL") + , ("addConfArgs", "addConfArgsL") + ] + ''InstallOptions + +type AdvanceInstallMenu = Menu InstallOptions Name + +create :: KeyCombination -> AdvanceInstallMenu +create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields + where + initialState = InstallOptions Nothing False Nothing False [] + -- Brick's internal editor representation is [mempty]. + emptyEditor i = T.null i || (i == "\n") + + uriValidator :: T.Text -> Either Menu.ErrorMessage (Maybe URI) + uriValidator i = + case not $ emptyEditor i of + True -> bimap (T.pack . show) Just . parseURI . UTF8.fromString . T.unpack $ i + False -> Right Nothing + + filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) + filepathValidator i = + case not $ emptyEditor i of + True -> Right . Just . T.unpack $ i + False -> Right Nothing + + 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.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, prefix with '-- ' (longopts)" + ] + + 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 = Common.frontwardLayer "Advance Install" . Menu.drawMenu diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs index 9d6ed17d..44b2d9f9 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs @@ -31,7 +31,7 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons [] & Menu.fieldLabelL .~ "Install" & Menu.fieldHelpMsgL .~ "Advance Installation Settings" compileButton = - Menu.createButtonField (MenuElement Common.AdvanceInstallButton) + Menu.createButtonField (MenuElement Common.CompilieButton) & Menu.fieldLabelL .~ "Compile" & Menu.fieldHelpMsgL .~ "Compile tool from source (to be implemented)" buttons = diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs index 6c47b552..cba19a2f 100644 --- a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs +++ b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs @@ -20,7 +20,6 @@ import qualified GHCup.Brick.Attributes as Attributes import Brick ( Padding(Max), Widget(..), - (<+>), (<=>)) import qualified Brick import Brick.Widgets.Center ( center ) diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index 1c53bf54..fe481c3a 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -17,7 +17,7 @@ module GHCup.BrickMain where import GHCup.Types ( Settings(noColor), - AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (bQuit) ) + AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (..) ) import GHCup.Prelude.Logger ( logError ) import qualified GHCup.Brick.Actions as Actions import qualified GHCup.Brick.Common as Common @@ -26,6 +26,7 @@ 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 Brick import Control.Monad.Reader ( ReaderT(runReaderT) ) @@ -63,6 +64,7 @@ brickMain s = do Common.defaultAppSettings initial_list (ContextMenu.create e exit_key) + (AdvanceInstall.create (bQuit . keyBindings $ s )) (keyBindings s) Common.Navigation in Brick.defaultMain initapp initstate From e88de9bc78611e9f1ec3306eaa1886eb6b0a41c9 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 7 Feb 2024 22:30:45 +0100 Subject: [PATCH 06/33] migrate #987 to new library --- lib-tui/GHCup/Brick/Widgets/SectionList.hs | 49 +++++++++++----------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/lib-tui/GHCup/Brick/Widgets/SectionList.hs b/lib-tui/GHCup/Brick/Widgets/SectionList.hs index 071b1a36..378f6eaa 100644 --- a/lib-tui/GHCup/Brick/Widgets/SectionList.hs +++ b/lib-tui/GHCup/Brick/Widgets/SectionList.hs @@ -155,34 +155,35 @@ handleGenericListEvent (VtyEvent ev) = do handleGenericListEvent _ = pure () -- This re-uses Brick.Widget.List.renderList -renderSectionList :: (Traversable t, Ord n, Show n, Eq n, L.Splittable t) +renderSectionList :: forall n t e . (Traversable t, Ord n, Show n, Eq n, L.Splittable t, Semigroup (t e)) => (Bool -> e -> Widget n) -- ^ Rendering function of the list element, True for the selected element -> Bool -- ^ Whether the section list has focus -> GenericSectionList n t e -- ^ The section list to render -> Widget n -renderSectionList render_elem section_focus (GenericSectionList focus elms sl_name) = - Brick.Widget Brick.Greedy Brick.Greedy $ do - c <- Brick.getContext - let -- A section is focused if the whole thing is focused, and the inner list has focus - section_is_focused l = section_focus && (Just (L.listName l) == F.focusGetCurrent focus) - -- We need to limit the widget size when the length of the list is higher than the size of the terminal - limit = min (Brick.windowHeight c) (Brick.availHeight c) - s_idx = fromMaybe 0 $ V.findIndex section_is_focused elms - render_inner_list has_focus l = Brick.vLimit (length l) $ L.renderList (\b -> render_elem (b && has_focus)) has_focus l - (widget, off) = - V.ifoldl' (\wacc i list -> - let has_focus_list = section_is_focused list - (!acc_widget, !acc_off) = wacc - new_widget = if i == 0 then render_inner_list has_focus_list list else hBorder <=> render_inner_list has_focus_list list - new_off - | i < s_idx = 1 + L.listItemHeight list * length list - | i == s_idx = 1 + L.listItemHeight list * fromMaybe 0 (L.listSelected list) - | otherwise = 0 - in (acc_widget <=> new_widget, acc_off + new_off) - ) - (Brick.emptyWidget, 0) - elms - Brick.render $ Brick.viewport sl_name Brick.Vertical $ Brick.translateBy (Brick.Location (0, min 0 (limit-off))) widget +renderSectionList renderElem sectionFocus ge@(GenericSectionList focus elms slName) = + Brick.Widget Brick.Greedy Brick.Greedy $ Brick.render $ Brick.viewport slName Brick.Vertical $ + V.ifoldl' (\(!accWidget) !i list -> + let hasFocusList = sectionIsFocused list + makeVisible = if hasFocusList then Brick.visibleRegion (Brick.Location (c, r)) (1, 1) else id + appendBorder = if i == 0 then id else (hBorder <=>) + newWidget = appendBorder (makeVisible $ renderInnerList hasFocusList list) + in accWidget <=> newWidget + ) + Brick.emptyWidget + elms + where + -- A section is focused if the whole thing is focused, and the inner list has focus + sectionIsFocused :: L.GenericList n t e -> Bool + sectionIsFocused l = sectionFocus && (Just (L.listName l) == F.focusGetCurrent focus) + + renderInnerList :: Bool -> L.GenericList n t e -> Widget n + renderInnerList hasFocus l = Brick.vLimit (length l) $ L.renderList (\b -> renderElem (b && hasFocus)) hasFocus l + + -- compute the location to focus on within the active section + (c, r) :: (Int, Int) = case sectionListSelectedElement ge of + Nothing -> (0, 0) + Just (selElIx, _) -> (0, selElIx) + -- | Equivalent to listSelectedElement sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) From 7e6ddf8b38682b9dc04c3fe0367cc74b1db1add4 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 28 Feb 2024 17:01:54 +0100 Subject: [PATCH 07/33] Add visuals for compile Menu --- ghcup.cabal | 1 + lib-tui/GHCup/Brick/Actions.hs | 7 +- lib-tui/GHCup/Brick/App.hs | 24 ++- lib-tui/GHCup/Brick/BrickState.hs | 14 +- lib-tui/GHCup/Brick/Common.hs | 60 +++++- lib-tui/GHCup/Brick/Widgets/Menu.hs | 15 +- .../GHCup/Brick/Widgets/Menus/CompileGHC.hs | 177 ++++++++++++++++++ lib-tui/GHCup/BrickMain.hs | 2 + 8 files changed, 278 insertions(+), 22 deletions(-) create mode 100644 lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs diff --git a/ghcup.cabal b/ghcup.cabal index ba3d7d25..0e6b630e 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -333,6 +333,7 @@ library ghcup-tui GHCup.Brick.Widgets.Menu GHCup.Brick.Widgets.Menus.Context GHCup.Brick.Widgets.Menus.AdvanceInstall + GHCup.Brick.Widgets.Menus.CompileGHC GHCup.Brick.Actions GHCup.Brick.App GHCup.Brick.BrickState diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index ae16aed9..0619b359 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -28,6 +28,8 @@ import GHCup.Brick.BrickState 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 qualified Brick import qualified Brick.Widgets.List as L @@ -73,7 +75,7 @@ import Optics.Operators ((.~),(%~)) import Optics.Getter (view) import Optics.Optic ((%)) import Optics ((^.), to) -import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall + {- Core Logic. @@ -458,8 +460,9 @@ keyHandlers KeyBindings {..} = Nothing -> pure () Just (_, r) -> do -- Create new menus - contextMenu .= ContextMenu.create r bQuit + contextMenu .= ContextMenu.create r bQuit advanceInstallMenu .= AdvanceInstall.create bQuit + compileGHCMenu .= CompileGHC.create bQuit -- Set mode to context mode .= ContextPanel pure () diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 9132d407..4a64117d 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -25,7 +25,7 @@ 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) +import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu) import GHCup.Brick.Common (Mode (..), Name (..)) import qualified GHCup.Brick.Common as Common import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo @@ -64,6 +64,7 @@ import Optics.Operators ((^.)) import Optics.Optic ((%)) import Optics.State (use) import Optics.State.Operators ((.=)) +import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC app :: AttrMap -> AttrMap -> App BrickState () Name app attrs dimAttrs = @@ -91,7 +92,8 @@ drawUI dimAttrs st = Tutorial -> [Tutorial.draw, navg] KeyInfo -> [KeyInfo.draw (st ^. appKeys), navg] ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg] - AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg] + AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg] + CompileGHCPanel -> [CompileGHC.draw (st ^. compileGHCMenu), navg] -- | On q, go back to navigation. @@ -134,7 +136,7 @@ contextMenuHandler ev = do && n `elem` [Menu.fieldName button | button <- buttons] -> mode .= Navigation (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel - (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompilieButton) ) -> pure () + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompilieButton) ) -> mode .= Common.CompileGHCPanel _ -> Common.zoom contextMenu $ ContextMenu.handler ev -- advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState () @@ -152,6 +154,21 @@ advanceInstallHandler ev = do -> mode .= ContextPanel _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev +compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState () +compileGHCHandler ev = do + ctx <- use compileGHCMenu + let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent + buttons = ctx ^. Menu.menuButtonsL + (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL + case (ev, focusedElement) of + (_ , Nothing) -> pure () + (VtyEvent (Vty.EvKey k m), Just n) + | k == exitKey + && m == mods + && n `elem` [Menu.fieldName button | button <- buttons] + -> mode .= ContextPanel + _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev + eventHandler :: BrickEvent Name e -> EventM Name BrickState () eventHandler ev = do m <- use mode @@ -161,3 +178,4 @@ eventHandler ev = do Navigation -> navigationHandler ev ContextPanel -> contextMenuHandler ev AdvanceInstallPanel -> advanceInstallHandler ev + CompileGHCPanel -> compileGHCHandler ev diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs index 84583f45..7ac36f3d 100644 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -28,12 +28,13 @@ 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 Optics.TH (makeLenses) +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) data BrickState = BrickState @@ -42,6 +43,7 @@ data BrickState = BrickState , _appState :: BrickInternalState , _contextMenu :: ContextMenu , _advanceInstallMenu :: AdvanceInstallMenu + , _compileGHCMenu :: CompileGHCMenu , _appKeys :: KeyBindings , _mode :: Mode } diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 7f08f57a..e209c3af 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -23,7 +23,30 @@ This module contains common values used across the library. Crucially it contain -} -module GHCup.Brick.Common where +module GHCup.Brick.Common ( + installedSign, + setSign, + notInstalledSign, + showKey, + showMod, + keyToWidget, + separator, + frontwardLayer, + zoom, + defaultAppSettings, + lr, + showAllVersions, + Name(..), + Mode(..), + BrickData(..), + BrickSettings(..), + ResourceId ( + UrlEditBox, SetCheckBox, IsolateEditBox, ForceCheckBox, AdditionalEditBox + , TargetGhcEditBox, BootstrapGhcEditBox, JobsEditBox, BuildConfigEditBox + , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox + , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton + , CompilieButton + ) ) where import GHCup.List ( ListResult ) import GHCup.Types ( Tool, KeyCombination (KeyCombination) ) @@ -48,16 +71,45 @@ import qualified Brick.Widgets.Border.Style as Border -- | 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 CompilieButton :: ResourceId pattern CompilieButton = ResourceId 101 +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 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 + -- | 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 @@ -65,8 +117,9 @@ data Name = AllTools -- ^ The main list widget | Singular Tool -- ^ The particular list for each tool | KeyInfoBox -- ^ The text box widget with action informacion | TutorialBox -- ^ The tutorial widget - | ContextBox -- ^ The Context Menu for a Tool - | AdvanceInstallBox -- ^ The Menu for AdvanceInstall + | 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. @@ -79,6 +132,7 @@ data Mode = Navigation | Tutorial | ContextPanel | AdvanceInstallPanel + | CompileGHCPanel deriving (Eq, Show, Ord) installedSign :: String diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 6eef7157..6ee02a94 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -194,15 +194,14 @@ createEditableInput name validator = FieldInput initEdit validateEditContent "" let borderBox = amp . Border.border . Brick.padRight Brick.Max editorRender = Edit.renderEditor (Brick.txt . T.unlines) focus edi + isEditorEmpty = Edit.getEditContents edi == [mempty] in case errMsg of - Valid -> - if Edit.getEditContents edi == [mempty] - then borderBox $ renderAsHelpMsg help - else borderBox editorRender - Invalid msg -> - if focus - then borderBox editorRender - else borderBox $ renderAsErrMsg msg + Valid | isEditorEmpty -> borderBox $ renderAsHelpMsg help + | otherwise -> borderBox editorRender + Invalid msg + | focus && isEditorEmpty -> borderBox $ renderAsHelpMsg help + | focus -> borderBox editorRender + | otherwise -> borderBox $ renderAsErrMsg msg validateEditContent = validator . T.unlines . Edit.getEditContents initEdit = Edit.editorText name (Just 1) "" diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs new file mode 100644 index 00000000..bd212870 --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -0,0 +1,177 @@ +{-# 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) where + +import GHCup.Brick.Widgets.Menu (Menu) +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 (KeyCombination, BuildSystem (Hadrian)) +import URI.ByteString (URI) +import qualified Data.Text as T +import qualified Data.ByteString.UTF8 as UTF8 +import GHCup.Utils (parseURI) +import Data.Bifunctor (Bifunctor(..)) +import Data.Function ((&)) +import Optics ((.~)) +import Data.Char (isSpace) +import Data.Versions (Version, version) +import System.FilePath (isPathSeparator) +import Control.Applicative (Alternative((<|>))) +import Text.Read (readEither) + +data CompileGHCOptions = CompileGHCOptions + { _bootstrapGhc :: Either Version FilePath + , _jobs :: Maybe Int + , _buildConfig :: Maybe FilePath + , _patches :: Maybe (Either FilePath [URI]) + , _crossTarget :: Maybe T.Text + , _addConfArgs :: [T.Text] + , _setCompile :: Bool + , _ovewrwiteVer :: Maybe Version + , _buildFlavour :: Maybe String + , _buildSystem :: Maybe BuildSystem + , _isolateDir :: Maybe FilePath + } deriving (Eq, Show) + +makeLenses ''CompileGHCOptions + +type CompileGHCMenu = Menu CompileGHCOptions Name + +create :: KeyCombination -> CompileGHCMenu +create k = Menu.createMenu CompileGHCBox initialState k buttons fields + where + initialState = + CompileGHCOptions + (Right "") + Nothing + Nothing + Nothing + Nothing + [] + False + Nothing + Nothing + Nothing + 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 (T.init i)) -- Brick adds \n at the end, hence T.init + readPath + = if isPathSeparator (T.head i) + then pure $ Right (T.unpack i) + else Left "Not an absolute Path" + in if T.any isPathSeparator i + then readPath + else readVersion + False -> Left "Invalid Empty value" + + versionV :: T.Text -> Either Menu.ErrorMessage (Maybe Version) + versionV = bimap (const "Not a valid version") Just . version . T.init -- Brick adds \n at the end, hence T.init + + 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 + readUri :: T.Text -> Either String URI + readUri = first show . parseURI . UTF8.fromString . T.unpack + readPatches j = + let + x = (bimap T.unpack (fmap Left) $ filepathV j) + y = second (Just . Right) $ traverse readUri (T.split isSpace j) + in first T.pack $ x <|> y + + filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) + filepathV = whenEmpty Nothing (Right . Just . T.unpack) + + additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] + additionalValidator = Right . T.split isSpace + + systemV :: T.Text -> Either Menu.ErrorMessage (Maybe BuildSystem) + systemV = whenEmpty Nothing readSys + where + readSys i + | T.toLower i == "hadrian" = Right $ Just Hadrian + | T.toLower i == "make" = Right $ Just Hadrian + | otherwise = Left "Not a valid Build System" + + fields = + [ 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" + , Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs + & Menu.fieldLabelL .~ "jobs" + & Menu.fieldHelpMsgL .~ "How many jobs to use for make" + , Menu.createEditableField (Common.MenuElement Common.BuildConfigEditBox) filepathV buildConfig + & Menu.fieldLabelL .~ "build config" + & Menu.fieldHelpMsgL .~ "Absolute path to build config file" + , 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.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgs + & Menu.fieldLabelL .~ "CONFIGURE_ARGS" + & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure, prefix with '-- ' (longopts)" + , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile + & Menu.fieldLabelL .~ "set" + & Menu.fieldHelpMsgL .~ "Set as active version after install" + , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV ovewrwiteVer + & Menu.fieldLabelL .~ "overwrite-version" + & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one" + , 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.BuildSystemEditBox) systemV buildSystem + & Menu.fieldLabelL .~ "build system" + & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')" + , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir + & Menu.fieldLabelL .~ "isolated" + & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one" + ] + + buttons = [ + Menu.createButtonField (Common.MenuElement Common.OkButton) + & Menu.fieldLabelL .~ "Compile" + & Menu.fieldHelpMsgL .~ "Compile GHC from source with options below" + ] + +handler :: BrickEvent Name e -> EventM Name CompileGHCMenu () +handler = Menu.handlerMenu + + +draw :: CompileGHCMenu -> Widget Name +draw = Common.frontwardLayer "Compile GHC" . Menu.drawMenu diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index fe481c3a..e3d6c017 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -27,6 +27,7 @@ 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 qualified Brick import Control.Monad.Reader ( ReaderT(runReaderT) ) @@ -65,6 +66,7 @@ brickMain s = do initial_list (ContextMenu.create e exit_key) (AdvanceInstall.create (bQuit . keyBindings $ s )) + (CompileGHC.create exit_key) (keyBindings s) Common.Navigation in Brick.defaultMain initapp initstate From ca670982a4bb6a778885c8c1e36c9e978774112f Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 28 Feb 2024 17:11:00 +0100 Subject: [PATCH 08/33] Better aesth for context menu --- lib-tui/GHCup/Brick/Widgets/Menu.hs | 14 ++--- lib-tui/GHCup/Brick/Widgets/Menus/Context.hs | 57 +++++++++++++------- 2 files changed, 46 insertions(+), 25 deletions(-) diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 6ee02a94..4a3a39bc 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -150,6 +150,14 @@ 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 = inputRender focus fieldStatus inputHelp inputState (amp focus) + in if focus + then Brick.visible input + else input + instance Brick.Named (MenuField s n) n where getName :: MenuField s n -> n getName entry = entry & fieldName @@ -330,12 +338,6 @@ drawMenu menu = <+> Brick.txt " to go back" ] where - drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) = - let input = inputRender focus fieldStatus inputHelp inputState (amp focus) - in if focus - then Brick.visible input - else input - fieldLabels = [field & fieldLabel | field <- menu ^. menuFieldsL] buttonLabels = [button & fieldLabel | button <- menu ^. menuButtonsL] allLabels = fieldLabels ++ buttonLabels diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs index 44b2d9f9..434183af 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs @@ -6,20 +6,25 @@ import Brick ( Widget (..), BrickEvent, EventM, ) import Data.Function ((&)) -import qualified GHCup.Brick.Common as Common -import qualified GHCup.Brick.Widgets.Menu as Menu import Prelude hiding (appendFile) -import qualified Data.Text as T - import Data.Versions (prettyVer) -import GHCup (ListResult (..)) +import GHCup.List ( ListResult(..) ) +import GHCup.Types (KeyCombination, 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) -import GHCup.Types (KeyCombination, Tool (..)) +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 @@ -33,7 +38,7 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons [] compileButton = Menu.createButtonField (MenuElement Common.CompilieButton) & Menu.fieldLabelL .~ "Compile" - & Menu.fieldHelpMsgL .~ "Compile tool from source (to be implemented)" + & Menu.fieldHelpMsgL .~ "Compile tool from source" buttons = case lTool lr of GHC -> [advInstallButton, compileButton] @@ -41,19 +46,33 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons [] _ -> [advInstallButton] draw :: ContextMenu -> Widget Name -draw ctx = +draw menu = Common.frontwardLayer - ("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ ctx ^. Menu.menuStateL)) - (Menu.drawMenu ctx) - where - tool_str :: T.Text - tool_str = - case ctx ^. Menu.menuStateL % to lTool of - GHC -> "GHC" - GHCup -> "GHCup" - Cabal -> "Cabal" - HLS -> "HLS" - Stack -> "Stack" + ("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.menuExitKeyL) + <+> 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 \ No newline at end of file From 5d2784fba3612d88ea0b3a6419950bc355008293 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Fri, 1 Mar 2024 09:17:25 +0100 Subject: [PATCH 09/33] Advance Install menu implements functionality. --- lib-tui/GHCup/Brick/Actions.hs | 100 +++++++++++++++--- lib-tui/GHCup/Brick/App.hs | 11 +- .../Brick/Widgets/Menus/AdvanceInstall.hs | 22 +++- .../GHCup/Brick/Widgets/Menus/CompileGHC.hs | 22 ++-- 4 files changed, 129 insertions(+), 26 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 0619b359..ab5c3ed9 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -18,7 +18,7 @@ import GHCup.Types.Optics ( getDirs, getPlatformReq ) import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils import GHCup.OptParse.Common (logGHCPostRm) -import GHCup.Prelude ( decUTF8Safe ) +import GHCup.Prelude ( decUTF8Safe, runBothE' ) import GHCup.Prelude.Logger import GHCup.Prelude.Process import GHCup.Prompts @@ -173,12 +173,19 @@ withIOAction action = do pure (updateList data' as) Left err -> throwIO $ userError err -install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => (Int, ListResult) +installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) + => AdvanceInstall.InstallOptions + -> (Int, ListResult) -> m (Either String ()) -install' (_, 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 + v = GHCTargetVersion lCross lVer let run = runResourceT . runE @@ -208,6 +215,7 @@ install' (_, ListResult {..}) = do , UnsupportedSetupCombo , DistroNotFound , NoCompatibleArch + , InstallSetError ] run (do @@ -216,20 +224,81 @@ install' (_, ListResult {..}) = do dirs <- lift getDirs case lTool of GHC -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls - liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce) + let vi = getVersionInfo v GHC dls + case opts ^. AdvanceInstall.instBindistL of + Nothing -> do + liftE $ + runBothE' + (installGHCBin v shouldIsolate shouldForce extraArgs) + (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing)) + pure (vi, dirs, ce) + Just uri -> do + liftE $ + runBothE' + (installGHCBindist + (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) + v + shouldIsolate + shouldForce + extraArgs) + (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing)) + pure (vi, dirs, ce) + Cabal -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls - liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) + let vi = getVersionInfo v Cabal dls + case opts ^. AdvanceInstall.instBindistL of + Nothing -> do + liftE $ + runBothE' + (installCabalBin lVer shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer)) + pure (vi, dirs, ce) + Just uri -> do + liftE $ + runBothE' + (installCabalBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer)) + pure (vi, dirs, ce) + GHCup -> do let vi = snd <$> getLatest dls GHCup liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) - HLS -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls - liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) + HLS -> do + let vi = getVersionInfo v HLS dls + case opts ^. AdvanceInstall.instBindistL of + Nothing -> do + liftE $ + runBothE' + (installHLSBin lVer shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS lVer SetHLSOnly Nothing)) + pure (vi, dirs, ce) + Just uri -> do + liftE $ + runBothE' + (installHLSBindist + (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing) + lVer + shouldIsolate + shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS lVer SetHLSOnly Nothing)) + pure (vi, dirs, ce) + Stack -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls - liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) + let vi = getVersionInfo v Stack dls + case opts ^. AdvanceInstall.instBindistL of + Nothing -> do + liftE $ + runBothE' + (installStackBin lVer shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer)) + pure (vi, dirs, ce) + Just uri -> do + liftE $ + runBothE' + (installStackBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce) + (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer)) + pure (vi, dirs, ce) + ) >>= \case VRight (vi, Dirs{..}, Just ce) -> do @@ -256,6 +325,9 @@ install' (_, ListResult {..}) = do VLeft e -> pure $ Left $ prettyHFError e <> "\n" <> "Also check the logs in ~/.ghcup/logs" +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 False []) set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) => (Int, ListResult) diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 4a64117d..4552eab7 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -148,10 +148,13 @@ advanceInstallHandler ev = do case (ev, focusedElement) of (_ , Nothing) -> pure () (VtyEvent (Vty.EvKey k m), Just n) - | k == exitKey - && m == mods - && n `elem` [Menu.fieldName button | button <- buttons] - -> mode .= ContextPanel + | k == exitKey + && m == mods + && n `elem` [Menu.fieldName button | button <- buttons] + -> mode .= ContextPanel + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do + let iopts = ctx ^. Menu.menuStateL + Actions.withIOAction $ Actions.installWithOptions iopts _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState () diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs index 343d9098..52983434 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -14,7 +14,18 @@ {-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -module GHCup.Brick.Widgets.Menus.AdvanceInstall (InstallOptions, AdvanceInstallMenu, create, handler, draw) where +module GHCup.Brick.Widgets.Menus.AdvanceInstall ( + InstallOptions (..), + AdvanceInstallMenu, + create, + handler, + draw, + instBindistL, + instSetL, + isolateDirL, + forceInstallL, + addConfArgsL, +) where import GHCup.Brick.Widgets.Menu (Menu) import qualified GHCup.Brick.Widgets.Menu as Menu @@ -35,6 +46,8 @@ import Data.Bifunctor (Bifunctor(..)) import Data.Function ((&)) import Optics ((.~)) import Data.Char (isSpace) +import System.FilePath (isValid, isAbsolute, normalise) +import GHCup.Prelude (stripNewlineEnd) data InstallOptions = InstallOptions { instBindist :: Maybe URI @@ -71,9 +84,14 @@ create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) filepathValidator i = case not $ emptyEditor i of - True -> Right . Just . T.unpack $ i + True -> absolutePathParser (T.unpack i) False -> Right Nothing + absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath) + absolutePathParser f = case isValid f && isAbsolute f of + True -> Right . Just . stripNewlineEnd . normalise $ f + False -> Left "Please enter a valid absolute filepath." + additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] additionalValidator = Right . T.split isSpace diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index bd212870..6712687a 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -36,9 +36,10 @@ import Data.Function ((&)) import Optics ((.~)) import Data.Char (isSpace) import Data.Versions (Version, version) -import System.FilePath (isPathSeparator) +import System.FilePath (isPathSeparator, isValid, isAbsolute, normalise) import Control.Applicative (Alternative((<|>))) import Text.Read (readEither) +import GHCup.Prelude (stripNewlineEnd) data CompileGHCOptions = CompileGHCOptions { _bootstrapGhc :: Either Version FilePath @@ -84,10 +85,11 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields case not $ emptyEditor i of True -> let readVersion = bimap (const "Not a valid version") Left (version (T.init i)) -- Brick adds \n at the end, hence T.init - readPath - = if isPathSeparator (T.head i) - then pure $ Right (T.unpack i) - else Left "Not an absolute Path" + readPath = do + mfilepath <- filepathV i + case mfilepath of + Nothing -> Left "Invalid Empty value" + Just f -> Right (Right f) in if T.any isPathSeparator i then readPath else readVersion @@ -113,7 +115,15 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields in first T.pack $ x <|> y filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) - filepathV = whenEmpty Nothing (Right . Just . T.unpack) + filepathV i = + case not $ emptyEditor i of + True -> absolutePathParser (T.unpack i) + False -> Right Nothing + + absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath) + absolutePathParser f = case isValid f && isAbsolute f of + True -> Right . Just . stripNewlineEnd . normalise $ f + False -> Left "Please enter a valid absolute filepath." additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] additionalValidator = Right . T.split isSpace From f804c0398954cfbfcb81b1e6b67a4ae1813502ea Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Mon, 4 Mar 2024 17:32:22 +0100 Subject: [PATCH 10/33] Visuals for compiling HLS --- ghcup.cabal | 1 + lib-tui/GHCup/Brick/Actions.hs | 2 + lib-tui/GHCup/Brick/App.hs | 25 ++- lib-tui/GHCup/Brick/BrickState.hs | 2 + lib-tui/GHCup/Brick/Common.hs | 18 +- .../GHCup/Brick/Widgets/Menus/CompileHLS.hs | 174 ++++++++++++++++++ lib-tui/GHCup/Brick/Widgets/Menus/Context.hs | 14 +- lib-tui/GHCup/BrickMain.hs | 2 + 8 files changed, 227 insertions(+), 11 deletions(-) create mode 100644 lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs diff --git a/ghcup.cabal b/ghcup.cabal index 0e6b630e..06a90858 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -334,6 +334,7 @@ library ghcup-tui GHCup.Brick.Widgets.Menus.Context GHCup.Brick.Widgets.Menus.AdvanceInstall GHCup.Brick.Widgets.Menus.CompileGHC + GHCup.Brick.Widgets.Menus.CompileHLS GHCup.Brick.Actions GHCup.Brick.App GHCup.Brick.BrickState diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index ab5c3ed9..f1db3c00 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -75,6 +75,7 @@ import Optics.Operators ((.~),(%~)) import Optics.Getter (view) import Optics.Optic ((%)) import Optics ((^.), to) +import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS @@ -535,6 +536,7 @@ keyHandlers KeyBindings {..} = contextMenu .= ContextMenu.create r bQuit advanceInstallMenu .= AdvanceInstall.create bQuit compileGHCMenu .= CompileGHC.create bQuit + compileHLSMenu .= CompileHLS.create bQuit -- Set mode to context mode .= ContextPanel pure () diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 4552eab7..5dcc9049 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -25,7 +25,7 @@ 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) +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 @@ -65,6 +65,7 @@ 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 app :: AttrMap -> AttrMap -> App BrickState () Name app attrs dimAttrs = @@ -94,7 +95,7 @@ drawUI dimAttrs st = 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 @@ -136,7 +137,8 @@ contextMenuHandler ev = do && n `elem` [Menu.fieldName button | button <- buttons] -> mode .= Navigation (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel - (VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompilieButton) ) -> mode .= Common.CompileGHCPanel + (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 () @@ -172,6 +174,22 @@ compileGHCHandler ev = do -> mode .= ContextPanel _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev + +compileHLSHandler :: BrickEvent Name e -> EventM Name BrickState () +compileHLSHandler ev = do + ctx <- use compileHLSMenu + let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent + buttons = ctx ^. Menu.menuButtonsL + (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL + case (ev, focusedElement) of + (_ , Nothing) -> pure () + (VtyEvent (Vty.EvKey k m), Just n) + | k == exitKey + && m == mods + && n `elem` [Menu.fieldName button | button <- buttons] + -> mode .= ContextPanel + _ -> Common.zoom compileHLSMenu $ CompileHLS.handler ev + eventHandler :: BrickEvent Name e -> EventM Name BrickState () eventHandler ev = do m <- use mode @@ -182,3 +200,4 @@ eventHandler ev = do ContextPanel -> contextMenuHandler ev AdvanceInstallPanel -> advanceInstallHandler ev CompileGHCPanel -> compileGHCHandler ev + CompileHLSPanel -> compileHLSHandler ev diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs index 7ac36f3d..a88d61ca 100644 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -35,6 +35,7 @@ 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 @@ -44,6 +45,7 @@ data BrickState = BrickState , _contextMenu :: ContextMenu , _advanceInstallMenu :: AdvanceInstallMenu , _compileGHCMenu :: CompileGHCMenu + , _compileHLSMenu :: CompileHLSMenu , _appKeys :: KeyBindings , _mode :: Mode } diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index e209c3af..5d6b5af4 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -45,7 +45,8 @@ module GHCup.Brick.Common ( , TargetGhcEditBox, BootstrapGhcEditBox, JobsEditBox, BuildConfigEditBox , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton - , CompilieButton + , CompileGHCButton, CompileHLSButton, CabalProjectEditBox + , CabalProjectLocalEditBox, UpdateCabalCheckBox ) ) where import GHCup.List ( ListResult ) @@ -75,8 +76,10 @@ pattern OkButton :: ResourceId pattern OkButton = ResourceId 0 pattern AdvanceInstallButton :: ResourceId pattern AdvanceInstallButton = ResourceId 100 -pattern CompilieButton :: ResourceId -pattern CompilieButton = ResourceId 101 +pattern CompileGHCButton :: ResourceId +pattern CompileGHCButton = ResourceId 101 +pattern CompileHLSButton :: ResourceId +pattern CompileHLSButton = ResourceId 102 pattern UrlEditBox :: ResourceId pattern UrlEditBox = ResourceId 1 @@ -110,6 +113,14 @@ 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 + + -- | 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 @@ -133,6 +144,7 @@ data Mode = Navigation | ContextPanel | AdvanceInstallPanel | CompileGHCPanel + | CompileHLSPanel deriving (Eq, Show, Ord) installedSign :: String diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs new file mode 100644 index 00000000..e7085fcd --- /dev/null +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -0,0 +1,174 @@ +{-# 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) where + +import GHCup.Brick.Widgets.Menu (Menu) +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 (KeyCombination, VersionPattern, ToolVersion) +import URI.ByteString (URI) +import qualified Data.Text as T +import qualified Data.ByteString.UTF8 as UTF8 +import GHCup.Utils (parseURI) +import Data.Bifunctor (Bifunctor(..)) +import Data.Function ((&)) +import Optics ((.~)) +import Data.Char (isSpace) +import System.FilePath (isValid, isAbsolute, normalise) +import Control.Applicative (Alternative((<|>))) +import Text.Read (readEither) +import GHCup.Prelude (stripNewlineEnd) +import qualified GHCup.OptParse.Common as OptParse + +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] + } deriving (Eq, Show) + +makeLenses ''CompileHLSOptions + +type CompileHLSMenu = Menu CompileHLSOptions Name + +create :: KeyCombination -> CompileHLSMenu +create k = Menu.createMenu CompileGHCBox initialState k buttons fields + where + initialState = + CompileHLSOptions + Nothing + False + False + Nothing + Nothing + Nothing + Nothing + 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 + + cabalProjectV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath URI)) + cabalProjectV i = + case not $ emptyEditor i of + True -> + let readPath = Right . Left . stripNewlineEnd . T.unpack $ i + in bimap T.pack Just $ second Right (readUri i) <|> readPath + False -> Right Nothing + + {- There is an unwanted dependency to ghcup-opt... Alternatives are + - copy-paste a bunch of code + - define a new common library + -} + ghcVersionTagEither :: T.Text -> Either Menu.ErrorMessage [ToolVersion] + ghcVersionTagEither = first T.pack . traverse (OptParse.ghcVersionTagEither . T.unpack) . T.split isSpace + + overWriteVersionParser :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) + overWriteVersionParser = bimap T.pack Just . OptParse.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 + + readUri :: T.Text -> Either String URI + readUri = first show . parseURI . UTF8.fromString . T.unpack + + patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) + patchesV = whenEmpty Nothing readPatches + where + readPatches j = + let + x = (bimap T.unpack (fmap Left) $ filepathV j) + y = second (Just . Right) $ traverse readUri (T.split isSpace j) + in first T.pack $ x <|> y + + filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) + filepathV i = + case not $ emptyEditor i of + True -> absolutePathParser (T.unpack i) + False -> Right Nothing + + absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath) + absolutePathParser f = case isValid f && isAbsolute f of + True -> Right . Just . stripNewlineEnd . normalise $ f + False -> Left "Please enter a valid absolute filepath." + + additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] + additionalValidator = Right . T.split isSpace + + fields = + [ 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) (bimap T.pack Just . readUri) 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.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.createEditableField (Common.MenuElement Common.TargetGhcEditBox) ghcVersionTagEither targetGHCs + & Menu.fieldLabelL .~ "target GHC" + & Menu.fieldHelpMsgL .~ "For which GHC version to compile for (can be specified multiple times)" + , 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.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 .~ "CONFIGURE_ARGS" + & Menu.fieldHelpMsgL .~ "Additional arguments to cabal install, prefix with '-- ' (longopts)" + , 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" + ] + + buttons = [ + Menu.createButtonField (Common.MenuElement Common.OkButton) + & Menu.fieldLabelL .~ "Compile" + & Menu.fieldHelpMsgL .~ "Compile HLS from source with options below" + ] + +handler :: BrickEvent Name e -> EventM Name CompileHLSMenu () +handler = Menu.handlerMenu + + +draw :: CompileHLSMenu -> Widget Name +draw = Common.frontwardLayer "Compile HLS" . Menu.drawMenu diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs index 434183af..1302231f 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs @@ -35,14 +35,18 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons [] Menu.createButtonField (MenuElement Common.AdvanceInstallButton) & Menu.fieldLabelL .~ "Install" & Menu.fieldHelpMsgL .~ "Advance Installation Settings" - compileButton = - Menu.createButtonField (MenuElement Common.CompilieButton) + compileGhcButton = + Menu.createButtonField (MenuElement Common.CompileGHCButton) & Menu.fieldLabelL .~ "Compile" - & Menu.fieldHelpMsgL .~ "Compile tool from source" + & 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, compileButton] - HLS -> [advInstallButton, compileButton] + GHC -> [advInstallButton, compileGhcButton] + HLS -> [advInstallButton, compileHLSButton] _ -> [advInstallButton] draw :: ContextMenu -> Widget Name diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index e3d6c017..8875d5eb 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -37,6 +37,7 @@ import Prelude hiding ( appendFile ) import System.Exit ( ExitCode(ExitFailure), exitWith ) import qualified Data.Text as T +import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS @@ -67,6 +68,7 @@ brickMain s = do (ContextMenu.create e exit_key) (AdvanceInstall.create (bQuit . keyBindings $ s )) (CompileGHC.create exit_key) + (CompileHLS.create exit_key) (keyBindings s) Common.Navigation in Brick.defaultMain initapp initstate From 246851b43d9ed90de7d488558bff36fc836469b5 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 13 Mar 2024 16:38:05 +0100 Subject: [PATCH 11/33] untested compileGHC IOAction --- lib-tui/GHCup/Brick/Actions.hs | 90 +++++++++++++++++++ lib-tui/GHCup/Brick/App.hs | 3 + .../GHCup/Brick/Widgets/Menus/CompileGHC.hs | 59 +++++++----- 3 files changed, 132 insertions(+), 20 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index f1db3c00..2728d05c 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -76,6 +76,8 @@ 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 @@ -457,6 +459,94 @@ 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 + ] + compileResult <- run (do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + let vi = getVersionInfo (mkTVer lVer) GHC dls + 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 + + targetVer <- liftE $ GHCup.compileGHC + (GHC.SourceDist lVer) + (compopts ^. CompileGHC.crossTarget) + (compopts ^. CompileGHC.overwriteVer) + (compopts ^. CompileGHC.bootstrapGhc) + (compopts ^. CompileGHC.jobs) + (compopts ^. CompileGHC.buildConfig) + (compopts ^. CompileGHC.patches) + (compopts ^. CompileGHC.addConfArgs) + (compopts ^. CompileGHC.buildFlavour) + (compopts ^. CompileGHC.buildSystem) + (maybe GHCupInternal IsolateDir $ compopts ^. CompileGHC.isolateDir) + 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 + logWarn $ + "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall" + pure $ Right () + VLeft (V (DirNotEmpty fp)) -> do + logError $ + "Install directory " <> T.pack fp <> " is not empty." + pure $ Right () + VLeft err@(V (BuildFailed tmpdir _)) -> do + case keepDirs (appstate & settings) of + Never -> logError $ T.pack $ prettyHFError err + _ -> logError $ T.pack (prettyHFError err) <> "\n" + <> "Check the logs at " <> T.pack (fromGHCupPath (appstate & dirs & logsDir)) + <> " and the build directory " + <> T.pack tmpdir <> " for more clues." <> "\n" + <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards." + pure $ Right () + VLeft e -> do + logError $ T.pack $ prettyHFError e + pure $ Right () +-- This is the case when the tool is not GHC... which should be impossible but, +-- it exhaustes pattern matches +compileGHC _ (_, ListResult{lTool = _}) = pure (Right ()) + settings' :: IORef AppState {-# NOINLINE settings' #-} diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 5dcc9049..1fed39ea 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -172,6 +172,9 @@ compileGHCHandler ev = do && m == mods && n `elem` [Menu.fieldName button | button <- buttons] -> mode .= ContextPanel + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do + let iopts = ctx ^. Menu.menuStateL + Actions.withIOAction $ Actions.compileGHC iopts _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index 6712687a..8b243832 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -14,7 +14,24 @@ {-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -module GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCOptions, CompileGHCMenu, create, handler, draw) where +module GHCup.Brick.Widgets.Menus.CompileGHC ( + CompileGHCOptions, + CompileGHCMenu, + create, + handler, + draw, + bootstrapGhc, + jobs, + buildConfig, + patches, + crossTarget, + addConfArgs, + setCompile, + overwriteVer, + buildFlavour, + buildSystem, + isolateDir, +) where import GHCup.Brick.Widgets.Menu (Menu) import qualified GHCup.Brick.Widgets.Menu as Menu @@ -26,7 +43,8 @@ import Brick import Prelude hiding ( appendFile ) import Optics.TH (makeLenses) import qualified GHCup.Brick.Common as Common -import GHCup.Types (KeyCombination, BuildSystem (Hadrian)) +import GHCup.Types + ( KeyCombination, BuildSystem(Hadrian), VersionPattern ) import URI.ByteString (URI) import qualified Data.Text as T import qualified Data.ByteString.UTF8 as UTF8 @@ -40,6 +58,7 @@ import System.FilePath (isPathSeparator, isValid, isAbsolute, normalise) import Control.Applicative (Alternative((<|>))) import Text.Read (readEither) import GHCup.Prelude (stripNewlineEnd) +import qualified GHCup.OptParse.Common as OptParse data CompileGHCOptions = CompileGHCOptions { _bootstrapGhc :: Either Version FilePath @@ -49,7 +68,7 @@ data CompileGHCOptions = CompileGHCOptions , _crossTarget :: Maybe T.Text , _addConfArgs :: [T.Text] , _setCompile :: Bool - , _ovewrwiteVer :: Maybe Version + , _overwriteVer :: Maybe [VersionPattern] , _buildFlavour :: Maybe String , _buildSystem :: Maybe BuildSystem , _isolateDir :: Maybe FilePath @@ -62,8 +81,8 @@ type CompileGHCMenu = Menu CompileGHCOptions Name create :: KeyCombination -> CompileGHCMenu create k = Menu.createMenu CompileGHCBox initialState k buttons fields where - initialState = - CompileGHCOptions + initialState = + CompileGHCOptions (Right "") Nothing Nothing @@ -83,39 +102,39 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields bootstrapV :: T.Text -> Either Menu.ErrorMessage (Either Version FilePath) bootstrapV i = case not $ emptyEditor i of - True -> + True -> let readVersion = bimap (const "Not a valid version") Left (version (T.init i)) -- Brick adds \n at the end, hence T.init - readPath = do + readPath = do mfilepath <- filepathV i case mfilepath of Nothing -> Left "Invalid Empty value" Just f -> Right (Right f) - in if T.any isPathSeparator i + in if T.any isPathSeparator i then readPath else readVersion False -> Left "Invalid Empty value" - versionV :: T.Text -> Either Menu.ErrorMessage (Maybe Version) - versionV = bimap (const "Not a valid version") Just . version . T.init -- Brick adds \n at the end, hence T.init + versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) + versionV = whenEmpty Nothing (bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack . T.init) -- Brick adds \n at the end, hence T.init jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int) - jobsV = + jobsV = let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack - in whenEmpty Nothing parseInt + in whenEmpty Nothing parseInt patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) patchesV = whenEmpty Nothing readPatches - where + where readUri :: T.Text -> Either String URI - readUri = first show . parseURI . UTF8.fromString . T.unpack - readPatches j = - let + readUri = first show . parseURI . UTF8.fromString . T.unpack + readPatches j = + let x = (bimap T.unpack (fmap Left) $ filepathV j) y = second (Just . Right) $ traverse readUri (T.split isSpace j) in first T.pack $ x <|> y filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) - filepathV i = + filepathV i = case not $ emptyEditor i of True -> absolutePathParser (T.unpack i) False -> Right Nothing @@ -130,13 +149,13 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields systemV :: T.Text -> Either Menu.ErrorMessage (Maybe BuildSystem) systemV = whenEmpty Nothing readSys - where + where readSys i | T.toLower i == "hadrian" = Right $ Just Hadrian | T.toLower i == "make" = Right $ Just Hadrian | otherwise = Left "Not a valid Build System" - fields = + fields = [ 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)" @@ -159,7 +178,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile & Menu.fieldLabelL .~ "set" & Menu.fieldHelpMsgL .~ "Set as active version after install" - , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV ovewrwiteVer + , 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" , Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour From 588cf68a2be051ffe239c54d3c0d20d539d8c4dd Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 13 Mar 2024 17:42:30 +0100 Subject: [PATCH 12/33] untested compile HLS --- lib-tui/GHCup/Brick/Actions.hs | 85 ++++++++++++++++++- lib-tui/GHCup/Brick/App.hs | 3 + .../GHCup/Brick/Widgets/Menus/CompileHLS.hs | 19 ++++- 3 files changed, 105 insertions(+), 2 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 2728d05c..57a13d0b 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -78,6 +78,8 @@ 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.OptParse.Common as OptParse +import qualified GHCup.HLS as HLS @@ -535,7 +537,7 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do case keepDirs (appstate & settings) of Never -> logError $ T.pack $ prettyHFError err _ -> logError $ T.pack (prettyHFError err) <> "\n" - <> "Check the logs at " <> T.pack (fromGHCupPath (appstate & dirs & logsDir)) + <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir) <> " and the build directory " <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards." @@ -548,6 +550,87 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do 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 + ] + compileResult <- run (do + AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask + let vi = getVersionInfo (mkTVer lVer) GHC dls + 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 + + ghcs <- + liftE $ forM (compopts ^. CompileHLS.targetGHCs) + (\ghc -> fmap (_tvVersion . fst) . OptParse.fromVersion (Just ghc) $ GHC) + targetVer <- liftE $ GHCup.compileHLS + (HLS.SourceDist lVer) + 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 _)) -> do + case keepDirs (appstate & settings) of + Never -> logError $ T.pack $ prettyHFError err + _ -> logError $ T.pack (prettyHFError err) <> "\n" + <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir) + <> " and the build directory " + <> T.pack tmpdir <> " for more clues." <> "\n" + <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards." + pure $ Right () + VLeft e -> do + logError $ T.pack $ prettyHFError e + pure $ Right () +-- 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 diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 1fed39ea..35309a8a 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -191,6 +191,9 @@ compileHLSHandler ev = do && m == mods && n `elem` [Menu.fieldName button | button <- buttons] -> mode .= ContextPanel + (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do + let iopts = ctx ^. Menu.menuStateL + Actions.withIOAction $ Actions.compileHLS iopts _ -> Common.zoom compileHLSMenu $ CompileHLS.handler ev eventHandler :: BrickEvent Name e -> EventM Name BrickState () diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs index e7085fcd..1bcd2fdd 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -14,7 +14,24 @@ {-# LANGUAGE InstanceSigs #-} {-# OPTIONS_GHC -Wno-incomplete-patterns #-} -module GHCup.Brick.Widgets.Menus.CompileHLS (CompileHLSOptions, CompileHLSMenu, create, handler, draw) where +module GHCup.Brick.Widgets.Menus.CompileHLS ( + CompileHLSOptions, + CompileHLSMenu, + create, + handler, + draw, + jobs, + setCompile, + updateCabal, + overwriteVer, + isolateDir, + cabalProject, + cabalProjectLocal, + patches, + targetGHCs, + cabalArgs, +) +where import GHCup.Brick.Widgets.Menu (Menu) import qualified GHCup.Brick.Widgets.Menu as Menu From 51b94fb98ee8a7aa6e63b6e0b1e9df99412674ab Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 13 Mar 2024 18:12:00 +0100 Subject: [PATCH 13/33] Execute action only if inputs are valid + better UX --- lib-tui/GHCup/Brick/App.hs | 7 +++++-- lib-tui/GHCup/Brick/Widgets/Menu.hs | 15 ++++++++++++--- lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs | 1 + 3 files changed, 18 insertions(+), 5 deletions(-) diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 35309a8a..fc1fc7ac 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -66,6 +66,7 @@ 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 (when) app :: AttrMap -> AttrMap -> App BrickState () Name app attrs dimAttrs = @@ -174,7 +175,8 @@ compileGHCHandler ev = do -> mode .= ContextPanel (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do let iopts = ctx ^. Menu.menuStateL - Actions.withIOAction $ Actions.compileGHC iopts + when (Menu.isValidMenu ctx) + (Actions.withIOAction $ Actions.compileGHC iopts) _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev @@ -193,7 +195,8 @@ compileHLSHandler ev = do -> mode .= ContextPanel (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do let iopts = ctx ^. Menu.menuStateL - Actions.withIOAction $ Actions.compileHLS iopts + when (Menu.isValidMenu ctx) + (Actions.withIOAction $ Actions.compileHLS iopts) _ -> Common.zoom compileHLSMenu $ CompileHLS.handler ev eventHandler :: BrickEvent Name e -> EventM Name BrickState () diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 4a3a39bc..6443abc8 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -93,7 +93,7 @@ idFormatter = const id -- | An error message type ErrorMessage = T.Text -data ErrorStatus = Valid | Invalid ErrorMessage +data ErrorStatus = Valid | Invalid ErrorMessage deriving (Eq) -- | A lens which does nothing. Usefull to defined no-op fields emptyLens :: Lens' s () @@ -137,6 +137,8 @@ data MenuField s n where , fieldName :: n } -> MenuField s n +isValidField :: MenuField s n -> Bool +isValidField = (== Valid) . fieldStatus makeLensesFor [ ("fieldLabel", "fieldLabelL") @@ -226,7 +228,9 @@ type Button = MenuField createButtonInput :: FieldInput () () n createButtonInput = FieldInput () Right "" drawButton (const $ pure ()) - where drawButton _ _ help _ amp = amp . centerV . renderAsHelpMsg $ help + where + drawButton True (Invalid err) _ _ amp = amp . centerV . renderAsErrMsg $ err + drawButton _ _ help _ amp = amp . centerV . renderAsHelpMsg $ help createButtonField :: n -> Button s n createButtonField = MenuField emptyLens createButtonInput "" Valid @@ -281,7 +285,6 @@ data Menu s n , menuName :: n -- ^ The resource Name. } - makeLensesFor [ ("menuFields", "menuFieldsL"), ("menuState", "menuStateL") , ("menuButtons", "menuButtonsL"), ("menuFocusRing", "menuFocusRingL") @@ -289,6 +292,9 @@ makeLensesFor ] ''Menu +isValidMenu :: Menu s n -> Bool +isValidMenu = all isValidField . menuFields + createMenu :: n -> s -> KeyCombination -> [Button s n] -> [MenuField s n] -> Menu s n createMenu n initial exitK buttons fields = Menu fields initial buttons ring exitK n where ring = F.focusRing $ [field & fieldName | field <- fields] ++ [button & fieldName | button <- buttons] @@ -307,6 +313,9 @@ handlerMenu ev = Nothing -> pure () Just n -> do updated_fields <- updateFields n (VtyEvent e) fields + if all isValidField updated_fields + then menuButtonsL %= fmap (fieldStatusL .~ Valid) + else menuButtonsL %= fmap (fieldStatusL .~ Invalid "Some fields are invalid") menuFieldsL .= updated_fields _ -> pure () where diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index 8b243832..0acc1825 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -196,6 +196,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields Menu.createButtonField (Common.MenuElement Common.OkButton) & Menu.fieldLabelL .~ "Compile" & Menu.fieldHelpMsgL .~ "Compile GHC from source with options below" + & Menu.fieldStatusL .~ Menu.Invalid "bootstrap GHC is mandatory" ] handler :: BrickEvent Name e -> EventM Name CompileGHCMenu () From 9a16dcc55cdf83d7cae7a5b6089968cd58e8784a Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sat, 16 Mar 2024 16:14:24 +0100 Subject: [PATCH 14/33] Remove trailing white space --- lib-tui/GHCup/Brick/Actions.hs | 76 +++++++++---------- lib-tui/GHCup/Brick/App.hs | 26 +++---- lib-tui/GHCup/Brick/Attributes.hs | 2 - lib-tui/GHCup/Brick/BrickState.hs | 8 +- lib-tui/GHCup/Brick/Common.hs | 10 +-- lib-tui/GHCup/Brick/Widgets/KeyInfo.hs | 4 +- lib-tui/GHCup/Brick/Widgets/Menu.hs | 36 ++++----- .../Brick/Widgets/Menus/AdvanceInstall.hs | 10 +-- .../GHCup/Brick/Widgets/Menus/CompileHLS.hs | 2 +- lib-tui/GHCup/Brick/Widgets/Menus/Context.hs | 6 +- lib-tui/GHCup/Brick/Widgets/Navigation.hs | 2 +- lib-tui/GHCup/Brick/Widgets/SectionList.hs | 28 +++---- lib-tui/GHCup/Brick/Widgets/Tutorial.hs | 2 +- lib-tui/GHCup/BrickMain.hs | 10 +-- 14 files changed, 110 insertions(+), 112 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 57a13d0b..dc1facb7 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -83,7 +83,7 @@ import qualified GHCup.HLS as HLS -{- Core Logic. +{- Core Logic. This module defines the IO actions we can execute within the Brick App: - Install @@ -116,7 +116,7 @@ constructList appD settings = selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState selectBy tool predicate internal_state = let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state) - tool_lens = sectionL (Singular tool) + tool_lens = sectionL (Singular tool) in internal_state & sectionListFocusRingL .~ new_focus & tool_lens %~ L.listMoveTo 0 -- We move to 0 first @@ -184,7 +184,7 @@ installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFai -> m (Either String ()) installWithOptions opts (_, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - let + let misolated = opts ^. AdvanceInstall.isolateDirL shouldIsolate = maybe GHCupInternal IsolateDir (opts ^. AdvanceInstall.isolateDirL) shouldForce = opts ^. AdvanceInstall.forceInstallL @@ -233,15 +233,15 @@ installWithOptions opts (_, ListResult {..}) = do case opts ^. AdvanceInstall.instBindistL of Nothing -> do liftE $ - runBothE' + runBothE' (installGHCBin v shouldIsolate shouldForce extraArgs) (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing)) - pure (vi, dirs, ce) + pure (vi, dirs, ce) Just uri -> do liftE $ - runBothE' + runBothE' (installGHCBindist - (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) + (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) v shouldIsolate shouldForce @@ -253,14 +253,14 @@ installWithOptions opts (_, ListResult {..}) = do let vi = getVersionInfo v Cabal dls case opts ^. AdvanceInstall.instBindistL of Nothing -> do - liftE $ - runBothE' + liftE $ + runBothE' (installCabalBin lVer shouldIsolate shouldForce) (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer)) pure (vi, dirs, ce) Just uri -> do - liftE $ - runBothE' + liftE $ + runBothE' (installCabalBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce) (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer)) pure (vi, dirs, ce) @@ -268,19 +268,19 @@ installWithOptions opts (_, ListResult {..}) = do GHCup -> do let vi = snd <$> getLatest dls GHCup liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) - HLS -> do + HLS -> do let vi = getVersionInfo v HLS dls case opts ^. AdvanceInstall.instBindistL of Nothing -> do - liftE $ - runBothE' + liftE $ + runBothE' (installHLSBin lVer shouldIsolate shouldForce) (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS lVer SetHLSOnly Nothing)) - pure (vi, dirs, ce) + pure (vi, dirs, ce) Just uri -> do - liftE $ - runBothE' - (installHLSBindist + liftE $ + runBothE' + (installHLSBindist (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing) lVer shouldIsolate @@ -293,13 +293,13 @@ installWithOptions opts (_, ListResult {..}) = do case opts ^. AdvanceInstall.instBindistL of Nothing -> do liftE $ - runBothE' + runBothE' (installStackBin lVer shouldIsolate shouldForce) (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer)) pure (vi, dirs, ce) Just uri -> do liftE $ - runBothE' + runBothE' (installStackBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce) (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer)) pure (vi, dirs, ce) @@ -330,7 +330,7 @@ installWithOptions opts (_, ListResult {..}) = do VLeft e -> pure $ Left $ prettyHFError e <> "\n" <> "Also check the logs in ~/.ghcup/logs" -install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) +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 False []) @@ -461,11 +461,11 @@ 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 :: (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 = + let run = runResourceT . runE @'[ AlreadyInstalled , BuildFailed @@ -500,7 +500,7 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene - targetVer <- liftE $ GHCup.compileGHC + targetVer <- liftE $ GHCup.compileGHC (GHC.SourceDist lVer) (compopts ^. CompileGHC.crossTarget) (compopts ^. CompileGHC.overwriteVer) @@ -536,10 +536,10 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do VLeft err@(V (BuildFailed tmpdir _)) -> do case keepDirs (appstate & settings) of Never -> logError $ T.pack $ prettyHFError err - _ -> logError $ T.pack (prettyHFError err) <> "\n" - <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir) + _ -> logError $ T.pack (prettyHFError err) <> "\n" + <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir) <> " and the build directory " - <> T.pack tmpdir <> " for more clues." <> "\n" + <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards." pure $ Right () VLeft e -> do @@ -550,11 +550,11 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do compileGHC _ (_, ListResult{lTool = _}) = pure (Right ()) -compileHLS :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) +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 = + let run = runResourceT . runE @'[ AlreadyInstalled , BuildFailed @@ -587,10 +587,10 @@ compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do "...waiting for 5 seconds, you can still abort..." liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene - ghcs <- - liftE $ forM (compopts ^. CompileHLS.targetGHCs) + ghcs <- + liftE $ forM (compopts ^. CompileHLS.targetGHCs) (\ghc -> fmap (_tvVersion . fst) . OptParse.fromVersion (Just ghc) $ GHC) - targetVer <- liftE $ GHCup.compileHLS + targetVer <- liftE $ GHCup.compileHLS (HLS.SourceDist lVer) ghcs (compopts ^. CompileHLS.jobs) @@ -617,10 +617,10 @@ compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do VLeft err@(V (BuildFailed tmpdir _)) -> do case keepDirs (appstate & settings) of Never -> logError $ T.pack $ prettyHFError err - _ -> logError $ T.pack (prettyHFError err) <> "\n" + _ -> logError $ T.pack (prettyHFError err) <> "\n" <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir) <> " and the build directory " - <> T.pack tmpdir <> " for more clues." <> "\n" + <> T.pack tmpdir <> " for more clues." <> "\n" <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards." pure $ Right () VLeft e -> do @@ -675,7 +675,7 @@ getAppData mgi = runExceptT $ do lV <- listVersions Nothing [] False True (Nothing, Nothing) pure $ BrickData (reverse lV) --- +-- keyHandlers :: KeyBindings -> [ ( KeyCombination @@ -700,7 +700,7 @@ keyHandlers KeyBindings {..} = , (KeyCombination Vty.KEnter [], const "advance options", createMenuforTool ) ] where - createMenuforTool = do + createMenuforTool = do e <- use (appState % to sectionListSelectedElement) case e of Nothing -> pure () @@ -715,9 +715,9 @@ keyHandlers KeyBindings {..} = pure () --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () - hideShowHandler' f = do + hideShowHandler' f = do app_settings <- use appSettings - let + let vers = f app_settings newAppSettings = app_settings & Common.showAllVersions .~ vers ad <- use appData diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index fc1fc7ac..bde89e82 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -79,12 +79,12 @@ app attrs dimAttrs = drawUI :: AttrMap -> BrickState -> [Widget Name] drawUI dimAttrs st = - let + let footer = Brick.withAttr Attributes.helpAttr . Brick.txtWrap . T.pack . foldr1 (\x y -> x <> " " <> y) - . fmap (\(KeyCombination key mods, pretty_setting, _) + . fmap (\(KeyCombination key mods, pretty_setting, _) -> intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) <> ":" <> pretty_setting (st ^. appSettings) ) $ Actions.keyHandlers (st ^. appKeys) @@ -98,7 +98,7 @@ drawUI dimAttrs st = CompileGHCPanel -> [CompileGHC.draw (st ^. compileGHCMenu), navg] CompileHLSPanel -> [CompileHLS.draw (st ^. compileHLSMenu), navg] --- | On q, go back to navigation. +-- | On q, go back to navigation. -- On Enter, to go to tutorial keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState () keyInfoHandler ev = case ev of @@ -113,7 +113,7 @@ tutorialHandler ev = VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation _ -> pure () --- | Tab/Arrows to navigate. +-- | Tab/Arrows to navigate. navigationHandler :: BrickEvent Name e -> EventM Name BrickState () navigationHandler ev = do AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings' @@ -126,25 +126,25 @@ navigationHandler ev = do contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState () contextMenuHandler ev = do - ctx <- use contextMenu + ctx <- use contextMenu let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent buttons = ctx ^. Menu.menuButtonsL (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL case (ev, focusedElement) of (_ , Nothing) -> pure () - (VtyEvent (Vty.EvKey k m), Just n) - | k == exitKey - && m == mods + (VtyEvent (Vty.EvKey k m), Just n) + | k == exitKey + && m == mods && n `elem` [Menu.fieldName button | button <- buttons] -> 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 ev = do - ctx <- use advanceInstallMenu + ctx <- use advanceInstallMenu let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent buttons = ctx ^. Menu.menuButtonsL (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL @@ -162,7 +162,7 @@ advanceInstallHandler ev = do compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState () compileGHCHandler ev = do - ctx <- use compileGHCMenu + ctx <- use compileGHCMenu let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent buttons = ctx ^. Menu.menuButtonsL (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL @@ -175,14 +175,14 @@ compileGHCHandler ev = do -> mode .= ContextPanel (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do let iopts = ctx ^. Menu.menuStateL - when (Menu.isValidMenu ctx) + when (Menu.isValidMenu ctx) (Actions.withIOAction $ Actions.compileGHC iopts) _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev compileHLSHandler :: BrickEvent Name e -> EventM Name BrickState () compileHLSHandler ev = do - ctx <- use compileHLSMenu + ctx <- use compileHLSMenu let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent buttons = ctx ^. Menu.menuButtonsL (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL diff --git a/lib-tui/GHCup/Brick/Attributes.hs b/lib-tui/GHCup/Brick/Attributes.hs index 46333af0..f7641be6 100644 --- a/lib-tui/GHCup/Brick/Attributes.hs +++ b/lib-tui/GHCup/Brick/Attributes.hs @@ -46,10 +46,8 @@ defaultAttributes no_color = Brick.attrMap where withForeColor | no_color = const | otherwise = Vty.withForeColor - withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo | otherwise = Vty.withBackColor - withStyle = Vty.withStyle diff --git a/lib-tui/GHCup/Brick/BrickState.hs b/lib-tui/GHCup/Brick/BrickState.hs index a88d61ca..ab59b74f 100644 --- a/lib-tui/GHCup/Brick/BrickState.hs +++ b/lib-tui/GHCup/Brick/BrickState.hs @@ -14,15 +14,15 @@ {-# LANGUAGE InstanceSigs #-} {- -This module contains the BrickState. One could be tempted to include this data structure in GHCup.Brick.Common, +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, +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 + BrickState `depends on` Widgets.XYZ `depends on` Common -The linear relation above breaks if BrickState is defined in Common. +The linear relation above breaks if BrickState is defined in Common. -} diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 5d6b5af4..7f769c07 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -121,7 +121,7 @@ pattern UpdateCabalCheckBox :: ResourceId pattern UpdateCabalCheckBox = ResourceId 18 --- | Name data type. Uniquely identifies each widget in the TUI. +-- | 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 @@ -129,8 +129,8 @@ data Name = AllTools -- ^ The main list widget | 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 + | 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. @@ -142,7 +142,7 @@ data Mode = Navigation | KeyInfo | Tutorial | ContextPanel - | AdvanceInstallPanel + | AdvanceInstallPanel | CompileGHCPanel | CompileHLSPanel deriving (Eq, Show, Ord) @@ -195,7 +195,7 @@ frontwardLayer layer_name = . Brick.withBorderStyle Border.unicode . Border.borderWithLabel (Brick.txt layer_name) --- I refuse to give this a type signature. +-- I refuse to give this a type signature. -- | Given a lens, zoom on it. It is needed because Brick uses microlens but GHCup uses optics. zoom l = Brick.zoom (toLensVL l) diff --git a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs index 8d07546b..6f976383 100644 --- a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs +++ b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs @@ -9,7 +9,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {- -A very simple information-only widget with no handler. +A very simple information-only widget with no handler. -} module GHCup.Brick.Widgets.KeyInfo where @@ -20,7 +20,7 @@ import qualified GHCup.Brick.Common as Common import Brick ( Padding(Max), - Widget(..), + Widget(..), (<+>), (<=>)) import qualified Brick diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 6443abc8..265379a6 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -34,9 +34,9 @@ An input (type FieldInput) consist in 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}) +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 @@ -113,7 +113,7 @@ data FieldInput a b n = -> HelpMessage -> b -> (Widget n -> Widget n) - -> Widget n -- ^ How to draw the input, with focus a help message and input. + -> Widget n -- ^ How to draw the input, with focus a help message and input. -- A extension function can be applied too , inputHandler :: BrickEvent n () -> EventM n b () -- ^ The handler } @@ -138,7 +138,7 @@ data MenuField s n where } -> MenuField s n isValidField :: MenuField s n -> Bool -isValidField = (== Valid) . fieldStatus +isValidField = (== Valid) . fieldStatus makeLensesFor [ ("fieldLabel", "fieldLabelL") @@ -181,7 +181,7 @@ createCheckBoxInput = FieldInput False Right "" checkBoxRender checkBoxHandler else border . Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign checkBoxRender focus _ help check f = let core = f $ drawBool check - in if focus + in if focus then core else core <+> (Brick.padLeft (Brick.Pad 1) . centerV . renderAsHelpMsg $ help) checkBoxHandler = \case @@ -201,14 +201,14 @@ createEditableInput :: (Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) createEditableInput name validator = FieldInput initEdit validateEditContent "" drawEdit Edit.handleEditorEvent where drawEdit focus errMsg help edi amp = - let + let borderBox = amp . Border.border . Brick.padRight Brick.Max editorRender = Edit.renderEditor (Brick.txt . T.unlines) focus edi isEditorEmpty = Edit.getEditContents edi == [mempty] in case errMsg of Valid | isEditorEmpty -> borderBox $ renderAsHelpMsg help | otherwise -> borderBox editorRender - Invalid msg + Invalid msg | focus && isEditorEmpty -> borderBox $ renderAsHelpMsg help | focus -> borderBox editorRender | otherwise -> borderBox $ renderAsErrMsg msg @@ -228,7 +228,7 @@ type Button = MenuField createButtonInput :: FieldInput () () n createButtonInput = FieldInput () Right "" drawButton (const $ pure ()) - where + where drawButton True (Invalid err) _ _ amp = amp . centerV . renderAsErrMsg $ err drawButton _ _ help _ amp = amp . centerV . renderAsHelpMsg $ help @@ -250,14 +250,14 @@ renderAslabel t focus = then highlighted $ Brick.txt t else Brick.txt t --- | Creates a left align column. +-- | 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 --- | center a line in three rows. +-- | center a line in three rows. centerV :: Widget n -> Widget n centerV = Brick.padTopBottom 1 @@ -273,8 +273,8 @@ renderAsErrMsg = Brick.withAttr Attributes.errMsgAttr . Brick.txt 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. +-- | 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. @@ -311,7 +311,7 @@ handlerMenu ev = fields <- use menuFieldsL case focused of Nothing -> pure () - Just n -> do + Just n -> do updated_fields <- updateFields n (VtyEvent e) fields if all isValidField updated_fields then menuButtonsL %= fmap (fieldStatusL .~ Valid) @@ -333,7 +333,7 @@ handlerMenu ev = drawMenu :: (Eq n, Ord n, Show n, Brick.Named (MenuField s n) n) => Menu s n -> Widget n -drawMenu menu = +drawMenu menu = Brick.vBox [ Brick.vBox buttonWidgets , Common.separator @@ -341,8 +341,8 @@ drawMenu menu = $ Brick.viewport (menu ^. menuNameL) Brick.Vertical $ Brick.vBox fieldWidgets , Brick.txt " " - , Brick.padRight Brick.Max $ - Brick.txt "Press " + , Brick.padRight Brick.Max $ + Brick.txt "Press " <+> Common.keyToWidget (menu ^. menuExitKeyL) <+> Brick.txt " to go back" ] @@ -353,7 +353,7 @@ drawMenu menu = 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. + -- 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 -> ((centerV . leftify (maxWidth + 10) $ f b) <+>) ) labelsWidgets diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs index 52983434..d88945d5 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -74,15 +74,15 @@ create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields initialState = InstallOptions Nothing False Nothing False [] -- Brick's internal editor representation is [mempty]. emptyEditor i = T.null i || (i == "\n") - + uriValidator :: T.Text -> Either Menu.ErrorMessage (Maybe URI) - uriValidator i = + uriValidator i = case not $ emptyEditor i of True -> bimap (T.pack . show) Just . parseURI . UTF8.fromString . T.unpack $ i False -> Right Nothing filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) - filepathValidator i = + filepathValidator i = case not $ emptyEditor i of True -> absolutePathParser (T.unpack i) False -> Right Nothing @@ -95,7 +95,7 @@ create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] additionalValidator = Right . T.split isSpace - fields = + fields = [ Menu.createEditableField (Common.MenuElement Common.UrlEditBox) uriValidator instBindistL & Menu.fieldLabelL .~ "url" & Menu.fieldHelpMsgL .~ "Install the specified version from this bindist" @@ -112,7 +112,7 @@ create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields & Menu.fieldLabelL .~ "CONFIGURE_ARGS" & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure, prefix with '-- ' (longopts)" ] - + ok = Menu.createButtonField (Common.MenuElement Common.OkButton) & Menu.fieldLabelL .~ "Advance Install" & Menu.fieldHelpMsgL .~ "Install with options below" diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs index 1bcd2fdd..c4e8e1ad 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -112,7 +112,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields overWriteVersionParser :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) overWriteVersionParser = bimap T.pack Just . OptParse.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 diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs index 1302231f..f9e11d37 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/Context.hs @@ -50,14 +50,14 @@ create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons [] _ -> [advInstallButton] draw :: ContextMenu -> Widget Name -draw menu = +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 " + , Brick.padRight Brick.Max $ + Brick.txt "Press " <+> Common.keyToWidget (menu ^. Menu.menuExitKeyL) <+> Brick.txt " to go back" ] diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs index f4826ebf..77de48e5 100644 --- a/lib-tui/GHCup/Brick/Widgets/Navigation.hs +++ b/lib-tui/GHCup/Brick/Widgets/Navigation.hs @@ -54,7 +54,7 @@ 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 + -> Int -- The height of each item in a list. Commonly 1 -> BrickInternalState create = SectionList.sectionList diff --git a/lib-tui/GHCup/Brick/Widgets/SectionList.hs b/lib-tui/GHCup/Brick/Widgets/SectionList.hs index 378f6eaa..ade14f28 100644 --- a/lib-tui/GHCup/Brick/Widgets/SectionList.hs +++ b/lib-tui/GHCup/Brick/Widgets/SectionList.hs @@ -15,8 +15,8 @@ {- A general system for lists with sections -Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing -the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). +Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing +the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). - To build a SectionList use the safe constructor sectionList - To access sections use the lens provider sectionL and the name of the section you'd like to access @@ -33,7 +33,7 @@ import Brick ( BrickEvent(VtyEvent, MouseDown), EventM, Size(..), - Widget(..), + Widget(..), ViewportType (Vertical), (<=>)) import qualified Brick @@ -68,8 +68,8 @@ makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListE type SectionList n e = GenericSectionList n V.Vector e --- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses. -sectionList :: Foldable t +-- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses. +sectionList :: Foldable t => n -- The name of the section list -> [(n, t e)] -- a list of tuples (section name, collection of elements) -> Int @@ -81,14 +81,14 @@ sectionList name elements height , sectionListName = name } -- | This lens constructor, takes a name and looks if a section has such a name. --- Used to dispatch events to sections. It is a partial function only meant to +-- Used to dispatch events to sections. It is a partial function only meant to -- be used with the FocusRing inside GenericSectionList sectionL :: Eq n => n -> Lens' (GenericSectionList n t e) (L.GenericList n t e) sectionL section_name = lens g s where is_section_name = (== section_name) . L.listName g section_list = let elms = section_list ^. sectionListElementsL - zeroth = elms V.! 0 -- TODO: This crashes for empty vectors. + zeroth = elms V.! 0 -- TODO: This crashes for empty vectors. in fromMaybe zeroth (V.find is_section_name elms) s gl@(GenericSectionList _ elms _) list = case V.findIndex is_section_name elms of @@ -97,16 +97,16 @@ sectionL section_name = lens g s in gl & sectionListElementsL .~ new_elms moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () -moveDown = do +moveDown = do ring <- use sectionListFocusRingL - case F.focusGetCurrent ring of + case F.focusGetCurrent ring of Nothing -> pure () Just l -> do -- If it is the last element, move to the first element of the next focus; else, just handle regular list event. current_list <- use (sectionL l) let current_idx = L.listSelected current_list list_length = current_list & length if current_idx == Just (list_length - 1) - then do + then do new_focus <- sectionListFocusRingL <%= F.focusNext case F.focusGetCurrent new_focus of Nothing -> pure () -- |- Optic.Zoom.zoom doesn't typecheck but Lens.Micro.Mtl.zoom does. It is re-exported by Brick @@ -122,10 +122,10 @@ moveUp = do current_list <- use (sectionL l) let current_idx = L.listSelected current_list if current_idx == Just 0 - then do + then do new_focus <- sectionListFocusRingL <%= F.focusPrev case F.focusGetCurrent new_focus of - Nothing -> pure () + Nothing -> pure () Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToEnd) else Common.zoom (sectionL l) $ Brick.modify L.listMoveUp @@ -188,6 +188,6 @@ renderSectionList renderElem sectionFocus ge@(GenericSectionList focus elms slNa -- | Equivalent to listSelectedElement sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) sectionListSelectedElement generic_section_list = do - current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent + current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent let current_section = generic_section_list ^. sectionL current_focus - L.listSelectedElement current_section + L.listSelectedElement current_section diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs index cba19a2f..ad3e40bb 100644 --- a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs +++ b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs @@ -9,7 +9,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {- -A very simple information-only widget with no handler. +A very simple information-only widget with no handler. -} module GHCup.Brick.Widgets.Tutorial (draw) where diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index 8875d5eb..ffd2ea2b 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -51,14 +51,14 @@ brickMain s = do Right ad -> do let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing current_element = Navigation.sectionListSelectedElement initial_list - exit_key = bQuit . keyBindings $ s + exit_key = bQuit . keyBindings $ s case current_element of Nothing -> do - flip runReaderT s $ logError "Error building app state: empty ResultList" + flip runReaderT s $ logError "Error building app state: empty ResultList" exitWith $ ExitFailure 2 Just (_, e) -> - let initapp = - BrickApp.app + let initapp = + BrickApp.app (Attributes.defaultAttributes $ noColor $ settings s) (Attributes.dimAttributes $ noColor $ settings s) initstate = @@ -71,7 +71,7 @@ brickMain s = do (CompileHLS.create exit_key) (keyBindings s) Common.Navigation - in Brick.defaultMain initapp initstate + in Brick.defaultMain initapp initstate $> () Left e -> do flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) From f6b948e35a5db94ee53621faba9d71116963ccc0 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sat, 16 Mar 2024 16:27:04 +0100 Subject: [PATCH 15/33] fix regression #875 and build system --- lib-tui/GHCup/Brick/App.hs | 4 ++-- lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs | 10 +++++----- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index bde89e82..4507b1b1 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -118,8 +118,8 @@ navigationHandler :: BrickEvent Name e -> EventM Name BrickState () navigationHandler ev = do AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings' case ev of - inner_event@(VtyEvent (Vty.EvKey key _)) -> - case find (\(key', _, _) -> key' == KeyCombination key []) (Actions.keyHandlers kb) of + 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 diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index 0acc1825..f6ab76b5 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -44,7 +44,7 @@ import Prelude hiding ( appendFile ) import Optics.TH (makeLenses) import qualified GHCup.Brick.Common as Common import GHCup.Types - ( KeyCombination, BuildSystem(Hadrian), VersionPattern ) + ( KeyCombination, BuildSystem(..), VersionPattern ) import URI.ByteString (URI) import qualified Data.Text as T import qualified Data.ByteString.UTF8 as UTF8 @@ -152,7 +152,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields where readSys i | T.toLower i == "hadrian" = Right $ Just Hadrian - | T.toLower i == "make" = Right $ Just Hadrian + | T.toLower i == "make" = Right $ Just Make | otherwise = Left "Not a valid Build System" fields = @@ -181,11 +181,11 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields , 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" - , 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.BuildSystemEditBox) systemV buildSystem & Menu.fieldLabelL .~ "build system" + & Menu.fieldHelpMsgL .~ "either 'make' or 'hadrian'" + , 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.IsolateEditBox) filepathV isolateDir & Menu.fieldLabelL .~ "isolated" From 3af3ee025c6abd6189dd6f604c2df44f2124f7d5 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sun, 17 Mar 2024 09:47:03 +0100 Subject: [PATCH 16/33] makes ctrl+c the shourtcut to exit menus + fix trailing new line in editor --- lib-tui/GHCup/Brick/Actions.hs | 9 +++--- lib-tui/GHCup/Brick/App.hs | 32 ++++--------------- lib-tui/GHCup/Brick/Widgets/KeyInfo.hs | 2 +- lib-tui/GHCup/Brick/Widgets/Menu.hs | 3 +- .../GHCup/Brick/Widgets/Menus/CompileGHC.hs | 4 +-- lib-tui/GHCup/Brick/Widgets/Tutorial.hs | 2 +- lib-tui/GHCup/BrickMain.hs | 7 ++-- 7 files changed, 21 insertions(+), 38 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index dc1facb7..2af6a4ff 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -702,14 +702,15 @@ keyHandlers KeyBindings {..} = where createMenuforTool = do e <- use (appState % to sectionListSelectedElement) + let exitKey = KeyCombination (Vty.KChar 'c') [Vty.MCtrl] case e of Nothing -> pure () Just (_, r) -> do -- Create new menus - contextMenu .= ContextMenu.create r bQuit - advanceInstallMenu .= AdvanceInstall.create bQuit - compileGHCMenu .= CompileGHC.create bQuit - compileHLSMenu .= CompileHLS.create bQuit + contextMenu .= ContextMenu.create r exitKey + advanceInstallMenu .= AdvanceInstall.create exitKey + compileGHCMenu .= CompileGHC.create exitKey + compileHLSMenu .= CompileHLS.create exitKey -- Set mode to context mode .= ContextPanel pure () diff --git a/lib-tui/GHCup/Brick/App.hs b/lib-tui/GHCup/Brick/App.hs index 4507b1b1..b3645b8e 100644 --- a/lib-tui/GHCup/Brick/App.hs +++ b/lib-tui/GHCup/Brick/App.hs @@ -102,7 +102,7 @@ drawUI dimAttrs st = -- On Enter, to go to tutorial keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState () keyInfoHandler ev = case ev of - VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation + VtyEvent (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) -> mode .= Navigation VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial _ -> pure () @@ -110,7 +110,7 @@ keyInfoHandler ev = case ev of tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () tutorialHandler ev = case ev of - VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation + VtyEvent (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) -> mode .= Navigation _ -> pure () -- | Tab/Arrows to navigate. @@ -128,15 +128,10 @@ contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState () contextMenuHandler ev = do ctx <- use contextMenu let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent - buttons = ctx ^. Menu.menuButtonsL (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL case (ev, focusedElement) of (_ , Nothing) -> pure () - (VtyEvent (Vty.EvKey k m), Just n) - | k == exitKey - && m == mods - && n `elem` [Menu.fieldName button | button <- buttons] - -> mode .= Navigation + (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 @@ -146,15 +141,10 @@ advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState () advanceInstallHandler ev = do ctx <- use advanceInstallMenu let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent - buttons = ctx ^. Menu.menuButtonsL (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL case (ev, focusedElement) of (_ , Nothing) -> pure () - (VtyEvent (Vty.EvKey k m), Just n) - | k == exitKey - && m == mods - && n `elem` [Menu.fieldName button | button <- buttons] - -> mode .= ContextPanel + (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 Actions.withIOAction $ Actions.installWithOptions iopts @@ -164,15 +154,10 @@ compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState () compileGHCHandler ev = do ctx <- use compileGHCMenu let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent - buttons = ctx ^. Menu.menuButtonsL (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL case (ev, focusedElement) of (_ , Nothing) -> pure () - (VtyEvent (Vty.EvKey k m), Just n) - | k == exitKey - && m == mods - && n `elem` [Menu.fieldName button | button <- buttons] - -> mode .= ContextPanel + (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) @@ -184,15 +169,10 @@ compileHLSHandler :: BrickEvent Name e -> EventM Name BrickState () compileHLSHandler ev = do ctx <- use compileHLSMenu let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent - buttons = ctx ^. Menu.menuButtonsL (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL case (ev, focusedElement) of (_ , Nothing) -> pure () - (VtyEvent (Vty.EvKey k m), Just n) - | k == exitKey - && m == mods - && n `elem` [Menu.fieldName button | button <- buttons] - -> mode .= ContextPanel + (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) diff --git a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs index 6f976383..dfa4dd4e 100644 --- a/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs +++ b/lib-tui/GHCup/Brick/Widgets/KeyInfo.hs @@ -69,4 +69,4 @@ draw KeyBindings {..} = ] ] ] - <=> Brick.hBox [Brick.txt "Press q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"] + <=> Brick.hBox [Brick.txt "Press c+ctrl to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"] diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 265379a6..0669766d 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -212,7 +212,7 @@ createEditableInput name validator = FieldInput initEdit validateEditContent "" | focus && isEditorEmpty -> borderBox $ renderAsHelpMsg help | focus -> borderBox editorRender | otherwise -> borderBox $ renderAsErrMsg msg - validateEditContent = validator . T.unlines . Edit.getEditContents + validateEditContent = validator . T.init . T.unlines . Edit.getEditContents initEdit = Edit.editorText name (Just 1) "" createEditableField :: (Eq n, Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> Lens' s a -> EditableField s n @@ -319,6 +319,7 @@ handlerMenu ev = menuFieldsL .= updated_fields _ -> 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 [] = pure [] updateFields n e (x@(MenuField {fieldInput = i@(FieldInput {..}) , ..}):xs) = diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index f6ab76b5..15ef55c0 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -103,7 +103,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields bootstrapV i = case not $ emptyEditor i of True -> - let readVersion = bimap (const "Not a valid version") Left (version (T.init i)) -- Brick adds \n at the end, hence T.init + let readVersion = bimap (const "Not a valid version") Left (version i) readPath = do mfilepath <- filepathV i case mfilepath of @@ -115,7 +115,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields False -> Left "Invalid Empty value" versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) - versionV = whenEmpty Nothing (bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack . T.init) -- Brick adds \n at the end, hence T.init + versionV = whenEmpty Nothing (bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack) jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int) jobsV = diff --git a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs index ad3e40bb..cc1ac680 100644 --- a/lib-tui/GHCup/Brick/Widgets/Tutorial.hs +++ b/lib-tui/GHCup/Brick/Widgets/Tutorial.hs @@ -74,4 +74,4 @@ draw = ] , Brick.txt " " ]) - <=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial") + <=> Brick.padRight Brick.Max (Brick.txt "Press c+ctrl to exit the tutorial") diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index ffd2ea2b..95e66b26 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -17,7 +17,7 @@ module GHCup.BrickMain where import GHCup.Types ( Settings(noColor), - AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (..) ) + AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (..), KeyCombination (KeyCombination) ) import GHCup.Prelude.Logger ( logError ) import qualified GHCup.Brick.Actions as Actions import qualified GHCup.Brick.Common as Common @@ -29,6 +29,7 @@ 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 qualified Brick +import qualified Graphics.Vty as Vty import Control.Monad.Reader ( ReaderT(runReaderT) ) import Data.Functor ( ($>) ) @@ -51,7 +52,7 @@ brickMain s = do Right ad -> do let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing current_element = Navigation.sectionListSelectedElement initial_list - exit_key = bQuit . keyBindings $ s + exit_key = KeyCombination (Vty.KChar 'c') [Vty.MCtrl] -- bQuit . keyBindings $ s case current_element of Nothing -> do flip runReaderT s $ logError "Error building app state: empty ResultList" @@ -66,7 +67,7 @@ brickMain s = do Common.defaultAppSettings initial_list (ContextMenu.create e exit_key) - (AdvanceInstall.create (bQuit . keyBindings $ s )) + (AdvanceInstall.create exit_key) (CompileGHC.create exit_key) (CompileHLS.create exit_key) (keyBindings s) From 02e876cdf176612cb75cae2d5074546526950849 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sat, 23 Mar 2024 20:51:12 +0100 Subject: [PATCH 17/33] fix #1030. Adds screen reader friendlyness --- lib-tui/GHCup/Brick/Common.hs | 7 ++++++- lib-tui/GHCup/Brick/Widgets/Menu.hs | 2 +- lib-tui/GHCup/Brick/Widgets/Navigation.hs | 3 ++- 3 files changed, 9 insertions(+), 3 deletions(-) diff --git a/lib-tui/GHCup/Brick/Common.hs b/lib-tui/GHCup/Brick/Common.hs index 7f769c07..d9de93a4 100644 --- a/lib-tui/GHCup/Brick/Common.hs +++ b/lib-tui/GHCup/Brick/Common.hs @@ -32,6 +32,7 @@ module GHCup.Brick.Common ( keyToWidget, separator, frontwardLayer, + enableScreenReader, zoom, defaultAppSettings, lr, @@ -195,8 +196,12 @@ frontwardLayer layer_name = . Brick.withBorderStyle Border.unicode . Border.borderWithLabel (Brick.txt layer_name) --- I refuse to give this a type signature. +-- | 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)) +-- |- tip: when debugging, use Brick.showCursor instead +-- I refuse to give this a type signature. -- | Given a lens, zoom on it. It is needed because Brick uses microlens but GHCup uses optics. zoom l = Brick.zoom (toLensVL l) diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index 0669766d..c633c0c3 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -157,7 +157,7 @@ drawField :: Formatter n -> Bool -> MenuField s n -> Widget n drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) = let input = inputRender focus fieldStatus inputHelp inputState (amp focus) in if focus - then Brick.visible input + then Common.enableScreenReader fieldName $ Brick.visible input else input instance Brick.Named (MenuField s n) n where diff --git a/lib-tui/GHCup/Brick/Widgets/Navigation.hs b/lib-tui/GHCup/Brick/Widgets/Navigation.hs index 77de48e5..89cb0884 100644 --- a/lib-tui/GHCup/Brick/Widgets/Navigation.hs +++ b/lib-tui/GHCup/Brick/Widgets/Navigation.hs @@ -100,7 +100,8 @@ draw dimAttrs section_list | elem Latest lTag' && not lInstalled = Brick.withAttr Attributes.hoorayAttr | otherwise = id - in hooray $ dim + active = if b then Common.enableScreenReader Common.AllTools else id + in hooray $ active $ dim ( marks <+> Brick.padLeft (Pad 2) ( minHSize 6 From 3b4e6610918a80566ae683c8ff48c95c95106fce Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 10 Apr 2024 07:43:12 +0200 Subject: [PATCH 18/33] fix unix version in cabal file --- ghcup.cabal | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/ghcup.cabal b/ghcup.cabal index 06a90858..49e3dd57 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -357,7 +357,7 @@ library ghcup-tui -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates - build-depends: + build-depends: , ghcup , ghcup-optparse , optics ^>=0.4 @@ -376,7 +376,7 @@ library ghcup-tui cpp-options: -DIS_WINDOWS else - build-depends: unix ^>=2.7 + build-depends: unix ^>=2.7 || ^>=2.8 executable ghcup import: app-common-depends From 546c6e44f7255b491dcbc0d0769f616542b38862 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Thu, 11 Apr 2024 20:38:24 +0200 Subject: [PATCH 19/33] :drop dependencies between tui and opt by factoring out commmon func --- app/ghcup/Main.hs | 1 + ghcup.cabal | 3 +- lib-opt/GHCup/OptParse.hs | 2 +- lib-opt/GHCup/OptParse/Common.hs | 211 +-------- lib-opt/GHCup/OptParse/Compile.hs | 1 + lib-opt/GHCup/OptParse/Config.hs | 1 + lib-opt/GHCup/OptParse/Install.hs | 1 + lib-opt/GHCup/OptParse/List.hs | 1 + lib-opt/GHCup/OptParse/Prefetch.hs | 1 + lib-opt/GHCup/OptParse/Run.hs | 1 + lib-opt/GHCup/OptParse/Set.hs | 1 + lib-opt/GHCup/OptParse/Test.hs | 1 + lib-opt/GHCup/OptParse/Whereis.hs | 1 + lib-tui/GHCup/Brick/Actions.hs | 15 +- .../Brick/Widgets/Menus/AdvanceInstall.hs | 24 +- .../GHCup/Brick/Widgets/Menus/CompileGHC.hs | 25 +- .../GHCup/Brick/Widgets/Menus/CompileHLS.hs | 53 +-- lib-tui/GHCup/BrickMain.hs | 2 +- lib/GHCup/Utils/Parsers.hs | 420 ++++++++++++++++++ 19 files changed, 485 insertions(+), 280 deletions(-) create mode 100644 lib/GHCup/Utils/Parsers.hs diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index c0dc84e2..e2f0ca19 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -25,6 +25,7 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils +import GHCup.Utils.Parsers (fromVersion) import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/ghcup.cabal b/ghcup.cabal index 49e3dd57..b2886808 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -143,6 +143,7 @@ library GHCup.Utils.Tar GHCup.Utils.Tar.Types GHCup.Utils.URI + GHCup.Utils.Parsers GHCup.Version hs-source-dirs: lib @@ -212,6 +213,7 @@ library , unliftio-core ^>=0.2.0.1 , unordered-containers ^>=0.2.10.0 , uri-bytestring ^>=0.3.2.2 + , utf8-string ^>=1.0 , vector >=0.12 && <0.14 , versions >=6.0.5 && <6.1 , word8 ^>=0.1.3 @@ -359,7 +361,6 @@ library ghcup-tui build-depends: , ghcup - , ghcup-optparse , optics ^>=0.4 , brick ^>=2.1 , transformers ^>=0.5 diff --git a/lib-opt/GHCup/OptParse.hs b/lib-opt/GHCup/OptParse.hs index aa8cfa03..3bda4035 100644 --- a/lib-opt/GHCup/OptParse.hs +++ b/lib-opt/GHCup/OptParse.hs @@ -52,7 +52,7 @@ import GHCup.OptParse.ToolRequirements import GHCup.OptParse.Nuke import GHCup.Types - +import GHCup.Utils.Parsers (gpgParser, downloaderParser, keepOnParser, platformParser, parseUrlSource) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) #endif diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index 7853398a..8cdbff94 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -12,15 +12,14 @@ module GHCup.OptParse.Common where import GHCup import GHCup.Download -import GHCup.Errors import GHCup.Platform import GHCup.Types import GHCup.Types.Optics import GHCup.Utils +import qualified GHCup.Utils.Parsers as Parsers import GHCup.Prelude import GHCup.Prelude.Process import GHCup.Prelude.Logger -import GHCup.Prelude.MegaParsec import Control.DeepSeq import Control.Concurrent @@ -43,65 +42,26 @@ import Data.Bifunctor import Data.Char import Data.Either import Data.Functor -import Data.List ( nub, sort, sortBy, isPrefixOf, stripPrefix ) +import Data.List ( nub, isPrefixOf, stripPrefix ) import Data.Maybe -import Data.Text ( Text ) -import Data.Time.Calendar ( Day ) -import Data.Time.Format ( parseTimeM, defaultTimeLocale ) import Data.Versions -import Data.Void import qualified Data.Vector as V import GHC.IO.Exception import Haskus.Utils.Variant.Excepts import Options.Applicative hiding ( style ) import Prelude hiding ( appendFile ) -import Safe +import Safe (lastMay) import System.Process ( readProcess ) import System.FilePath import Text.HTML.TagSoup hiding ( Tag ) -import URI.ByteString hiding (parseURI) -import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.Map.Strict as M import qualified Data.Text as T -import qualified Data.Text.Lazy.Encoding as LE -import qualified Data.Text.Lazy as LT -import qualified Text.Megaparsec as MP import qualified System.FilePath.Posix as FP import GHCup.Version import Control.Exception (evaluate) import qualified Cabal.Config as CC - - ------------- - --[ Types ]-- - ------------- - --- a superset of ToolVersion -data SetToolVersion = SetGHCVersion GHCTargetVersion - | SetToolVersion Version - | SetToolTag Tag - | SetToolDay Day - | SetRecommended - | SetNext - deriving (Eq, Show) - -prettyToolVer :: ToolVersion -> String -prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v' -prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v' -prettyToolVer (ToolTag t) = show t -prettyToolVer (ToolDay day) = show day - -toSetToolVer :: Maybe ToolVersion -> SetToolVersion -toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v' -toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' -toSetToolVer (Just (ToolTag t')) = SetToolTag t' -toSetToolVer (Just (ToolDay d')) = SetToolDay d' -toSetToolVer Nothing = SetRecommended - - - - -------------- --[ Parser ]-- -------------- @@ -118,9 +78,9 @@ toolVersionTagArgument criteria tool = mv (Just HLS) = "HLS_VERSION|TAG|RELEASE_DATE" mv _ = "VERSION|TAG|RELEASE_DATE" - parser (Just GHC) = ghcVersionTagEither - parser Nothing = ghcVersionTagEither - parser _ = toolVersionTagEither + parser (Just GHC) = Parsers.ghcVersionTagEither + parser Nothing = Parsers.ghcVersionTagEither + parser _ = Parsers.toolVersionTagEither versionParser' :: [ListCriteria] -> Maybe Tool -> Parser Version @@ -129,7 +89,7 @@ versionParser' criteria tool = argument (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) ghcVersionArgument :: [ListCriteria] -> Maybe Tool -> Parser GHCTargetVersion -ghcVersionArgument criteria tool = argument (eitherReader ghcVersionEither) +ghcVersionArgument criteria tool = argument (eitherReader Parsers.ghcVersionEither) (metavar "VERSION" <> foldMap (completer . versionCompleter criteria) tool) @@ -674,149 +634,6 @@ toolDlCompleter tool = mkCompleter $ \case #endif - - - - - ----------------- - --[ Utilities ]-- - ----------------- - - -fromVersion :: ( HasLog env - , MonadFail m - , MonadReader env m - , HasGHCupInfo env - , HasDirs env - , MonadThrow m - , MonadIO m - , MonadCatch m - ) - => Maybe ToolVersion - -> Tool - -> Excepts - '[ TagNotFound - , DayNotFound - , NextVerNotFound - , NoToolVersionSet - ] m (GHCTargetVersion, Maybe VersionInfo) -fromVersion tv = fromVersion' (toSetToolVer tv) - -fromVersion' :: ( HasLog env - , MonadFail m - , MonadReader env m - , HasGHCupInfo env - , HasDirs env - , MonadThrow m - , MonadIO m - , MonadCatch m - ) - => SetToolVersion - -> Tool - -> Excepts - '[ TagNotFound - , DayNotFound - , NextVerNotFound - , NoToolVersionSet - ] m (GHCTargetVersion, Maybe VersionInfo) -fromVersion' SetRecommended tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - second Just <$> getRecommended dls tool - ?? TagNotFound Recommended tool -fromVersion' (SetGHCVersion v) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo v tool dls - case pvp $ prettyVer (_tvVersion v) of -- need to be strict here - Left _ -> pure (v, vi) - Right pvpIn -> - lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case - Just (pvp_, vi', mt) -> do - v' <- lift $ pvpToVersion pvp_ "" - when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') - pure (GHCTargetVersion mt v', Just vi') - Nothing -> pure (v, vi) -fromVersion' (SetToolVersion (mkTVer -> v)) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - let vi = getVersionInfo v tool dls - case pvp $ prettyVer (_tvVersion v) of -- need to be strict here - Left _ -> pure (v, vi) - Right pvpIn -> - lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case - Just (pvp_, vi', mt) -> do - v' <- lift $ pvpToVersion pvp_ "" - when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') - pure (GHCTargetVersion mt v', Just vi') - Nothing -> pure (v, vi) -fromVersion' (SetToolTag Latest) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool -fromVersion' (SetToolDay day) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> case getByReleaseDay dls tool day of - Left ad -> throwE $ DayNotFound day tool ad - Right v -> pure v -fromVersion' (SetToolTag LatestPrerelease) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool -fromVersion' (SetToolTag LatestNightly) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool -fromVersion' (SetToolTag Recommended) tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool -fromVersion' (SetToolTag (Base pvp'')) GHC = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC -fromVersion' SetNext tool = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - next <- case tool of - GHC -> do - set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool - ghcs <- rights <$> lift getInstalledGHCs - (headMay - . tail - . dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set) - . cycle - . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y)) - . filter (\GHCTargetVersion {..} -> isNothing _tvTarget) - $ ghcs) ?? NoToolVersionSet tool - Cabal -> do - set <- cabalSet !? NoToolVersionSet tool - cabals <- rights <$> lift getInstalledCabals - (fmap (GHCTargetVersion Nothing) - . headMay - . tail - . dropWhile (/= set) - . cycle - . sort - $ cabals) ?? NoToolVersionSet tool - HLS -> do - set <- hlsSet !? NoToolVersionSet tool - hlses <- rights <$> lift getInstalledHLSs - (fmap (GHCTargetVersion Nothing) - . headMay - . tail - . dropWhile (/= set) - . cycle - . sort - $ hlses) ?? NoToolVersionSet tool - Stack -> do - set <- stackSet !? NoToolVersionSet tool - stacks <- rights <$> lift getInstalledStacks - (fmap (GHCTargetVersion Nothing) - . headMay - . tail - . dropWhile (/= set) - . cycle - . sort - $ stacks) ?? NoToolVersionSet tool - GHCup -> fail "GHCup cannot be set" - let vi = getVersionInfo next tool dls - pure (next, vi) -fromVersion' (SetToolTag t') tool = - throwE $ TagNotFound t' tool - - checkForUpdates :: ( MonadReader env m , HasGHCupInfo env , HasDirs env @@ -847,23 +664,9 @@ checkForUpdates = do where forMM a f = fmap join $ forM a f - logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m () logGHCPostRm ghcVer = do cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store") (runIdentity . CC.cfgStoreDir <$> CC.readConfig) let storeGhcDir = cabalStore ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir - -parseUrlSource :: String -> Either String URLSource -parseUrlSource "GHCupURL" = pure GHCupURL -parseUrlSource "StackSetupURL" = pure StackSetupURL -parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') - <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI .UTF8.fromString $ s') - -parseNewUrlSource :: String -> Either String NewURLSource -parseNewUrlSource "GHCupURL" = pure NewGHCupURL -parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL -parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') - <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s') - diff --git a/lib-opt/GHCup/OptParse/Compile.hs b/lib-opt/GHCup/OptParse/Compile.hs index a9d65c96..032a87da 100644 --- a/lib-opt/GHCup/OptParse/Compile.hs +++ b/lib-opt/GHCup/OptParse/Compile.hs @@ -18,6 +18,7 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Utils +import GHCup.Utils.Parsers (fromVersion, uriParser, ghcVersionTagEither, isolateParser, overWriteVersionParser) import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ import GHCup.OptParse.Common diff --git a/lib-opt/GHCup/OptParse/Config.hs b/lib-opt/GHCup/OptParse/Config.hs index e8b815f6..79a8d182 100644 --- a/lib-opt/GHCup/OptParse/Config.hs +++ b/lib-opt/GHCup/OptParse/Config.hs @@ -14,6 +14,7 @@ module GHCup.OptParse.Config where import GHCup.Errors import GHCup.Types import GHCup.Utils +import GHCup.Utils.Parsers (parseNewUrlSource) import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/Install.hs b/lib-opt/GHCup/OptParse/Install.hs index 4ec5af52..1228eefb 100644 --- a/lib-opt/GHCup/OptParse/Install.hs +++ b/lib-opt/GHCup/OptParse/Install.hs @@ -20,6 +20,7 @@ import GHCup import GHCup.Errors import GHCup.Types import GHCup.Utils.Dirs +import GHCup.Utils.Parsers (fromVersion, isolateParser, uriParser) import GHCup.Prelude import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/List.hs b/lib-opt/GHCup/OptParse/List.hs index fe56c884..f99c6f7a 100644 --- a/lib-opt/GHCup/OptParse/List.hs +++ b/lib-opt/GHCup/OptParse/List.hs @@ -14,6 +14,7 @@ module GHCup.OptParse.List where import GHCup import GHCup.Prelude import GHCup.Types +import GHCup.Utils.Parsers (dayParser, toolParser, criteriaParser) import GHCup.OptParse.Common import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/Prefetch.hs b/lib-opt/GHCup/OptParse/Prefetch.hs index 3550ab7f..17e5bd31 100644 --- a/lib-opt/GHCup/OptParse/Prefetch.hs +++ b/lib-opt/GHCup/OptParse/Prefetch.hs @@ -14,6 +14,7 @@ module GHCup.OptParse.Prefetch where import GHCup import GHCup.Errors import GHCup.Types +import GHCup.Utils.Parsers (fromVersion) import GHCup.Types.Optics import GHCup.Prelude.File import GHCup.Prelude.Logger diff --git a/lib-opt/GHCup/OptParse/Run.hs b/lib-opt/GHCup/OptParse/Run.hs index 72caeab5..74e5f857 100644 --- a/lib-opt/GHCup/OptParse/Run.hs +++ b/lib-opt/GHCup/OptParse/Run.hs @@ -11,6 +11,7 @@ module GHCup.OptParse.Run where import GHCup import GHCup.Utils +import GHCup.Utils.Parsers (fromVersion, ghcVersionTagEither, isolateParser, toolVersionTagEither) import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types diff --git a/lib-opt/GHCup/OptParse/Set.hs b/lib-opt/GHCup/OptParse/Set.hs index c4941b9a..94ff3611 100644 --- a/lib-opt/GHCup/OptParse/Set.hs +++ b/lib-opt/GHCup/OptParse/Set.hs @@ -17,6 +17,7 @@ import GHCup.OptParse.Common import GHCup import GHCup.Errors import GHCup.Types +import GHCup.Utils.Parsers (SetToolVersion(..), tagEither, ghcVersionEither, toolVersionEither, fromVersion') import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/Test.hs b/lib-opt/GHCup/OptParse/Test.hs index 8ccdef1c..a124c345 100644 --- a/lib-opt/GHCup/OptParse/Test.hs +++ b/lib-opt/GHCup/OptParse/Test.hs @@ -20,6 +20,7 @@ import GHCup import GHCup.Errors import GHCup.Types import GHCup.Utils.Dirs +import GHCup.Utils.Parsers (fromVersion, uriParser) import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-opt/GHCup/OptParse/Whereis.hs b/lib-opt/GHCup/OptParse/Whereis.hs index d6b269fb..90d8d708 100644 --- a/lib-opt/GHCup/OptParse/Whereis.hs +++ b/lib-opt/GHCup/OptParse/Whereis.hs @@ -18,6 +18,7 @@ import GHCup.Errors import GHCup.OptParse.Common import GHCup.Types import GHCup.Utils +import GHCup.Utils.Parsers (fromVersion) import GHCup.Prelude.Logger import GHCup.Prelude.String.QQ diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 2af6a4ff..b5078141 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -14,10 +14,9 @@ module GHCup.Brick.Actions where import GHCup import GHCup.Download import GHCup.Errors -import GHCup.Types.Optics ( getDirs, getPlatformReq ) +import GHCup.Types.Optics ( getDirs, getPlatformReq, HasLog ) import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils -import GHCup.OptParse.Common (logGHCPostRm) import GHCup.Prelude ( decUTF8Safe, runBothE' ) import GHCup.Prelude.Logger import GHCup.Prelude.Process @@ -45,6 +44,7 @@ import Control.Monad.Trans.Resource import Data.Bool import Data.Functor import Data.Function ( (&), on) +import Data.Functor.Identity import Data.List import Data.Maybe import Data.IORef (IORef, readIORef, newIORef, modifyIORef) @@ -78,8 +78,9 @@ 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.OptParse.Common as OptParse +import qualified GHCup.Utils.Parsers as Utils import qualified GHCup.HLS as HLS +import qualified Cabal.Config as CC @@ -409,6 +410,12 @@ set' input@(_, ListResult {..}) = do _ -> pure $ Left (prettyHFError e) +logGHCPostRm :: (MonadReader env m, HasLog env, MonadIO m) => GHCTargetVersion -> m () +logGHCPostRm ghcVer = do + cabalStore <- liftIO $ handleIO (\_ -> if isWindows then pure "C:\\cabal\\store" else pure "~/.cabal/store or ~/.local/state/cabal/store") + (runIdentity . CC.cfgStoreDir <$> CC.readConfig) + let storeGhcDir = cabalStore ("ghc-" <> T.unpack (prettyVer $ _tvVersion ghcVer)) + logInfo $ T.pack $ "After removing GHC you might also want to clean up your cabal store at: " <> storeGhcDir del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) @@ -589,7 +596,7 @@ compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do ghcs <- liftE $ forM (compopts ^. CompileHLS.targetGHCs) - (\ghc -> fmap (_tvVersion . fst) . OptParse.fromVersion (Just ghc) $ GHC) + (\ghc -> fmap (_tvVersion . fst) . Utils.fromVersion (Just ghc) $ GHC) targetVer <- liftE $ GHCup.compileHLS (HLS.SourceDist lVer) ghcs diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs index d88945d5..12ed9f44 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -40,14 +40,11 @@ import qualified GHCup.Brick.Common as Common import GHCup.Types (KeyCombination) import URI.ByteString (URI) import qualified Data.Text as T -import qualified Data.ByteString.UTF8 as UTF8 -import GHCup.Utils (parseURI) import Data.Bifunctor (Bifunctor(..)) import Data.Function ((&)) import Optics ((.~)) import Data.Char (isSpace) -import System.FilePath (isValid, isAbsolute, normalise) -import GHCup.Prelude (stripNewlineEnd) +import qualified GHCup.Utils.Parsers as Utils data InstallOptions = InstallOptions { instBindist :: Maybe URI @@ -75,22 +72,15 @@ create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields -- 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 i = - case not $ emptyEditor i of - True -> bimap (T.pack . show) Just . parseURI . UTF8.fromString . T.unpack $ i - False -> Right Nothing + uriValidator = whenEmpty Nothing (second Just . readUri) + where readUri = first T.pack . Utils.uriParser . T.unpack filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath) - filepathValidator i = - case not $ emptyEditor i of - True -> absolutePathParser (T.unpack i) - False -> Right Nothing - - absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath) - absolutePathParser f = case isValid f && isAbsolute f of - True -> Right . Just . stripNewlineEnd . normalise $ f - False -> Left "Please enter a valid absolute filepath." + filepathValidator = whenEmpty Nothing (bimap T.pack Just . Utils.absolutePathParser . T.unpack) additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text] additionalValidator = Right . T.split isSpace diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index 15ef55c0..869e9dea 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -47,18 +47,15 @@ import GHCup.Types ( KeyCombination, BuildSystem(..), VersionPattern ) import URI.ByteString (URI) import qualified Data.Text as T -import qualified Data.ByteString.UTF8 as UTF8 -import GHCup.Utils (parseURI) import Data.Bifunctor (Bifunctor(..)) import Data.Function ((&)) import Optics ((.~)) import Data.Char (isSpace) import Data.Versions (Version, version) -import System.FilePath (isPathSeparator, isValid, isAbsolute, normalise) +import System.FilePath (isPathSeparator) import Control.Applicative (Alternative((<|>))) import Text.Read (readEither) -import GHCup.Prelude (stripNewlineEnd) -import qualified GHCup.OptParse.Common as OptParse +import qualified GHCup.Utils.Parsers as Utils data CompileGHCOptions = CompileGHCOptions { _bootstrapGhc :: Either Version FilePath @@ -115,7 +112,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields False -> Left "Invalid Empty value" versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) - versionV = whenEmpty Nothing (bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack) + versionV = whenEmpty Nothing (bimap T.pack Just . Utils.overWriteVersionParser . T.unpack) jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int) jobsV = @@ -125,24 +122,14 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) patchesV = whenEmpty Nothing readPatches where - readUri :: T.Text -> Either String URI - readUri = first show . parseURI . UTF8.fromString . T.unpack readPatches j = let - x = (bimap T.unpack (fmap Left) $ filepathV j) - y = second (Just . Right) $ traverse readUri (T.split isSpace j) + 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 i = - case not $ emptyEditor i of - True -> absolutePathParser (T.unpack i) - False -> Right Nothing - - absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath) - absolutePathParser f = case isValid f && isAbsolute f of - True -> Right . Just . stripNewlineEnd . normalise $ f - False -> Left "Please enter a valid absolute 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 diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs index c4e8e1ad..e48385c2 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -46,17 +46,13 @@ import qualified GHCup.Brick.Common as Common import GHCup.Types (KeyCombination, VersionPattern, ToolVersion) import URI.ByteString (URI) import qualified Data.Text as T -import qualified Data.ByteString.UTF8 as UTF8 -import GHCup.Utils (parseURI) import Data.Bifunctor (Bifunctor(..)) import Data.Function ((&)) import Optics ((.~)) import Data.Char (isSpace) -import System.FilePath (isValid, isAbsolute, normalise) import Control.Applicative (Alternative((<|>))) import Text.Read (readEither) -import GHCup.Prelude (stripNewlineEnd) -import qualified GHCup.OptParse.Common as OptParse +import qualified GHCup.Utils.Parsers as Utils data CompileHLSOptions = CompileHLSOptions { _jobs :: Maybe Int @@ -95,51 +91,42 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields 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 i = - case not $ emptyEditor i of - True -> - let readPath = Right . Left . stripNewlineEnd . T.unpack $ i - in bimap T.pack Just $ second Right (readUri i) <|> readPath - False -> Right Nothing - - {- There is an unwanted dependency to ghcup-opt... Alternatives are - - copy-paste a bunch of code - - define a new common library - -} + 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 = first T.pack . traverse (OptParse.ghcVersionTagEither . T.unpack) . T.split isSpace + ghcVersionTagEither = whenEmpty [] $ first T.pack . traverse (Utils.ghcVersionTagEither . T.unpack) . T.split isSpace overWriteVersionParser :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern]) - overWriteVersionParser = bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack + 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 - readUri :: T.Text -> Either String URI - readUri = first show . parseURI . UTF8.fromString . T.unpack - patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI])) patchesV = whenEmpty Nothing readPatches where readPatches j = let - x = (bimap T.unpack (fmap Left) $ filepathV j) - y = second (Just . Right) $ traverse readUri (T.split isSpace j) + 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 i = - case not $ emptyEditor i of - True -> absolutePathParser (T.unpack i) - False -> Right Nothing - - absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath) - absolutePathParser f = case isValid f && isAbsolute f of - True -> Right . Just . stripNewlineEnd . normalise $ f - False -> Left "Please enter a valid absolute 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 @@ -148,7 +135,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields [ 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) (bimap T.pack Just . readUri) cabalProjectLocal + , 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.createCheckBoxField (Common.MenuElement Common.UpdateCabalCheckBox) updateCabal diff --git a/lib-tui/GHCup/BrickMain.hs b/lib-tui/GHCup/BrickMain.hs index 95e66b26..c0f91c74 100644 --- a/lib-tui/GHCup/BrickMain.hs +++ b/lib-tui/GHCup/BrickMain.hs @@ -17,7 +17,7 @@ module GHCup.BrickMain where import GHCup.Types ( Settings(noColor), - AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (..), KeyCombination (KeyCombination) ) + AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyCombination (KeyCombination) ) import GHCup.Prelude.Logger ( logError ) import qualified GHCup.Brick.Actions as Actions import qualified GHCup.Brick.Common as Common diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs new file mode 100644 index 00000000..42415666 --- /dev/null +++ b/lib/GHCup/Utils/Parsers.hs @@ -0,0 +1,420 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ViewPatterns #-} + +module GHCup.Utils.Parsers where + + +import GHCup.Errors +import GHCup.Types +import GHCup.Types.Optics +import GHCup.List +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.MegaParsec + +import Control.Applicative ((<|>)) +import Control.Exception.Safe +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Data.Aeson +#if MIN_VERSION_aeson(2,0,0) +#else +import qualified Data.HashMap.Strict as KM +#endif +import Data.Bifunctor +import Data.Char +import Data.Either +import Data.Functor +import Data.List ( sort, sortBy ) +import Data.Maybe +import Data.Text ( Text ) +import Data.Time.Calendar ( Day ) +import Data.Time.Format ( parseTimeM, defaultTimeLocale ) +import Data.Versions +import Data.Void +import Haskus.Utils.Variant.Excepts +import Prelude hiding ( appendFile ) +import Safe +import System.FilePath +import URI.ByteString hiding (parseURI) + +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Data.Text as T +import qualified Data.Text.Lazy.Encoding as LE +import qualified Data.Text.Lazy as LT +import qualified Text.Megaparsec as MP +import GHCup.Version + + + ------------- + --[ Types ]-- + ------------- + +-- a superset of ToolVersion +data SetToolVersion = SetGHCVersion GHCTargetVersion + | SetToolVersion Version + | SetToolTag Tag + | SetToolDay Day + | SetRecommended + | SetNext + deriving (Eq, Show) + +prettyToolVer :: ToolVersion -> String +prettyToolVer (GHCVersion v') = T.unpack $ tVerToText v' +prettyToolVer (ToolVersion v') = T.unpack $ prettyVer v' +prettyToolVer (ToolTag t) = show t +prettyToolVer (ToolDay day) = show day + +toSetToolVer :: Maybe ToolVersion -> SetToolVersion +toSetToolVer (Just (GHCVersion v')) = SetGHCVersion v' +toSetToolVer (Just (ToolVersion v')) = SetToolVersion v' +toSetToolVer (Just (ToolTag t')) = SetToolTag t' +toSetToolVer (Just (ToolDay d')) = SetToolDay d' +toSetToolVer Nothing = SetRecommended + + +platformParser :: String -> Either String PlatformRequest +platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of + Right r -> pure r + Left e -> Left $ errorBundlePretty e + where + archP :: MP.Parsec Void Text Architecture + archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32) + platformP :: MP.Parsec Void Text PlatformRequest + platformP = choice' + [ (`PlatformRequest` FreeBSD) + <$> (archP <* MP.chunk "-") + <*> ( MP.chunk "portbld" + *> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof)) + <|> pure Nothing + ) + <* MP.chunk "-freebsd" + ) + , (`PlatformRequest` Darwin) + <$> (archP <* MP.chunk "-") + <*> ( MP.chunk "apple" + *> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof)) + <|> pure Nothing + ) + <* MP.chunk "-darwin" + ) + , (\a d mv -> PlatformRequest a (Linux d) mv) + <$> (archP <* MP.chunk "-") + <*> distroP + <*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing + ) + <* MP.chunk "-linux" + ) + ] + distroP :: MP.Parsec Void Text LinuxDistro + distroP = choice' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros) + + +uriParser :: String -> Either String URI +uriParser = first show . parseURI . UTF8.fromString + + +absolutePathParser :: FilePath -> Either String FilePath +absolutePathParser f = case isValid f && isAbsolute f of + True -> Right $ normalise f + False -> Left "Please enter a valid absolute filepath." + +isolateParser :: FilePath -> Either String FilePath +isolateParser f = case isValid f && isAbsolute f of + True -> Right $ normalise f + False -> Left "Please enter a valid filepath for isolate dir." + +-- this accepts cross prefix +ghcVersionTagEither :: String -> Either String ToolVersion +ghcVersionTagEither s' = + second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s') + +-- this ignores cross prefix +toolVersionTagEither :: String -> Either String ToolVersion +toolVersionTagEither s' = + second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s') + +tagEither :: String -> Either String Tag +tagEither s' = case fmap toLower s' of + "recommended" -> Right Recommended + "latest" -> Right Latest + "latest-prerelease" -> Right LatestPrerelease + "latest-nightly" -> Right LatestNightly + ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of + Right x -> Right (Base x) + Left _ -> Left $ "Invalid PVP version for base " <> ver' + other -> Left $ "Unknown tag " <> other + + +ghcVersionEither :: String -> Either String GHCTargetVersion +ghcVersionEither = + first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack + +toolVersionEither :: String -> Either String Version +toolVersionEither = + first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . T.pack + + +toolParser :: String -> Either String Tool +toolParser s' | t == T.pack "ghc" = Right GHC + | t == T.pack "cabal" = Right Cabal + | t == T.pack "hls" = Right HLS + | t == T.pack "stack" = Right Stack + | otherwise = Left ("Unknown tool: " <> s') + where t = T.toLower (T.pack s') + +dayParser :: String -> Either String Day +dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right + $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s + + +criteriaParser :: String -> Either String ListCriteria +criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True + | t == T.pack "set" = Right $ ListSet True + | t == T.pack "available" = Right $ ListAvailable True + | t == T.pack "+installed" = Right $ ListInstalled True + | t == T.pack "+set" = Right $ ListSet True + | t == T.pack "+available" = Right $ ListAvailable True + | t == T.pack "-installed" = Right $ ListInstalled False + | t == T.pack "-set" = Right $ ListSet False + | t == T.pack "-available" = Right $ ListAvailable False + | otherwise = Left ("Unknown criteria: " <> s') + where t = T.toLower (T.pack s') + + + +keepOnParser :: String -> Either String KeepDirs +keepOnParser s' | t == T.pack "always" = Right Always + | t == T.pack "errors" = Right Errors + | t == T.pack "never" = Right Never + | otherwise = Left ("Unknown keep value: " <> s') + where t = T.toLower (T.pack s') + + +downloaderParser :: String -> Either String Downloader +downloaderParser s' | t == T.pack "curl" = Right Curl + | t == T.pack "wget" = Right Wget +#if defined(INTERNAL_DOWNLOADER) + | t == T.pack "internal" = Right Internal +#endif + | otherwise = Left ("Unknown downloader value: " <> s') + where t = T.toLower (T.pack s') + +gpgParser :: String -> Either String GPGSetting +gpgParser s' | t == T.pack "strict" = Right GPGStrict + | t == T.pack "lax" = Right GPGLax + | t == T.pack "none" = Right GPGNone + | otherwise = Left ("Unknown gpg setting value: " <> s') + where t = T.toLower (T.pack s') + + + +overWriteVersionParser :: String -> Either String [VersionPattern] +overWriteVersionParser = first (const "Not a valid version pattern") . MP.parse (MP.many versionPattern <* MP.eof) "" . T.pack + where + versionPattern :: MP.Parsec Void Text VersionPattern + versionPattern = do + str' <- T.unpack <$> MP.takeWhileP Nothing (/= '%') + if str' /= mempty + then pure (S str') + else fmap (const CabalVer) v_cabal + <|> fmap (const GitBranchName) b_name + <|> fmap (const GitHashShort) s_hash + <|> fmap (const GitHashLong) l_hash + <|> fmap (const GitDescribe) g_desc + <|> ((\a b -> S (a : T.unpack b)) <$> MP.satisfy (const True) <*> MP.takeWhileP Nothing (== '%')) -- invalid pattern, e.g. "%k" + where + v_cabal = MP.chunk "%v" + b_name = MP.chunk "%b" + s_hash = MP.chunk "%h" + l_hash = MP.chunk "%H" + g_desc = MP.chunk "%g" + + ----------------- + --[ Utilities ]-- + ----------------- + + +fromVersion :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => Maybe ToolVersion + -> Tool + -> Excepts + '[ TagNotFound + , DayNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) +fromVersion tv = fromVersion' (toSetToolVer tv) + +fromVersion' :: ( HasLog env + , MonadFail m + , MonadReader env m + , HasGHCupInfo env + , HasDirs env + , MonadThrow m + , MonadIO m + , MonadCatch m + ) + => SetToolVersion + -> Tool + -> Excepts + '[ TagNotFound + , DayNotFound + , NextVerNotFound + , NoToolVersionSet + ] m (GHCTargetVersion, Maybe VersionInfo) +fromVersion' SetRecommended tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + second Just <$> getRecommended dls tool + ?? TagNotFound Recommended tool +fromVersion' (SetGHCVersion v) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo v tool dls + case pvp $ prettyVer (_tvVersion v) of -- need to be strict here + Left _ -> pure (v, vi) + Right pvpIn -> + lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case + Just (pvp_, vi', mt) -> do + v' <- lift $ pvpToVersion pvp_ "" + when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') + pure (GHCTargetVersion mt v', Just vi') + Nothing -> pure (v, vi) +fromVersion' (SetToolVersion (mkTVer -> v)) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + let vi = getVersionInfo v tool dls + case pvp $ prettyVer (_tvVersion v) of -- need to be strict here + Left _ -> pure (v, vi) + Right pvpIn -> + lift (getLatestToolFor tool (_tvTarget v) pvpIn dls) >>= \case + Just (pvp_, vi', mt) -> do + v' <- lift $ pvpToVersion pvp_ "" + when (v' /= _tvVersion v) $ lift $ logWarn ("Assuming you meant version " <> prettyVer v') + pure (GHCTargetVersion mt v', Just vi') + Nothing -> pure (v, vi) +fromVersion' (SetToolTag Latest) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool +fromVersion' (SetToolDay day) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap id Just <$> case getByReleaseDay dls tool day of + Left ad -> throwE $ DayNotFound day tool ad + Right v -> pure v +fromVersion' (SetToolTag LatestPrerelease) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool +fromVersion' (SetToolTag LatestNightly) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool +fromVersion' (SetToolTag Recommended) tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool +fromVersion' (SetToolTag (Base pvp'')) GHC = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC +fromVersion' SetNext tool = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + next <- case tool of + GHC -> do + set <- fmap _tvVersion $ ghcSet Nothing !? NoToolVersionSet tool + ghcs <- rights <$> lift getInstalledGHCs + (headMay + . tail + . dropWhile (\GHCTargetVersion {..} -> _tvVersion /= set) + . cycle + . sortBy (\x y -> compare (_tvVersion x) (_tvVersion y)) + . filter (\GHCTargetVersion {..} -> isNothing _tvTarget) + $ ghcs) ?? NoToolVersionSet tool + Cabal -> do + set <- cabalSet !? NoToolVersionSet tool + cabals <- rights <$> lift getInstalledCabals + (fmap (GHCTargetVersion Nothing) + . headMay + . tail + . dropWhile (/= set) + . cycle + . sort + $ cabals) ?? NoToolVersionSet tool + HLS -> do + set <- hlsSet !? NoToolVersionSet tool + hlses <- rights <$> lift getInstalledHLSs + (fmap (GHCTargetVersion Nothing) + . headMay + . tail + . dropWhile (/= set) + . cycle + . sort + $ hlses) ?? NoToolVersionSet tool + Stack -> do + set <- stackSet !? NoToolVersionSet tool + stacks <- rights <$> lift getInstalledStacks + (fmap (GHCTargetVersion Nothing) + . headMay + . tail + . dropWhile (/= set) + . cycle + . sort + $ stacks) ?? NoToolVersionSet tool + GHCup -> fail "GHCup cannot be set" + let vi = getVersionInfo next tool dls + pure (next, vi) +fromVersion' (SetToolTag t') tool = + throwE $ TagNotFound t' tool + + +parseUrlSource :: String -> Either String URLSource +parseUrlSource "GHCupURL" = pure GHCupURL +parseUrlSource "StackSetupURL" = pure StackSetupURL +parseUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') + <|> (fmap (OwnSource . (:[]) . Right) . first show . parseURI .UTF8.fromString $ s') + +parseNewUrlSource :: String -> Either String NewURLSource +parseNewUrlSource "GHCupURL" = pure NewGHCupURL +parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL +parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') + <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s') + + +checkForUpdates :: ( MonadReader env m + , HasGHCupInfo env + , HasDirs env + , HasPlatformReq env + , MonadCatch m + , HasLog env + , MonadThrow m + , MonadIO m + , MonadFail m + ) + => m [(Tool, GHCTargetVersion)] +checkForUpdates = do + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo + lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) + let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled + + ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do + (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer + if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing + + otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t -> + forMM (getLatest dls t) $ \(l, _) -> do + let mver = latestInstalled t + forMM mver $ \ver -> + if (l > ver) then pure $ Just (t, l) else pure Nothing + + pure $ catMaybes (ghcup:otherTools) + where + forMM a f = fmap join $ forM a f \ No newline at end of file From 9153f21d9b62d0e2e7157b8b67c0abd15e93f93f Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sat, 27 Apr 2024 14:22:57 +0200 Subject: [PATCH 20/33] fix vty version + attributes --- ghcup.cabal | 3 +-- lib-tui/GHCup/Brick/Attributes.hs | 6 +++--- 2 files changed, 4 insertions(+), 5 deletions(-) diff --git a/ghcup.cabal b/ghcup.cabal index b2886808..20d1b60b 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -364,8 +364,7 @@ library ghcup-tui , optics ^>=0.4 , brick ^>=2.1 , transformers ^>=0.5 - , vty ^>=6.0 - , optics ^>=0.4 + , vty ^>=6.0 || ^>=6.1 || ^>=6.2 if flag(internal-downloader) cpp-options: -DINTERNAL_DOWNLOADER diff --git a/lib-tui/GHCup/Brick/Attributes.hs b/lib-tui/GHCup/Brick/Attributes.hs index f7641be6..8226f46a 100644 --- a/lib-tui/GHCup/Brick/Attributes.hs +++ b/lib-tui/GHCup/Brick/Attributes.hs @@ -35,9 +35,9 @@ defaultAttributes no_color = Brick.attrMap , (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red) , (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red) , (nightlyAttr , Vty.defAttr `withForeColor` Vty.red) - , (compiledAttr , Vty.defAttr `withForeColor` Vty.blue) - , (strayAttr , Vty.defAttr `withForeColor` Vty.blue) - , (dayAttr , Vty.defAttr `withForeColor` Vty.blue) + , (compiledAttr , Vty.defAttr `withForeColor` Vty.brightCyan) + , (strayAttr , Vty.defAttr `withForeColor` Vty.brightCyan) + , (dayAttr , Vty.defAttr `withForeColor` Vty.brightCyan) , (helpAttr , Vty.defAttr `withStyle` Vty.italic) , (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite) , (helpMsgAttr , Vty.defAttr `withForeColor` Vty.brightBlack) From 11d1917ccd76e4bd3de1399c77fb6fc05a9dd2f1 Mon Sep 17 00:00:00 2001 From: Divam Date: Mon, 20 May 2024 20:10:30 +0900 Subject: [PATCH 21/33] minor refactor, use traverse --- lib-tui/GHCup/Brick/Widgets/Menu.hs | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/lib-tui/GHCup/Brick/Widgets/Menu.hs b/lib-tui/GHCup/Brick/Widgets/Menu.hs index c633c0c3..9a3cb63c 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menu.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menu.hs @@ -321,16 +321,15 @@ handlerMenu ev = 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 [] = pure [] - updateFields n e (x@(MenuField {fieldInput = i@(FieldInput {..}) , ..}):xs) = + 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):xs - Right a -> menuStateL % fieldAccesor .= a >> pure ((newField & fieldStatusL .~ Valid):xs) - else fmap (x:) (updateFields n e xs) + 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 From d98a57c2fd9047e33374a4f2626110c292f37a29 Mon Sep 17 00:00:00 2001 From: Divam Date: Mon, 20 May 2024 21:41:14 +0900 Subject: [PATCH 22/33] Fix help msg, the "-- " prefix is not necessary in the input text --- lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs | 2 +- lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs | 2 +- lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs | 2 +- 3 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs index 12ed9f44..3e1a6f3a 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs @@ -100,7 +100,7 @@ create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields & 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, prefix with '-- ' (longopts)" + & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure" ] ok = Menu.createButtonField (Common.MenuElement Common.OkButton) diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs index 869e9dea..067266d6 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs @@ -161,7 +161,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields & Menu.fieldHelpMsgL .~ "Build cross-compiler for this platform" , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgs & Menu.fieldLabelL .~ "CONFIGURE_ARGS" - & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure, prefix with '-- ' (longopts)" + & Menu.fieldHelpMsgL .~ "Additional arguments to compile configure" , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile & Menu.fieldLabelL .~ "set" & Menu.fieldHelpMsgL .~ "Set as active version after install" diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs index e48385c2..dea4b1ed 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -155,7 +155,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields & Menu.fieldHelpMsgL .~ "Set as active version after install" , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator cabalArgs & Menu.fieldLabelL .~ "CONFIGURE_ARGS" - & Menu.fieldHelpMsgL .~ "Additional arguments to cabal install, prefix with '-- ' (longopts)" + & 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" From 9e1a05e33f48dda5b23d2ba9f5febfd62037f49a Mon Sep 17 00:00:00 2001 From: Divam Date: Mon, 20 May 2024 21:57:14 +0900 Subject: [PATCH 23/33] Dont reset the state of Install/Compile submenus --- lib-tui/GHCup/Brick/Actions.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index b5078141..156ff243 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -713,11 +713,10 @@ keyHandlers KeyBindings {..} = case e of Nothing -> pure () Just (_, r) -> do - -- Create new menus + -- 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 exitKey - advanceInstallMenu .= AdvanceInstall.create exitKey - compileGHCMenu .= CompileGHC.create exitKey - compileHLSMenu .= CompileHLS.create exitKey -- Set mode to context mode .= ContextPanel pure () From 7b36ce63e392493b2359842eb14f864bccd196fa Mon Sep 17 00:00:00 2001 From: Divam Date: Mon, 20 May 2024 22:32:29 +0900 Subject: [PATCH 24/33] Return errors from compileGHC and compileHLS APIs --- lib-tui/GHCup/Brick/Actions.hs | 42 +++++++++++++++------------------- 1 file changed, 18 insertions(+), 24 deletions(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 156ff243..076571a8 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -533,25 +533,21 @@ compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do liftIO $ putStr (T.unpack $ tVerToText tv) pure $ Right () VLeft (V (AlreadyInstalled _ v)) -> do - logWarn $ - "GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall" - pure $ Right () + pure $ Left $ + "GHC ver " <> T.unpack (prettyVer v) <> " already installed, remove it first to reinstall" VLeft (V (DirNotEmpty fp)) -> do - logError $ - "Install directory " <> T.pack fp <> " is not empty." - pure $ Right () - VLeft err@(V (BuildFailed tmpdir _)) -> do + pure $ Left $ + "Install directory " <> fp <> " is not empty." + VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $ case keepDirs (appstate & settings) of - Never -> logError $ T.pack $ prettyHFError err - _ -> logError $ T.pack (prettyHFError err) <> "\n" - <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir) + Never -> prettyHFError err + _ -> prettyHFError err <> "\n" + <> "Check the logs at " <> (fromGHCupPath $ appstate & dirs & logsDir) <> " and the build directory " - <> T.pack tmpdir <> " for more clues." <> "\n" - <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards." - pure $ Right () + <> tmpdir <> " for more clues." <> "\n" + <> "Make sure to clean up " <> tmpdir <> " afterwards." VLeft e -> do - logError $ T.pack $ prettyHFError e - pure $ Right () + 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 ()) @@ -621,18 +617,16 @@ compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg liftIO $ putStr (T.unpack $ prettyVer tv) pure $ Right () - VLeft err@(V (BuildFailed tmpdir _)) -> do + VLeft err@(V (BuildFailed tmpdir _)) -> pure $ Left $ case keepDirs (appstate & settings) of - Never -> logError $ T.pack $ prettyHFError err - _ -> logError $ T.pack (prettyHFError err) <> "\n" - <> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir) + Never -> prettyHFError err + _ -> prettyHFError err <> "\n" + <> "Check the logs at " <> (fromGHCupPath $ appstate & dirs & logsDir) <> " and the build directory " - <> T.pack tmpdir <> " for more clues." <> "\n" - <> "Make sure to clean up " <> T.pack tmpdir <> " afterwards." - pure $ Right () + <> tmpdir <> " for more clues." <> "\n" + <> "Make sure to clean up " <> tmpdir <> " afterwards." VLeft e -> do - logError $ T.pack $ prettyHFError e - pure $ Right () + 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 ()) From aafbf40cce4097f071e5582810872af83fb2b77c Mon Sep 17 00:00:00 2001 From: Divam Date: Tue, 28 May 2024 17:19:50 +0900 Subject: [PATCH 25/33] Fix HLS compile field label --- lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs index dea4b1ed..8557515e 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -154,7 +154,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields & Menu.fieldLabelL .~ "set" & Menu.fieldHelpMsgL .~ "Set as active version after install" , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator cabalArgs - & Menu.fieldLabelL .~ "CONFIGURE_ARGS" + & Menu.fieldLabelL .~ "CABAL_ARGS" & Menu.fieldHelpMsgL .~ "Additional arguments to cabal install" , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir & Menu.fieldLabelL .~ "isolated" From 5d46492cd704b476d49838afb7b8214c83f5e025 Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 31 May 2024 13:18:47 +0900 Subject: [PATCH 26/33] Reorder the fields in compile HLS menu. To have frequently used fields shown first. --- .../GHCup/Brick/Widgets/Menus/CompileHLS.hs | 20 +++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs index 8557515e..7caa9202 100644 --- a/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs +++ b/lib-tui/GHCup/Brick/Widgets/Menus/CompileHLS.hs @@ -132,13 +132,7 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields additionalValidator = Right . T.split isSpace fields = - [ 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.createCheckBoxField (Common.MenuElement Common.UpdateCabalCheckBox) updateCabal + [ 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 @@ -147,9 +141,6 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields , Menu.createEditableField (Common.MenuElement Common.TargetGhcEditBox) ghcVersionTagEither targetGHCs & Menu.fieldLabelL .~ "target GHC" & Menu.fieldHelpMsgL .~ "For which GHC version to compile for (can be specified multiple times)" - , 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.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile & Menu.fieldLabelL .~ "set" & Menu.fieldHelpMsgL .~ "Set as active version after install" @@ -162,6 +153,15 @@ create k = Menu.createMenu CompileGHCBox initialState k buttons fields , 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" + , 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." ] buttons = [ From fe4466a74766c242686d22a5f9d5c970a8854d68 Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 31 May 2024 13:40:40 +0900 Subject: [PATCH 27/33] Move common imports to app-common-depends --- ghcup.cabal | 9 +++------ 1 file changed, 3 insertions(+), 6 deletions(-) diff --git a/ghcup.cabal b/ghcup.cabal index 20d1b60b..a9e5279c 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -80,6 +80,7 @@ common app-common-depends , haskus-utils-variant ^>=3.3 , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 + , optics ^>=0.4 , optparse-applicative >=0.15.1.0 && <0.18 , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0 @@ -92,6 +93,7 @@ common app-common-depends , temporary ^>=1.3 , text ^>=2.0 , time >=1.9.3 && <1.12 + , transformers ^>=0.5 , unordered-containers ^>=0.2 , uri-bytestring ^>=0.3.2.2 , utf8-string ^>=1.0 @@ -109,6 +111,7 @@ common app-common-depends build-depends: libarchive ^>=3.0.3.0 library + import: app-common-depends exposed-modules: GHCup GHCup.Cabal @@ -194,7 +197,6 @@ library , lzma-static ^>=5.2.5.3 , megaparsec >=8.0.0 && <9.3 , mtl ^>=2.2 - , optics ^>=0.4 , os-release ^>=1.0.0 , pretty ^>=1.1.3.1 , pretty-terminal ^>=0.1.0.0 @@ -209,7 +211,6 @@ library , temporary ^>=1.3 , text ^>=2.0 , time >=1.9.3 && <1.12 - , transformers ^>=0.5 , unliftio-core ^>=0.2.0.1 , unordered-containers ^>=0.2.10.0 , uri-bytestring ^>=0.3.2.2 @@ -361,9 +362,7 @@ library ghcup-tui build-depends: , ghcup - , optics ^>=0.4 , brick ^>=2.1 - , transformers ^>=0.5 , vty ^>=6.0 || ^>=6.1 || ^>=6.2 if flag(internal-downloader) @@ -411,9 +410,7 @@ executable ghcup other-modules: BrickMain build-depends: , brick ^>=2.1 - , transformers ^>=0.5 , vty ^>=6.0 || ^>=6.1 || ^>=6.2 - , optics ^>=0.4 if os(windows) cpp-options: -DIS_WINDOWS From d97246a5b312d0d1b94cbc687adaaa021cac8a86 Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 31 May 2024 13:41:26 +0900 Subject: [PATCH 28/33] Fix build with -tui flag --- ghcup.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ghcup.cabal b/ghcup.cabal index a9e5279c..a0b6e4d9 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -400,7 +400,6 @@ executable ghcup build-depends: , ghcup , ghcup-optparse - , ghcup-tui if flag(internal-downloader) cpp-options: -DINTERNAL_DOWNLOADER @@ -410,6 +409,7 @@ executable ghcup other-modules: BrickMain build-depends: , brick ^>=2.1 + , ghcup-tui , vty ^>=6.0 || ^>=6.1 || ^>=6.2 if os(windows) From 1753199539c4bce25921214f2bbebe6c9d1179b9 Mon Sep 17 00:00:00 2001 From: Divam Date: Fri, 31 May 2024 13:41:45 +0900 Subject: [PATCH 29/33] minor fix/cleanup INTERNAL_DOWNLOADER, and BRICK are not used in ghcup-tui --- ghcup.cabal | 7 ++----- 1 file changed, 2 insertions(+), 5 deletions(-) diff --git a/ghcup.cabal b/ghcup.cabal index a0b6e4d9..c779b122 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -365,11 +365,8 @@ library ghcup-tui , brick ^>=2.1 , vty ^>=6.0 || ^>=6.1 || ^>=6.2 - if flag(internal-downloader) - cpp-options: -DINTERNAL_DOWNLOADER - - if flag(tui) - cpp-options: -DBRICK + if !flag(tui) + buildable: False if os(windows) cpp-options: -DIS_WINDOWS From 8fb4ec0aa344a930876ee8aa31d892df2510d007 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Fri, 14 Jun 2024 08:27:48 +0200 Subject: [PATCH 30/33] rebase and port 6c59475 to new Common/Parsers --- lib-opt/GHCup/OptParse/Common.hs | 167 ------------------------------- lib/GHCup/Utils/Parsers.hs | 36 +------ 2 files changed, 4 insertions(+), 199 deletions(-) diff --git a/lib-opt/GHCup/OptParse/Common.hs b/lib-opt/GHCup/OptParse/Common.hs index 8cdbff94..14433875 100644 --- a/lib-opt/GHCup/OptParse/Common.hs +++ b/lib-opt/GHCup/OptParse/Common.hs @@ -131,173 +131,6 @@ invertableSwitch' longopt shortopt defv enmod dismod = optional - --------------------- - --[ Either Parser ]-- - --------------------- - - -platformParser :: String -> Either String PlatformRequest -platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of - Right r -> pure r - Left e -> Left $ errorBundlePretty e - where - archP :: MP.Parsec Void Text Architecture - archP = choice' ((\x -> MP.chunk (T.pack $ archToString x) $> x) <$> ([minBound..maxBound] :: [Architecture])) - platformP :: MP.Parsec Void Text PlatformRequest - platformP = choice' - [ (`PlatformRequest` FreeBSD) - <$> (archP <* MP.chunk "-") - <*> ( MP.chunk "portbld" - *> ( MP.try (Just <$> verP (MP.chunk "-freebsd" <* MP.eof)) - <|> pure Nothing - ) - <* MP.chunk "-freebsd" - ) - , (`PlatformRequest` Darwin) - <$> (archP <* MP.chunk "-") - <*> ( MP.chunk "apple" - *> ( MP.try (Just <$> verP (MP.chunk "-darwin" <* MP.eof)) - <|> pure Nothing - ) - <* MP.chunk "-darwin" - ) - , (\a d mv -> PlatformRequest a (Linux d) mv) - <$> (archP <* MP.chunk "-") - <*> distroP - <*> ((MP.try (Just <$> verP (MP.chunk "-linux" <* MP.eof)) <|> pure Nothing - ) - <* MP.chunk "-linux" - ) - , (\a -> PlatformRequest a Windows Nothing) - <$> ((archP <* MP.chunk "-") - <* (MP.chunk "unknown-mingw32" <|> MP.chunk "unknown-windows" <|> MP.chunk "windows")) - ] - distroP :: MP.Parsec Void Text LinuxDistro - distroP = choice' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros) - - -uriParser :: String -> Either String URI -uriParser = first show . parseURI . UTF8.fromString - - -absolutePathParser :: FilePath -> Either String FilePath -absolutePathParser f = case isValid f && isAbsolute f of - True -> Right $ normalise f - False -> Left "Please enter a valid absolute filepath." - -isolateParser :: FilePath -> Either String FilePath -isolateParser f = case isValid f && isAbsolute f of - True -> Right $ normalise f - False -> Left "Please enter a valid filepath for isolate dir." - --- this accepts cross prefix -ghcVersionTagEither :: String -> Either String ToolVersion -ghcVersionTagEither s' = - second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second GHCVersion (ghcVersionEither s') - --- this ignores cross prefix -toolVersionTagEither :: String -> Either String ToolVersion -toolVersionTagEither s' = - second ToolDay (dayParser s') <|> second ToolTag (tagEither s') <|> second ToolVersion (toolVersionEither s') - -tagEither :: String -> Either String Tag -tagEither s' = case fmap toLower s' of - "recommended" -> Right Recommended - "latest" -> Right Latest - "latest-prerelease" -> Right LatestPrerelease - "latest-nightly" -> Right LatestNightly - ('b':'a':'s':'e':'-':ver') -> case pvp (T.pack ver') of - Right x -> Right (Base x) - Left _ -> Left $ "Invalid PVP version for base " <> ver' - other -> Left $ "Unknown tag " <> other - - -ghcVersionEither :: String -> Either String GHCTargetVersion -ghcVersionEither = - first (const "Not a valid version") . MP.parse ghcTargetVerP "" . T.pack - -toolVersionEither :: String -> Either String Version -toolVersionEither = - first (const "Not a valid version") . MP.parse (version' <* MP.eof) "" . T.pack - - -toolParser :: String -> Either String Tool -toolParser s' | t == T.pack "ghc" = Right GHC - | t == T.pack "cabal" = Right Cabal - | t == T.pack "hls" = Right HLS - | t == T.pack "stack" = Right Stack - | otherwise = Left ("Unknown tool: " <> s') - where t = T.toLower (T.pack s') - -dayParser :: String -> Either String Day -dayParser s = maybe (Left $ "Could not parse \"" <> s <> "\". Expected format is: YYYY-MM-DD") Right - $ parseTimeM True defaultTimeLocale "%Y-%-m-%-d" s - - -criteriaParser :: String -> Either String ListCriteria -criteriaParser s' | t == T.pack "installed" = Right $ ListInstalled True - | t == T.pack "set" = Right $ ListSet True - | t == T.pack "available" = Right $ ListAvailable True - | t == T.pack "+installed" = Right $ ListInstalled True - | t == T.pack "+set" = Right $ ListSet True - | t == T.pack "+available" = Right $ ListAvailable True - | t == T.pack "-installed" = Right $ ListInstalled False - | t == T.pack "-set" = Right $ ListSet False - | t == T.pack "-available" = Right $ ListAvailable False - | otherwise = Left ("Unknown criteria: " <> s') - where t = T.toLower (T.pack s') - - - -keepOnParser :: String -> Either String KeepDirs -keepOnParser s' | t == T.pack "always" = Right Always - | t == T.pack "errors" = Right Errors - | t == T.pack "never" = Right Never - | otherwise = Left ("Unknown keep value: " <> s') - where t = T.toLower (T.pack s') - - -downloaderParser :: String -> Either String Downloader -downloaderParser s' | t == T.pack "curl" = Right Curl - | t == T.pack "wget" = Right Wget -#if defined(INTERNAL_DOWNLOADER) - | t == T.pack "internal" = Right Internal -#endif - | otherwise = Left ("Unknown downloader value: " <> s') - where t = T.toLower (T.pack s') - -gpgParser :: String -> Either String GPGSetting -gpgParser s' | t == T.pack "strict" = Right GPGStrict - | t == T.pack "lax" = Right GPGLax - | t == T.pack "none" = Right GPGNone - | otherwise = Left ("Unknown gpg setting value: " <> s') - where t = T.toLower (T.pack s') - - - -overWriteVersionParser :: String -> Either String [VersionPattern] -overWriteVersionParser = first (const "Not a valid version pattern") . MP.parse (MP.many versionPattern <* MP.eof) "" . T.pack - where - versionPattern :: MP.Parsec Void Text VersionPattern - versionPattern = do - str' <- T.unpack <$> MP.takeWhileP Nothing (/= '%') - if str' /= mempty - then pure (S str') - else fmap (const CabalVer) v_cabal - <|> fmap (const GitBranchName) b_name - <|> fmap (const GitHashShort) s_hash - <|> fmap (const GitHashLong) l_hash - <|> fmap (const GitDescribe) g_desc - <|> ((\a b -> S (a : T.unpack b)) <$> MP.satisfy (const True) <*> MP.takeWhileP Nothing (== '%')) -- invalid pattern, e.g. "%k" - where - v_cabal = MP.chunk "%v" - b_name = MP.chunk "%b" - s_hash = MP.chunk "%h" - l_hash = MP.chunk "%H" - g_desc = MP.chunk "%g" - - - ------------------ --[ Completers ]-- ------------------ diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs index 42415666..6a593637 100644 --- a/lib/GHCup/Utils/Parsers.hs +++ b/lib/GHCup/Utils/Parsers.hs @@ -86,7 +86,7 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of Left e -> Left $ errorBundlePretty e where archP :: MP.Parsec Void Text Architecture - archP = MP.try (MP.chunk "x86_64" $> A_64) <|> (MP.chunk "i386" $> A_32) + archP = choice' ((\x -> MP.chunk (T.pack $ archToString x) $> x) <$> ([minBound..maxBound] :: [Architecture])) platformP :: MP.Parsec Void Text PlatformRequest platformP = choice' [ (`PlatformRequest` FreeBSD) @@ -112,6 +112,9 @@ platformParser s' = case MP.parse (platformP <* MP.eof) "" (T.pack s') of ) <* MP.chunk "-linux" ) + , (\a -> PlatformRequest a Windows Nothing) + <$> ((archP <* MP.chunk "-") + <* (MP.chunk "unknown-mingw32" <|> MP.chunk "unknown-windows" <|> MP.chunk "windows")) ] distroP :: MP.Parsec Void Text LinuxDistro distroP = choice' ((\d -> MP.chunk (T.pack $ distroToString d) $> d) <$> allDistros) @@ -387,34 +390,3 @@ parseNewUrlSource "GHCupURL" = pure NewGHCupURL parseNewUrlSource "StackSetupURL" = pure NewStackSetupURL parseNewUrlSource s' = (eitherDecode . LE.encodeUtf8 . LT.pack $ s') <|> (fmap NewURI . first show . parseURI .UTF8.fromString $ s') - - -checkForUpdates :: ( MonadReader env m - , HasGHCupInfo env - , HasDirs env - , HasPlatformReq env - , MonadCatch m - , HasLog env - , MonadThrow m - , MonadIO m - , MonadFail m - ) - => m [(Tool, GHCTargetVersion)] -checkForUpdates = do - GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - lInstalled <- listVersions Nothing [ListInstalled True] False False (Nothing, Nothing) - let latestInstalled tool = (fmap (\lr -> GHCTargetVersion (lCross lr) (lVer lr)) . lastMay . filter (\lr -> lTool lr == tool)) lInstalled - - ghcup <- forMM (getLatest dls GHCup) $ \(GHCTargetVersion _ l, _) -> do - (Right ghcup_ver) <- pure $ version $ prettyPVP ghcUpVer - if (l > ghcup_ver) then pure $ Just (GHCup, mkTVer l) else pure Nothing - - otherTools <- forM [GHC, Cabal, HLS, Stack] $ \t -> - forMM (getLatest dls t) $ \(l, _) -> do - let mver = latestInstalled t - forMM mver $ \ver -> - if (l > ver) then pure $ Just (t, l) else pure Nothing - - pure $ catMaybes (ghcup:otherTools) - where - forMM a f = fmap join $ forM a f \ No newline at end of file From e71ea826b77ee3bb14fb5e030bf728530acee3da Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Tue, 18 Jun 2024 18:17:12 +0200 Subject: [PATCH 31/33] fix tests and hlint --- lib/GHCup/Utils/Parsers.hs | 12 ++++++------ test/optparse-test/SetTest.hs | 1 + 2 files changed, 7 insertions(+), 6 deletions(-) diff --git a/lib/GHCup/Utils/Parsers.hs b/lib/GHCup/Utils/Parsers.hs index 6a593637..748a27f6 100644 --- a/lib/GHCup/Utils/Parsers.hs +++ b/lib/GHCup/Utils/Parsers.hs @@ -311,24 +311,24 @@ fromVersion' (SetToolVersion (mkTVer -> v)) tool = do Nothing -> pure (v, vi) fromVersion' (SetToolTag Latest) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatest dls tool ?? TagNotFound Latest tool + second Just <$> getLatest dls tool ?? TagNotFound Latest tool fromVersion' (SetToolDay day) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> case getByReleaseDay dls tool day of + second Just <$> case getByReleaseDay dls tool day of Left ad -> throwE $ DayNotFound day tool ad Right v -> pure v fromVersion' (SetToolTag LatestPrerelease) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool + second Just <$> getLatestPrerelease dls tool ?? TagNotFound LatestPrerelease tool fromVersion' (SetToolTag LatestNightly) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool + second Just <$> getLatestNightly dls tool ?? TagNotFound LatestNightly tool fromVersion' (SetToolTag Recommended) tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getRecommended dls tool ?? TagNotFound Recommended tool + second Just <$> getRecommended dls tool ?? TagNotFound Recommended tool fromVersion' (SetToolTag (Base pvp'')) GHC = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - bimap id Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC + second Just <$> getLatestBaseVersion dls pvp'' ?? TagNotFound (Base pvp'') GHC fromVersion' SetNext tool = do GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo next <- case tool of diff --git a/test/optparse-test/SetTest.hs b/test/optparse-test/SetTest.hs index 2e2f370c..ccecd30f 100644 --- a/test/optparse-test/SetTest.hs +++ b/test/optparse-test/SetTest.hs @@ -4,6 +4,7 @@ module SetTest where import GHCup.OptParse +import GHCup.Utils.Parsers (SetToolVersion(..)) import Test.Tasty import GHCup.Types import Data.Versions From 3a7a9a78c50e50bcf1238ec5676631172ab50355 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Tue, 18 Jun 2024 22:55:46 +0200 Subject: [PATCH 32/33] fix windows build --- lib-tui/GHCup/Brick/Actions.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib-tui/GHCup/Brick/Actions.hs b/lib-tui/GHCup/Brick/Actions.hs index 076571a8..d97d615d 100644 --- a/lib-tui/GHCup/Brick/Actions.hs +++ b/lib-tui/GHCup/Brick/Actions.hs @@ -65,10 +65,11 @@ import qualified Data.Vector as V import System.Environment (getExecutablePath) #if !IS_WINDOWS import GHCup.Prelude.File -import System.FilePath import qualified System.Posix.Process as SPP #endif +import System.FilePath + import Optics.State (use) import Optics.State.Operators ( (.=)) import Optics.Operators ((.~),(%~)) From e613ea69dda1757e418c666aa795ee17befeaf85 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 19 Jun 2024 14:52:42 +0200 Subject: [PATCH 33/33] remove dead code --- app/ghcup/BrickMain.hs | 1046 ---------------------------------------- app/ghcup/Main.hs | 1 - ghcup.cabal | 3 - 3 files changed, 1050 deletions(-) delete mode 100644 app/ghcup/BrickMain.hs diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs deleted file mode 100644 index fee22488..00000000 --- a/app/ghcup/BrickMain.hs +++ /dev/null @@ -1,1046 +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 ViewPatterns #-} - -module BrickMain where - -import GHCup -import GHCup.Download -import GHCup.Errors -import GHCup.Types.Optics ( getDirs, getPlatformReq ) -import GHCup.Types hiding ( LeanAppState(..) ) -import GHCup.Utils -import GHCup.OptParse.Common (logGHCPostRm) -import GHCup.Prelude ( decUTF8Safe ) -import GHCup.Prelude.Logger -import GHCup.Prelude.Process -import GHCup.Prompts - -import Brick - ( BrickEvent(VtyEvent, MouseDown), - App(..), - Padding(Max, Pad), - AttrMap, - EventM, - Size(..), - Widget(..), - ViewportType (Vertical), - (<+>), - (<=>)) -import qualified Brick -import Brick.Widgets.Border ( hBorder, borderWithLabel) -import Brick.Widgets.Border.Style ( unicode ) -import Brick.Widgets.Center ( center, centerLayer ) -import qualified Brick.Widgets.List as L -import Brick.Focus (FocusRing) -import qualified Brick.Focus as F -import Control.Applicative -import Control.Exception.Safe -#if !MIN_VERSION_base(4,13,0) -import Control.Monad.Fail ( MonadFail ) -#endif -import Control.Monad.Reader -import Control.Monad.Trans.Except -import Control.Monad.Trans.Resource -import Data.Bool -import Data.Functor -import Data.Function ( (&), on) -import Data.List -import Data.Maybe -import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef) -import Data.Vector ( Vector - - ) -import Data.Versions hiding (Lens') -import Haskus.Utils.Variant.Excepts -import Prelude hiding ( appendFile ) -import System.Exit -import System.IO.Unsafe -import System.Process ( system ) -import Text.PrettyPrint.HughesPJClass ( prettyShow ) -import URI.ByteString - -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy as L -import qualified Graphics.Vty as Vty -import qualified Data.Vector as V -import System.Environment (getExecutablePath) -#if !IS_WINDOWS -import GHCup.Prelude.File -import System.FilePath -import qualified System.Posix.Process as SPP -#endif - -import Optics.TH (makeLenses, makeLensesFor) -import Optics.State (use) -import Optics.State.Operators ( (.=), (%=), (<%=)) -import Optics.Operators ((.~), (^.), (%~)) -import Optics.Getter (view) -import Optics.Lens (Lens', lens, toLensVL) - -{- Brick's 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 - -Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing -the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). - -- To build a SectionList use the safe constructor sectionList -- To access sections use the lens provider sectionL and the name of the section you'd like to access -- You can modify Brick.Widget.List.GenericList within GenericSectionList via sectionL but do not - modify the vector length - --} - -data GenericSectionList n t e - = GenericSectionList - { sectionListFocusRing :: FocusRing n -- ^ The FocusRing for all sections - , sectionListElements :: !(Vector (L.GenericList n t e)) -- ^ A key-value vector - , sectionListName :: n -- ^ The section list name - } - -makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListElements", "sectionListElementsL"), ("sectionListName", "sectionListNameL")] ''GenericSectionList - -type SectionList n e = GenericSectionList n V.Vector e - - --- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses. -sectionList :: Foldable t - => n -- The name of the section list - -> [(n, t e)] -- a list of tuples (section name, collection of elements) - -> Int - -> GenericSectionList n t e -sectionList name elements height - = GenericSectionList - { sectionListFocusRing = F.focusRing [section_name | (section_name, _) <- elements] - , sectionListElements = V.fromList [L.list section_name els height | (section_name, els) <- elements] - , sectionListName = name - } --- | This lens constructor, takes a name and looks if a section has such a name. --- Used to dispatch events to sections. It is a partial function only meant to --- be used with the FocusRing inside GenericSectionList -sectionL :: Eq n => n -> Lens' (GenericSectionList n t e) (L.GenericList n t e) -sectionL section_name = lens g s - where is_section_name = (== section_name) . L.listName - g section_list = - let elms = section_list ^. sectionListElementsL - zeroth = elms V.! 0 -- TODO: This crashes for empty vectors. - in fromMaybe zeroth (V.find is_section_name elms) - s gl@(GenericSectionList _ elms _) list = - case V.findIndex is_section_name elms of - Nothing -> gl - Just i -> let new_elms = V.update elms (V.fromList [(i, list)]) - in gl & sectionListElementsL .~ new_elms - -moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () -moveDown = do - ring <- use sectionListFocusRingL - case F.focusGetCurrent ring of - Nothing -> pure () - Just l -> do -- If it is the last element, move to the first element of the next focus; else, just handle regular list event. - current_list <- use (sectionL l) - let current_idx = L.listSelected current_list - list_length = current_list & length - if current_idx == Just (list_length - 1) - then do - new_focus <- sectionListFocusRingL <%= F.focusNext - case F.focusGetCurrent new_focus of - Nothing -> pure () -- |- Optic.Zoom.zoom doesn't typecheck but Lens.Micro.Mtl.zoom does. It is re-exported by Brick - Just new_l -> Brick.zoom (toLensVL $ sectionL new_l) (Brick.modify L.listMoveToBeginning) - else Brick.zoom (toLensVL $ sectionL l) $ Brick.modify L.listMoveDown - -moveUp :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () -moveUp = do - ring <- use sectionListFocusRingL - case F.focusGetCurrent ring of - Nothing -> pure () - Just l -> do -- If it is the first element, move to the last element of the prev focus; else, just handle regular list event. - current_list <- use (sectionL l) - let current_idx = L.listSelected current_list - if current_idx == Just 0 - then do - new_focus <- sectionListFocusRingL <%= F.focusPrev - case F.focusGetCurrent new_focus of - Nothing -> pure () - Just new_l -> Brick.zoom (toLensVL $ sectionL new_l) (Brick.modify L.listMoveToEnd) - else Brick.zoom (toLensVL $ sectionL l) $ Brick.modify L.listMoveUp - --- | Handle events for list cursor movement. Events handled are: --- --- * Up (up arrow key). If first element of section, then jump prev section --- * Down (down arrow key). If last element of section, then jump next section --- * Page Up (PgUp) --- * Page Down (PgDown) --- * Go to next section (Tab) --- * Go to prev section (BackTab) -handleGenericListEvent :: (Foldable t, L.Splittable t, Ord n) - => BrickEvent n a - -> EventM n (GenericSectionList n t e) () -handleGenericListEvent (VtyEvent (Vty.EvResize _ _)) = pure () -handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext -handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab [])) = sectionListFocusRingL %= F.focusPrev -handleGenericListEvent (MouseDown _ Vty.BScrollDown _ _) = moveDown -handleGenericListEvent (MouseDown _ Vty.BScrollUp _ _) = moveUp -handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KDown [])) = moveDown -handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KUp [])) = moveUp -handleGenericListEvent (VtyEvent ev) = do - ring <- use sectionListFocusRingL - case F.focusGetCurrent ring of - Nothing -> pure () - Just l -> Brick.zoom (toLensVL $ sectionL l) $ L.handleListEvent ev -handleGenericListEvent _ = pure () - --- This re-uses Brick.Widget.List.renderList -renderSectionList :: forall n t e . (Traversable t, Ord n, Show n, Eq n, L.Splittable t, Semigroup (t e)) - => (Bool -> e -> Widget n) -- ^ Rendering function of the list element, True for the selected element - -> Bool -- ^ Whether the section list has focus - -> GenericSectionList n t e -- ^ The section list to render - -> Widget n -renderSectionList renderElem sectionFocus ge@(GenericSectionList focus elms slName) = - Brick.Widget Brick.Greedy Brick.Greedy $ Brick.render $ Brick.viewport slName Brick.Vertical $ - V.ifoldl' (\(!accWidget) !i list -> - let hasFocusList = sectionIsFocused list - makeVisible = if hasFocusList then Brick.visibleRegion (Brick.Location (c, r)) (1, 1) else id - appendBorder = if i == 0 then id else (hBorder <=>) - newWidget = appendBorder (makeVisible $ renderInnerList hasFocusList list) - in accWidget <=> newWidget - ) - Brick.emptyWidget - elms - where - -- A section is focused if the whole thing is focused, and the inner list has focus - sectionIsFocused :: L.GenericList n t e -> Bool - sectionIsFocused l = sectionFocus && (Just (L.listName l) == F.focusGetCurrent focus) - - renderInnerList :: Bool -> L.GenericList n t e -> Widget n - renderInnerList hasFocus l = Brick.vLimit (length l) $ L.renderList (\b -> renderElem (b && hasFocus)) hasFocus l - - -- compute the location to focus on within the active section - (c, r) :: (Int, Int) = case sectionListSelectedElement ge of - Nothing -> (0, 0) - Just (selElIx, _) -> (0, selElIx) - - --- | Equivalent to listSelectedElement -sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) -sectionListSelectedElement generic_section_list = do - current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent - let current_section = generic_section_list ^. sectionL current_focus - L.listSelectedElement current_section - -{- Brick app data structures. - -In this section we define the state, the widgets and the core data structures which we will be using for the brick app. - --} - -data Name = AllTools -- The main list widget - | Singular Tool -- The particular list for each tool - | KeyInfoBox -- The text box widget with action informacion - | TutorialBox -- The tutorial widget - deriving (Eq, Ord, Show) - -data Mode = Navigation | KeyInfo | Tutorial deriving (Eq, Show, Ord) - -installedSign :: String -#if IS_WINDOWS -installedSign = "I " -#else -installedSign = "✓ " -#endif - -setSign :: String -#if IS_WINDOWS -setSign = "IS" -#else -setSign = "✔✔" -#endif - -notInstalledSign :: String -#if IS_WINDOWS -notInstalledSign = "X " -#else -notInstalledSign = "✗ " -#endif - - -data BrickData = BrickData - { _lr :: [ListResult] - } - deriving Show - -makeLenses ''BrickData - -data BrickSettings = BrickSettings { _showAllVersions :: Bool} - --deriving Show - -makeLenses ''BrickSettings - -type BrickInternalState = SectionList Name ListResult - -data BrickState = BrickState - { _appData :: BrickData - , _appSettings :: BrickSettings - , _appState :: BrickInternalState - , _appKeys :: KeyBindings - , _mode :: Mode - } - --deriving Show - -makeLenses ''BrickState - -app :: AttrMap -> AttrMap -> App BrickState () Name -app attrs dimAttrs = - App { appDraw = drawUI dimAttrs - , appHandleEvent = eventHandler - , appStartEvent = return () - , appAttrMap = const attrs - , appChooseCursor = Brick.showFirstCursor - } - - -{- Drawing. - -The section for creating our widgets. - --} - -showKey :: Vty.Key -> String -showKey (Vty.KChar c) = [c] -showKey Vty.KUp = "↑" -showKey Vty.KDown = "↓" -showKey key = tail (show key) - -showMod :: Vty.Modifier -> String -showMod = tail . show - - -drawNavigation :: AttrMap -> BrickState -> Widget Name -drawNavigation dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} - = Brick.padBottom Max - ( Brick.withBorderStyle unicode - $ borderWithLabel (Brick.str "GHCup") - (center (header <=> hBorder <=> renderList' _appState)) - ) - <=> footer - where - footer = - Brick.withAttr helpAttr - . Brick.txtWrap - . T.pack - . foldr1 (\x y -> x <> " " <> y) - . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as) - $ keyHandlers _appKeys - 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 $ 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 $ renderSectionList (renderItem minTagSize minVerSize) True bis - renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} = - let marks = if - | lSet -> (Brick.withAttr setAttr $ Brick.str setSign) - | lInstalled -> (Brick.withAttr installedAttr $ Brick.str installedSign) - | otherwise -> (Brick.withAttr notInstalledAttr $ Brick.str 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 hoorayAttr - | otherwise = id - in hooray $ dim - ( marks - <+> Brick.padLeft (Pad 2) - ( minHSize 6 - (printTool lTool) - ) - <+> minHSize minVerSize (Brick.str ver) - <+> (let l = catMaybes . fmap 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 recommendedAttr $ Brick.str "recommended" - printTag Latest = Just $ Brick.withAttr latestAttr $ Brick.str "latest" - printTag Prerelease = Just $ Brick.withAttr prereleaseAttr $ Brick.str "prerelease" - printTag Nightly = Just $ Brick.withAttr nightlyAttr $ Brick.str "nightly" - printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp'')) - printTag Old = Nothing - printTag LatestPrerelease = Just $ Brick.withAttr latestPrereleaseAttr $ Brick.str "latest-prerelease" - printTag LatestNightly = Just $ Brick.withAttr latestNightlyAttr $ Brick.str "latest-nightly" - printTag (UnknownTag t) = Just $ Brick.str t - - printTool Cabal = Brick.str "cabal" - printTool GHC = Brick.str "GHC" - printTool GHCup = Brick.str "GHCup" - printTool HLS = Brick.str "HLS" - printTool Stack = Brick.str "Stack" - - printNotes ListResult {..} = - (if hlsPowered then [Brick.withAttr hlsPoweredAttr $ Brick.str "hls-powered"] else mempty - ) - ++ (if lStray then [Brick.withAttr strayAttr $ Brick.str "stray"] else mempty) - ++ (case lReleaseDay of - Nothing -> mempty - Just d -> [Brick.withAttr dayAttr $ Brick.str (show d)]) - - minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') - -drawTutorial :: Widget Name -drawTutorial = - let - mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - txt_separator = hBorder <+> Brick.str " o " <+> hBorder - in centerLayer - $ Brick.hLimitPercent 75 - $ Brick.vLimitPercent 50 - $ Brick.withBorderStyle unicode - $ borderWithLabel (Brick.txt "Tutorial") - $ Brick.vBox - (fmap center - [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] - , txt_separator - , mkTextBox [ - Brick.hBox [ - Brick.txt "This symbol " - , Brick.withAttr installedAttr (Brick.str installedSign) - , Brick.txtWrap " means that the tool is installed but not in used" - ] - , Brick.hBox [ - Brick.txt "This symbol " - , Brick.withAttr setAttr (Brick.str setSign) - , Brick.txtWrap " means that the tool is installed and in used" - ] - , Brick.hBox [ - Brick.txt "This symbol " - , Brick.withAttr notInstalledAttr (Brick.str notInstalledSign) - , Brick.txt " means that the tool isn't installed" - ] - ] - , txt_separator - , mkTextBox [ - Brick.hBox [ - Brick.withAttr recommendedAttr $ Brick.str "recommended" - , Brick.txtWrap " tag is based on community adoption, known bugs, etc... So It makes this version the least experimental" - ] - , Brick.hBox [ - Brick.withAttr latestAttr $ Brick.str "latest" - , Brick.txtWrap " tag is for the latest distributed version of the tool" - ] - , Brick.hBox [ - Brick.withAttr latestAttr $ Brick.str "hls-powered" - , Brick.txt " denotes the compiler version supported by the currently set (" - , Brick.withAttr setAttr (Brick.str setSign) - , Brick.txt ") hls" - ] - , Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" - ] - , Brick.txt " " - ]) - <=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial") - -drawKeyInfo :: KeyBindings -> Widget Name -drawKeyInfo KeyBindings {..} = - let - mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (showKey key : (showMod <$> mods)) - in centerLayer - $ Brick.hLimitPercent 75 - $ Brick.vLimitPercent 50 - $ Brick.withBorderStyle unicode - $ borderWithLabel (Brick.txt "Key Actions") - $ Brick.vBox [ - center $ - mkTextBox [ - Brick.hBox [ - Brick.txt "Press " - , keyToWidget bUp, Brick.txt " and ", keyToWidget bDown - , Brick.txtWrap " to navigate the list of tools" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bInstall - , Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bSet - , Brick.txtWrap " to set a tool as the one for use" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bUninstall - , Brick.txtWrap " to uninstall a tool" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bChangelog - , Brick.txtWrap " to open the tool's changelog. It will open a web browser" - ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bShowAllVersions - , Brick.txtWrap " to show older version of each tool" - ] - ] - ] - <=> Brick.hBox [Brick.txt "Press q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"] - -drawUI :: AttrMap -> BrickState -> [Widget Name] -drawUI dimAttrs st = - let navg = drawNavigation dimAttrs st - in case st ^. mode of - Navigation -> [navg] - Tutorial -> [drawTutorial, navg] - KeyInfo -> [drawKeyInfo (st ^. appKeys), navg] - -{- Attributes - --} - - -defaultAttributes :: Bool -> AttrMap -defaultAttributes no_color = Brick.attrMap - Vty.defAttr - [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) - , (L.listSelectedAttr , Vty.defAttr) - , (notInstalledAttr , Vty.defAttr `withForeColor` Vty.red) - , (setAttr , Vty.defAttr `withForeColor` Vty.green) - , (installedAttr , Vty.defAttr `withForeColor` Vty.green) - , (recommendedAttr , Vty.defAttr `withForeColor` Vty.green) - , (hlsPoweredAttr , Vty.defAttr `withForeColor` Vty.green) - , (latestAttr , Vty.defAttr `withForeColor` Vty.yellow) - , (latestPrereleaseAttr , Vty.defAttr `withForeColor` Vty.red) - , (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red) - , (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red) - , (nightlyAttr , Vty.defAttr `withForeColor` Vty.red) - , (compiledAttr , Vty.defAttr `withForeColor` Vty.blue) - , (strayAttr , Vty.defAttr `withForeColor` Vty.blue) - , (dayAttr , Vty.defAttr `withForeColor` Vty.blue) - , (helpAttr , Vty.defAttr `withStyle` Vty.italic) - , (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite) - ] - where - withForeColor | no_color = const - | otherwise = Vty.withForeColor - - withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo - | otherwise = Vty.withBackColor - - withStyle = Vty.withStyle - - -notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr:: Brick.AttrName -latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr:: Brick.AttrName -compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr:: Brick.AttrName - -notInstalledAttr = Brick.attrName "not-installed" -setAttr = Brick.attrName "set" -installedAttr = Brick.attrName "installed" -recommendedAttr = Brick.attrName "recommended" -hlsPoweredAttr = Brick.attrName "hls-powered" -latestAttr = Brick.attrName "latest" -latestPrereleaseAttr = Brick.attrName "latest-prerelease" -latestNightlyAttr = Brick.attrName "latest-nightly" -prereleaseAttr = Brick.attrName "prerelease" -nightlyAttr = Brick.attrName "nightly" -compiledAttr = Brick.attrName "compiled" -strayAttr = Brick.attrName "stray" -dayAttr = Brick.attrName "day" -helpAttr = Brick.attrName "help" -hoorayAttr = Brick.attrName "hooray" - -dimAttributes :: Bool -> AttrMap -dimAttributes no_color = Brick.attrMap - (Vty.defAttr `Vty.withStyle` Vty.dim) - [ (Brick.attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ?? - , (Brick.attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) - ] - where - withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo - | otherwise = Vty.withBackColor - -{- Handlers - --} - -keyHandlers :: KeyBindings - -> [ ( KeyCombination - , BrickSettings -> String - , 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", Brick.zoom (toLensVL appState) moveUp) - , (bDown, const "Down", Brick.zoom (toLensVL appState) moveDown) - , (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo) - ] - where - --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () - hideShowHandler' f = do - app_settings <- use appSettings - let - vers = f app_settings - newAppSettings = app_settings & showAllVersions .~ vers - ad <- use appData - current_app_state <- use appState - appSettings .= newAppSettings - appState .= constructList ad newAppSettings (Just current_app_state) - - -tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () -tutorialHandler ev = - case ev of - VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation - _ -> pure () - -keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState () -keyInfoHandler ev = do - case ev of - VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation - VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial - _ -> pure () - -navigationHandler :: BrickEvent Name e -> EventM Name BrickState () -navigationHandler ev = do - AppState { keyBindings = kb } <- liftIO $ readIORef settings' - case ev of - inner_event@(VtyEvent (Vty.EvKey key _)) -> - case find (\(key', _, _) -> key' == KeyCombination key []) (keyHandlers kb) of - Nothing -> void $ Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event - Just (_, _, handler) -> handler - inner_event -> Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event - -eventHandler :: BrickEvent Name e -> EventM Name BrickState () -eventHandler ev = do - m <- use mode - case m of - KeyInfo -> keyInfoHandler ev - Tutorial -> tutorialHandler ev - Navigation -> navigationHandler ev - - -{- Core Logic. - -This section defines the IO actions we can execute within the Brick App: - - Install - - Set - - UnInstall - - Launch the Changelog - --} - --- | 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)) - -> 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 - - --- | Update app data and list internal state based on new evidence. --- This synchronises @BrickInternalState@ with @BrickData@ --- and @BrickSettings@. -updateList :: BrickData -> BrickState -> BrickState -updateList appD BrickState{..} = - let newInternalState = constructList appD _appSettings (Just _appState) - in BrickState { _appState = newInternalState - , _appData = appD - , _appSettings = _appSettings - , _appKeys = _appKeys - , _mode = Navigation - } - -constructList :: BrickData - -> BrickSettings - -> Maybe BrickInternalState - -> BrickInternalState -constructList appD settings = - replaceLR (filterVisible (_showAllVersions settings)) - (_lr appD) - --- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0 -selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState -selectBy tool predicate internal_state = - let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state) - tool_lens = sectionL (Singular tool) - in internal_state - & sectionListFocusRingL .~ new_focus - & tool_lens %~ L.listMoveTo 0 -- We move to 0 first - & tool_lens %~ L.listFindBy predicate -- The lookup by the predicate. - --- | Select the latests GHC tool -selectLatest :: BrickInternalState -> BrickInternalState -selectLatest = selectBy GHC (elem Latest . lTag) - - --- | Replace the @appState@ or construct it based on a filter function --- and a new @[ListResult]@ evidence. --- When passed an existing @appState@, tries to keep the selected element. -replaceLR :: (ListResult -> Bool) - -> [ListResult] - -> Maybe BrickInternalState - -> BrickInternalState -replaceLR filterF list_result s = - let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e) - newVec = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] - newSectionList = sectionList AllTools newVec 1 - in case oldElem of - Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList - Nothing -> selectLatest newSectionList - where - toolEqual e1 e2 = - lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 - - -filterVisible :: Bool -> ListResult -> Bool -filterVisible v e | lInstalled e = True - | v - , Nightly `notElem` lTag e = True - | not v - , Old `notElem` lTag e - , Nightly `notElem` lTag e = True - | otherwise = (Old `notElem` lTag e) && - (Nightly `notElem` lTag e) - - -install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => (Int, ListResult) - -> m (Either String ()) -install' (_, ListResult {..}) = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - - let run = - runResourceT - . runE - @'[ AlreadyInstalled - , ArchiveResult - , UnknownArchive - , FileDoesNotExistError - , CopyError - , NoDownload - , NotInstalled - , BuildFailed - , TagNotFound - , DigestError - , ContentLengthError - , GPGError - , DownloadFailed - , DirNotEmpty - , NoUpdate - , TarDirDoesNotExist - , FileAlreadyExistsError - , ProcessError - , ToolShadowed - , UninstallFailed - , MergeFileTreeError - , NoCompatiblePlatform - , GHCup.Errors.ParseError - , UnsupportedSetupCombo - , DistroNotFound - , NoCompatibleArch - ] - - run (do - ce <- liftIO $ fmap (either (const Nothing) Just) $ - try @_ @SomeException $ getExecutablePath >>= canonicalizePath - dirs <- lift getDirs - case lTool of - GHC -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls - liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce) - Cabal -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls - liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce) - GHCup -> do - let vi = snd <$> getLatest dls GHCup - liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce) - HLS -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls - liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce) - Stack -> do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls - liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce) - ) - >>= \case - VRight (vi, Dirs{..}, Just ce) -> do - forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg - case lTool of - GHCup -> do -#if !IS_WINDOWS - up <- liftIO $ fmap (either (const Nothing) Just) - $ try @_ @SomeException $ canonicalizePath (binDir "ghcup" <.> exeExt) - when ((normalise <$> up) == Just (normalise ce)) $ - -- TODO: track cli arguments of previous invocation - liftIO $ SPP.executeFile ce False ["tui"] Nothing -#else - logInfo "Please restart 'ghcup' for the changes to take effect" -#endif - _ -> pure () - pure $ Right () - VRight (vi, _, _) -> do - forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg - logInfo "Please restart 'ghcup' for the changes to take effect" - pure $ Right () - VLeft (V (AlreadyInstalled _ _)) -> pure $ Right () - VLeft (V NoUpdate) -> pure $ Right () - VLeft e -> pure $ Left $ prettyHFError e <> "\n" - <> "Also check the logs in ~/.ghcup/logs" - - -set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => (Int, ListResult) - -> m (Either String ()) -set' input@(_, ListResult {..}) = do - settings <- liftIO $ readIORef settings' - - let run = - flip runReaderT settings - . runResourceT - . runE - @'[ AlreadyInstalled - , ArchiveResult - , UnknownArchive - , FileDoesNotExistError - , CopyError - , NoDownload - , NotInstalled - , BuildFailed - , TagNotFound - , DigestError - , ContentLengthError - , GPGError - , DownloadFailed - , DirNotEmpty - , NoUpdate - , TarDirDoesNotExist - , FileAlreadyExistsError - , ProcessError - , ToolShadowed - , UninstallFailed - , MergeFileTreeError - , NoCompatiblePlatform - , GHCup.Errors.ParseError - , UnsupportedSetupCombo - , DistroNotFound - , NoCompatibleArch - ] - - run (do - case lTool of - GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> () - Cabal -> liftE $ setCabal lVer $> () - HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> () - Stack -> liftE $ setStack lVer $> () - GHCup -> do - promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: " - case promptAnswer of - PromptYes -> do - void $ liftE $ upgradeGHCup Nothing False False - PromptNo -> pure () - ) - >>= \case - VRight _ -> pure $ Right () - VLeft e -> case e of - (V (NotInstalled tool _)) -> do - promptAnswer <- getUserPromptResponse userPrompt - case promptAnswer of - PromptYes -> do - res <- install' input - case res of - (Left err) -> pure $ Left err - (Right _) -> do - logInfo "Setting now..." - set' input - - PromptNo -> pure $ Left (prettyHFError e) - where - userPrompt = L.toStrict . B.toLazyText . B.fromString $ - "This Version of " - <> show tool - <> " you are trying to set is not installed.\n" - <> "Would you like to install it first? [Y/N]: " - - _ -> pure $ Left (prettyHFError e) - - - -del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) - => (Int, ListResult) - -> m (Either String ()) -del' (_, ListResult {..}) = do - AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - - let run = runE @'[NotInstalled, UninstallFailed] - - run (do - let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls - case lTool of - GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi - Cabal -> liftE $ rmCabalVer lVer $> vi - HLS -> liftE $ rmHLSVer lVer $> vi - Stack -> liftE $ rmStackVer lVer $> vi - GHCup -> pure Nothing - ) - >>= \case - VRight vi -> do - when (lTool == GHC) $ logGHCPostRm (mkTVer lVer) - forM_ (_viPostRemove =<< vi) $ \msg -> - logInfo msg - pure $ Right () - VLeft e -> pure $ Left (prettyHFError e) - - -changelog' :: (MonadReader AppState m, MonadIO m) - => (Int, ListResult) - -> m (Either String ()) -changelog' (_, ListResult {..}) = do - AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask - case getChangeLog dls lTool (ToolVersion lVer) of - Nothing -> pure $ Left $ - "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer) - Just uri -> do - case _rPlatform pfreq of - Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing - Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing - FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing - Windows -> do - let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri) - c <- liftIO $ system $ args - case c of - (ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args] - ExitSuccess -> pure $ Right () - - >>= \case - Right _ -> pure $ Right () - Left e -> pure $ Left $ prettyHFError e - - -settings' :: IORef AppState -{-# NOINLINE settings' #-} -settings' = unsafePerformIO $ do - dirs <- getAllDirs - let loggerConfig = LoggerConfig { lcPrintDebug = False - , consoleOutter = \_ -> pure () - , fileOutter = \_ -> pure () - , fancyColors = True - } - newIORef $ AppState defaultSettings - dirs - defaultKeyBindings - (GHCupInfo mempty mempty Nothing) - (PlatformRequest A_64 Darwin Nothing) - loggerConfig - - -brickMain :: AppState - -> IO () -brickMain s = do - writeIORef settings' s - - eAppData <- getAppData (Just $ ghcupInfo s) - case eAppData of - Right ad -> - Brick.defaultMain - (app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s))) - (BrickState ad - defaultAppSettings - (constructList ad defaultAppSettings Nothing) - (keyBindings (s :: AppState)) - Navigation - - ) - $> () - Left e -> do - flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e) - exitWith $ ExitFailure 2 - - -defaultAppSettings :: BrickSettings -defaultAppSettings = BrickSettings { _showAllVersions = False} - - -getGHCupInfo :: IO (Either String GHCupInfo) -getGHCupInfo = do - settings <- readIORef settings' - - r <- - flip runReaderT settings - . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError] - $ do - pfreq <- lift getPlatformReq - liftE $ getDownloadsF pfreq - - case r of - VRight a -> pure $ Right a - VLeft e -> pure $ Left (prettyHFError e) - - -getAppData :: Maybe GHCupInfo - -> IO (Either String BrickData) -getAppData mgi = runExceptT $ do - r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi - liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r }) - settings <- liftIO $ readIORef settings' - - flip runReaderT settings $ do - lV <- listVersions Nothing [] False True (Nothing, Nothing) - pure $ BrickData (reverse lV) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index e2f0ca19..d56e212e 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -11,7 +11,6 @@ module Main where #if defined(BRICK) --- import BrickMain ( brickMain ) import GHCup.BrickMain (brickMain) #endif diff --git a/ghcup.cabal b/ghcup.cabal index c779b122..960c74bf 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -403,11 +403,8 @@ executable ghcup if flag(tui) cpp-options: -DBRICK - other-modules: BrickMain build-depends: - , brick ^>=2.1 , ghcup-tui - , vty ^>=6.0 || ^>=6.1 || ^>=6.2 if os(windows) cpp-options: -DIS_WINDOWS