Compare commits
9 Commits
master
...
advance-in
Author | SHA1 | Date | |
---|---|---|---|
|
e1454d0551 | ||
|
06ace5324f | ||
|
b619a65ede | ||
|
33ace9557e | ||
|
2a2385731b | ||
|
16967bdc5f | ||
|
3298f2293b | ||
|
ddd76ab7ee | ||
|
e768fcb46c |
@ -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
|
||||
|
56
ghcup.cabal
56
ghcup.cabal
@ -323,6 +323,61 @@ 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.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
|
||||
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
|
||||
@ -346,6 +401,7 @@ executable ghcup
|
||||
build-depends:
|
||||
, ghcup
|
||||
, ghcup-optparse
|
||||
, ghcup-tui
|
||||
|
||||
if flag(internal-downloader)
|
||||
cpp-options: -DINTERNAL_DOWNLOADER
|
||||
|
4
hie.yaml
4
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"
|
||||
|
551
lib-tui/GHCup/Brick/Actions.hs
Normal file
551
lib-tui/GHCup/Brick/Actions.hs
Normal file
@ -0,0 +1,551 @@
|
||||
{-# 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, runBothE' )
|
||||
import GHCup.Prelude.Logger
|
||||
import GHCup.Prelude.Process
|
||||
import GHCup.Prompts
|
||||
import GHCup.Brick.Common (BrickData(..), BrickSettings(..), Name(..), Mode(..))
|
||||
import qualified GHCup.Brick.Common as Common
|
||||
import GHCup.Brick.BrickState
|
||||
import 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
|
||||
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, 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)
|
||||
import Optics.Optic ((%))
|
||||
import Optics ((^.), to)
|
||||
|
||||
|
||||
|
||||
{- 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 bst =
|
||||
let newInternalState = constructList appD (bst ^. appSettings) (Just (bst ^. appState))
|
||||
in bst
|
||||
& appState .~ newInternalState
|
||||
& appData .~ appD
|
||||
& mode .~ Navigation
|
||||
|
||||
constructList :: BrickData
|
||||
-> BrickSettings
|
||||
-> Maybe BrickInternalState
|
||||
-> BrickInternalState
|
||||
constructList appD settings =
|
||||
replaceLR (filterVisible (_showAllVersions settings))
|
||||
(_lr appD)
|
||||
|
||||
-- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0
|
||||
selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState
|
||||
selectBy tool 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
|
||||
|
||||
installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
|
||||
=> AdvanceInstall.InstallOptions
|
||||
-> (Int, ListResult)
|
||||
-> m (Either String ())
|
||||
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
|
||||
@'[ 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
|
||||
, InstallSetError
|
||||
]
|
||||
|
||||
run (do
|
||||
ce <- liftIO $ fmap (either (const Nothing) Just) $
|
||||
try @_ @SomeException $ getExecutablePath >>= canonicalizePath
|
||||
dirs <- lift getDirs
|
||||
case lTool of
|
||||
GHC -> do
|
||||
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 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 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 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
|
||||
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"
|
||||
|
||||
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)
|
||||
-> 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)
|
||||
, (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
|
||||
advanceInstallMenu .= AdvanceInstall.create bQuit
|
||||
compileGHCMenu .= CompileGHC.create bQuit
|
||||
-- Set mode to context
|
||||
mode .= ContextPanel
|
||||
pure ()
|
||||
|
||||
--hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
|
||||
hideShowHandler' f = do
|
||||
app_settings <- use appSettings
|
||||
let
|
||||
vers = f app_settings
|
||||
newAppSettings = app_settings & Common.showAllVersions .~ vers
|
||||
ad <- use appData
|
||||
current_app_state <- use appState
|
||||
appSettings .= newAppSettings
|
||||
appState .= constructList ad newAppSettings (Just current_app_state)
|
184
lib-tui/GHCup/Brick/App.hs
Normal file
184
lib-tui/GHCup/Brick/App.hs
Normal file
@ -0,0 +1,184 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
|
||||
{-
|
||||
This module defines the brick App. The pattern is very simple:
|
||||
|
||||
- Pattern match on the Mode
|
||||
- Dispatch drawing/events to the corresponding widget/s
|
||||
|
||||
In general each widget should know how to draw itself and how to handle its own events, so this
|
||||
module should only contain:
|
||||
|
||||
- how to draw non-widget information. For example the footer
|
||||
- how to change between modes (widgets aren't aware of the whole application state)
|
||||
|
||||
-}
|
||||
|
||||
module GHCup.Brick.App where
|
||||
|
||||
import qualified GHCup.Brick.Actions as Actions
|
||||
import qualified GHCup.Brick.Attributes as Attributes
|
||||
import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu)
|
||||
import GHCup.Brick.Common (Mode (..), Name (..))
|
||||
import qualified GHCup.Brick.Common as Common
|
||||
import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo
|
||||
import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu
|
||||
import qualified GHCup.Brick.Widgets.Navigation as Navigation
|
||||
import qualified GHCup.Brick.Widgets.Tutorial as Tutorial
|
||||
import qualified GHCup.Brick.Widgets.Menu as Menu
|
||||
import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall
|
||||
|
||||
import GHCup.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 (
|
||||
MonadIO (liftIO),
|
||||
void,
|
||||
)
|
||||
import Data.IORef (readIORef)
|
||||
import Data.List (find, intercalate)
|
||||
import Prelude hiding (appendFile)
|
||||
|
||||
import qualified Graphics.Vty as Vty
|
||||
|
||||
import qualified Data.Text as T
|
||||
|
||||
import Optics.Getter (to)
|
||||
import Optics.Operators ((^.))
|
||||
import Optics.Optic ((%))
|
||||
import Optics.State (use)
|
||||
import Optics.State.Operators ((.=))
|
||||
import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC
|
||||
|
||||
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]
|
||||
ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg]
|
||||
AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg]
|
||||
CompileGHCPanel -> [CompileGHC.draw (st ^. compileGHCMenu), 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
|
||||
|
||||
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) ) -> mode .= Common.AdvanceInstallPanel
|
||||
(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 ()
|
||||
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 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 ()
|
||||
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
|
||||
case m of
|
||||
KeyInfo -> keyInfoHandler ev
|
||||
Tutorial -> tutorialHandler ev
|
||||
Navigation -> navigationHandler ev
|
||||
ContextPanel -> contextMenuHandler ev
|
||||
AdvanceInstallPanel -> advanceInstallHandler ev
|
||||
CompileGHCPanel -> compileGHCHandler ev
|
86
lib-tui/GHCup/Brick/Attributes.hs
Normal file
86
lib-tui/GHCup/Brick/Attributes.hs
Normal file
@ -0,0 +1,86 @@
|
||||
{-# 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)
|
||||
, (helpMsgAttr , Vty.defAttr `withForeColor` Vty.brightBlack)
|
||||
, (errMsgAttr , Vty.defAttr `withForeColor` Vty.red)
|
||||
]
|
||||
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, helpMsgAttr, errMsgAttr :: 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"
|
||||
helpMsgAttr = Brick.attrName "helpMsg"
|
||||
errMsgAttr = Brick.attrName "errMsg"
|
||||
|
||||
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
|
52
lib-tui/GHCup/Brick/BrickState.hs
Normal file
52
lib-tui/GHCup/Brick/BrickState.hs
Normal file
@ -0,0 +1,52 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
|
||||
{-
|
||||
This module contains the BrickState. One could be tempted to include this data structure in GHCup.Brick.Common,
|
||||
but it is better to make a separated module in order to avoid cyclic dependencies.
|
||||
|
||||
This happens because the BrickState is sort of a container for all widgets,
|
||||
but widgets depends on common functionality, hence:
|
||||
|
||||
BrickState `depends on` Widgets.XYZ `depends on` Common
|
||||
|
||||
The linear relation above breaks if BrickState is defined in Common.
|
||||
|
||||
-}
|
||||
|
||||
module GHCup.Brick.BrickState where
|
||||
|
||||
import GHCup.Types ( KeyBindings )
|
||||
import GHCup.Brick.Common ( BrickData(..), BrickSettings(..), Mode(..))
|
||||
import GHCup.Brick.Widgets.Navigation ( BrickInternalState)
|
||||
import GHCup.Brick.Widgets.Menus.Context (ContextMenu)
|
||||
import GHCup.Brick.Widgets.Menus.AdvanceInstall (AdvanceInstallMenu)
|
||||
import GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCMenu)
|
||||
import Optics.TH (makeLenses)
|
||||
|
||||
|
||||
data BrickState = BrickState
|
||||
{ _appData :: BrickData
|
||||
, _appSettings :: BrickSettings
|
||||
, _appState :: BrickInternalState
|
||||
, _contextMenu :: ContextMenu
|
||||
, _advanceInstallMenu :: AdvanceInstallMenu
|
||||
, _compileGHCMenu :: CompileGHCMenu
|
||||
, _appKeys :: KeyBindings
|
||||
, _mode :: Mode
|
||||
}
|
||||
--deriving Show
|
||||
|
||||
makeLenses ''BrickState
|
204
lib-tui/GHCup/Brick/Common.hs
Normal file
204
lib-tui/GHCup/Brick/Common.hs
Normal file
@ -0,0 +1,204 @@
|
||||
{-# 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 #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
{-
|
||||
This module contains common values used across the library. Crucially it contains two important types for the brick app:
|
||||
|
||||
- Name: List all resources (widgets) used by the app. see https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst#resource-names
|
||||
- Mode: Use to dispatch events and drawings. see: https://github.com/jtdaugherty/brick/issues/476#issuecomment-1629151920
|
||||
|
||||
-}
|
||||
|
||||
module GHCup.Brick.Common (
|
||||
installedSign,
|
||||
setSign,
|
||||
notInstalledSign,
|
||||
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) )
|
||||
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 ((<+>))
|
||||
import qualified Data.Text as T
|
||||
import qualified Brick.Widgets.Center as Brick
|
||||
import qualified Brick.Widgets.Border.Style as Border
|
||||
|
||||
-- We could use regular ADTs but different menus share the same options.
|
||||
-- example: all of ghcup compile ghc, ghcup compile hls, ghcup install cabal, etc...
|
||||
-- all have a --set, --force, etc... common arguments. If we went for the ADT we'd end up
|
||||
-- with SetCompileHLSOption, SetCompileGHCOption, SetInstallCabalOption, etc...
|
||||
-- which isn't terrible, but verbose enough to reject it.
|
||||
|
||||
-- | A newtype for labeling resources in menus. It is bundled along with pattern synonyms
|
||||
newtype ResourceId = ResourceId Int deriving (Eq, Ord, Show)
|
||||
|
||||
pattern OkButton :: ResourceId
|
||||
pattern OkButton = ResourceId 0
|
||||
pattern AdvanceInstallButton :: ResourceId
|
||||
pattern AdvanceInstallButton = ResourceId 100
|
||||
pattern 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
|
||||
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 Context Menu
|
||||
| CompileGHCBox -- ^ The resource for CompileGHC Menu
|
||||
| AdvanceInstallBox -- ^ The resource for AdvanceInstall Menu
|
||||
| MenuElement ResourceId -- ^ Each element in a Menu. Resources must not be share for visible
|
||||
-- Menus, but MenuA and MenuB can share resources if they both are
|
||||
-- invisible, or just one of them is visible.
|
||||
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
-- | Mode type. It helps to dispatch events to different handlers.
|
||||
data Mode = Navigation
|
||||
| KeyInfo
|
||||
| Tutorial
|
||||
| ContextPanel
|
||||
| AdvanceInstallPanel
|
||||
| CompileGHCPanel
|
||||
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
|
||||
|
||||
-- | 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
|
||||
|
||||
-- | 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.
|
||||
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 False
|
72
lib-tui/GHCup/Brick/Widgets/KeyInfo.hs
Normal file
72
lib-tui/GHCup/Brick/Widgets/KeyInfo.hs
Normal file
@ -0,0 +1,72 @@
|
||||
{-# 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(..) )
|
||||
import qualified GHCup.Brick.Common as Common
|
||||
|
||||
|
||||
import Brick
|
||||
( Padding(Max),
|
||||
Widget(..),
|
||||
(<+>),
|
||||
(<=>))
|
||||
import qualified Brick
|
||||
import Brick.Widgets.Center ( center )
|
||||
import Prelude hiding ( appendFile )
|
||||
|
||||
|
||||
|
||||
draw :: KeyBindings -> Widget Common.Name
|
||||
draw KeyBindings {..} =
|
||||
let
|
||||
mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max)
|
||||
in Common.frontwardLayer "Key Actions"
|
||||
$ Brick.vBox [
|
||||
center $
|
||||
mkTextBox [
|
||||
Brick.hBox [
|
||||
Brick.txt "Press "
|
||||
, Common.keyToWidget bUp, Brick.txt " and ", Common.keyToWidget bDown
|
||||
, Brick.txtWrap " to navigate the list of tools"
|
||||
]
|
||||
, Brick.hBox [
|
||||
Brick.txt "Press "
|
||||
, 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 "
|
||||
, Common.keyToWidget bSet
|
||||
, Brick.txtWrap " to set a tool as the one for use"
|
||||
]
|
||||
, Brick.hBox [
|
||||
Brick.txt "Press "
|
||||
, Common.keyToWidget bUninstall
|
||||
, Brick.txtWrap " to uninstall a tool"
|
||||
]
|
||||
, Brick.hBox [
|
||||
Brick.txt "Press "
|
||||
, Common.keyToWidget bChangelog
|
||||
, Brick.txtWrap " to open the tool's changelog. It will open a web browser"
|
||||
]
|
||||
, Brick.hBox [
|
||||
Brick.txt "Press "
|
||||
, Common.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"]
|
360
lib-tui/GHCup/Brick/Widgets/Menu.hs
Normal file
360
lib-tui/GHCup/Brick/Widgets/Menu.hs
Normal file
@ -0,0 +1,360 @@
|
||||
{-# 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 , ..}
|
||||
|
||||
-- | 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
|
||||
|
||||
|
||||
{- *****************
|
||||
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
|
||||
isEditorEmpty = Edit.getEditContents edi == [mempty]
|
||||
in case errMsg of
|
||||
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) ""
|
||||
|
||||
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
|
||||
fieldLabels = [field & fieldLabel | field <- menu ^. menuFieldsL]
|
||||
buttonLabels = [button & fieldLabel | button <- menu ^. menuButtonsL]
|
||||
allLabels = fieldLabels ++ buttonLabels
|
||||
|
||||
maxWidth = foldl' max 5 (fmap Brick.textWidth allLabels)
|
||||
|
||||
-- A list of functions which draw a highlighted label with right padding at the left of a widget.
|
||||
amplifiers =
|
||||
let labelsWidgets = fmap renderAslabel fieldLabels
|
||||
in fmap (\f b -> ((centerV . leftify (maxWidth + 10) $ f b) <+>) ) labelsWidgets
|
||||
drawFields = fmap drawField amplifiers
|
||||
fieldWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawFields (menu ^. menuFieldsL)
|
||||
|
||||
buttonAmplifiers =
|
||||
let buttonAsWidgets = fmap renderAslabel buttonLabels
|
||||
in fmap (\f b -> ((leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets
|
||||
drawButtons = fmap drawField buttonAmplifiers
|
||||
buttonWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawButtons (menu ^. menuButtonsL)
|
||||
|
||||
|
118
lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs
Normal file
118
lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs
Normal file
@ -0,0 +1,118 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
|
||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE BangPatterns #-}
|
||||
{-# LANGUAGE InstanceSigs #-}
|
||||
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
|
||||
|
||||
module GHCup.Brick.Widgets.Menus.AdvanceInstall (
|
||||
InstallOptions (..),
|
||||
AdvanceInstallMenu,
|
||||
create,
|
||||
handler,
|
||||
draw,
|
||||
instBindistL,
|
||||
instSetL,
|
||||
isolateDirL,
|
||||
forceInstallL,
|
||||
addConfArgsL,
|
||||
) 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
|
177
lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs
Normal file
177
lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs
Normal file
@ -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
|
78
lib-tui/GHCup/Brick/Widgets/Menus/Context.hs
Normal file
78
lib-tui/GHCup/Brick/Widgets/Menus/Context.hs
Normal file
@ -0,0 +1,78 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module GHCup.Brick.Widgets.Menus.Context (ContextMenu, create, draw, handler) where
|
||||
|
||||
import Brick (
|
||||
Widget (..), BrickEvent, EventM,
|
||||
)
|
||||
import Data.Function ((&))
|
||||
import Prelude hiding (appendFile)
|
||||
|
||||
import Data.Versions (prettyVer)
|
||||
import GHCup.List ( ListResult(..) )
|
||||
import GHCup.Types (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 qualified Brick.Widgets.Core as Brick
|
||||
import qualified Brick.Widgets.Border as Border
|
||||
import qualified Brick.Focus as F
|
||||
import Brick.Widgets.Core ((<+>))
|
||||
|
||||
import Optics (to)
|
||||
import Optics.Operators ((.~), (^.))
|
||||
import Optics.Optic ((%))
|
||||
import Data.Foldable (foldl')
|
||||
|
||||
type ContextMenu = Menu ListResult Name
|
||||
|
||||
create :: ListResult -> 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.CompilieButton)
|
||||
& Menu.fieldLabelL .~ "Compile"
|
||||
& Menu.fieldHelpMsgL .~ "Compile tool from source"
|
||||
buttons =
|
||||
case lTool lr of
|
||||
GHC -> [advInstallButton, compileButton]
|
||||
HLS -> [advInstallButton, compileButton]
|
||||
_ -> [advInstallButton]
|
||||
|
||||
draw :: ContextMenu -> Widget Name
|
||||
draw menu =
|
||||
Common.frontwardLayer
|
||||
("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ menu ^. Menu.menuStateL))
|
||||
$ Brick.vBox
|
||||
[ Brick.vBox buttonWidgets
|
||||
, Brick.txt " "
|
||||
, Brick.padRight Brick.Max $
|
||||
Brick.txt "Press "
|
||||
<+> Common.keyToWidget (menu ^. Menu.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
|
148
lib-tui/GHCup/Brick/Widgets/Navigation.hs
Normal file
148
lib-tui/GHCup/Brick/Widgets/Navigation.hs
Normal file
@ -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 ' ')
|
193
lib-tui/GHCup/Brick/Widgets/SectionList.hs
Normal file
193
lib-tui/GHCup/Brick/Widgets/SectionList.hs
Normal file
@ -0,0 +1,193 @@
|
||||
{-# 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 :: 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
|
77
lib-tui/GHCup/Brick/Widgets/Tutorial.hs
Normal file
77
lib-tui/GHCup/Brick/Widgets/Tutorial.hs
Normal file
@ -0,0 +1,77 @@
|
||||
{-# 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.Center ( center )
|
||||
import Prelude hiding ( appendFile )
|
||||
|
||||
|
||||
|
||||
draw :: Widget Common.Name
|
||||
draw =
|
||||
let
|
||||
mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max)
|
||||
|
||||
in Common.frontwardLayer "Tutorial"
|
||||
$ Brick.vBox
|
||||
(fmap center
|
||||
[ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."]
|
||||
, Common.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"
|
||||
]
|
||||
]
|
||||
, Common.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")
|
76
lib-tui/GHCup/BrickMain.hs
Normal file
76
lib-tui/GHCup/BrickMain.hs
Normal file
@ -0,0 +1,76 @@
|
||||
{-# 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), KeyBindings (..) )
|
||||
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 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) )
|
||||
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 -> 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)
|
||||
(AdvanceInstall.create (bQuit . keyBindings $ s ))
|
||||
(CompileGHC.create 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
|
Loading…
Reference in New Issue
Block a user