Compare commits

...

17 Commits

Author SHA1 Message Date
1793fa43cf
Fix for screen readers 2024-03-23 15:10:55 +08:00
Luis Morillo
b375398416 makes ctrl+c the shourtcut to exit menus + fix trailing new line in editor 2024-03-17 09:47:03 +01:00
Luis Morillo
04b29b0b98 fix regression #875 and build system 2024-03-16 16:27:04 +01:00
Luis Morillo
255f7c8eac Remove trailing white space 2024-03-16 16:14:24 +01:00
Luis Morillo
80a6c67cf3 Execute action only if inputs are valid + better UX 2024-03-13 18:14:37 +01:00
Luis Morillo
cee4a0d610 untested compile HLS 2024-03-13 18:14:37 +01:00
Luis Morillo
9c4e64baf1 untested compileGHC IOAction 2024-03-13 18:14:37 +01:00
Luis Morillo
0b6e9289fc Visuals for compiling HLS 2024-03-13 18:14:37 +01:00
Luis Morillo
cd8d13ff2b Advance Install menu implements functionality. 2024-03-13 18:14:37 +01:00
Luis Morillo
40f94fa016 Better aesth for context menu 2024-03-13 18:14:37 +01:00
Luis Morillo
32c2cd2efa Add visuals for compile Menu 2024-03-13 18:14:37 +01:00
Luis Morillo
7b18cc9081 migrate #987 to new library 2024-03-13 18:14:37 +01:00
Luis Morillo
3f80d41dd7 Add visuals for Advance Install 2024-03-13 18:14:37 +01:00
Luis Morillo
6485e230cd Context Menu visuals 2024-03-13 18:14:37 +01:00
Luis Morillo
3a8c32ae87 Extract common functionality 2024-03-13 18:14:37 +01:00
Luis Morillo
5ebb800646 Create Menu system. Similar to Brick.Forms 2024-03-13 18:14:37 +01:00
Luis Morillo
f157cf809e Move tui code into its own library. 2024-03-13 18:14:36 +01:00
18 changed files with 2883 additions and 1 deletions

View File

@ -11,7 +11,8 @@
module Main where module Main where
#if defined(BRICK) #if defined(BRICK)
import BrickMain ( brickMain ) -- import BrickMain ( brickMain )
import GHCup.BrickMain (brickMain)
#endif #endif
import qualified GHCup.GHC as GHC import qualified GHCup.GHC as GHC

View File

@ -322,6 +322,62 @@ library ghcup-optparse
else else
build-depends: unix ^>=2.7 || ^>=2.8 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.Widgets.Menus.CompileHLS
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 executable ghcup
import: app-common-depends import: app-common-depends
main-is: Main.hs main-is: Main.hs
@ -345,6 +401,7 @@ executable ghcup
build-depends: build-depends:
, ghcup , ghcup
, ghcup-optparse , ghcup-optparse
, ghcup-tui
if flag(internal-downloader) if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER cpp-options: -DINTERNAL_DOWNLOADER

View File

@ -2,6 +2,10 @@ cradle:
cabal: cabal:
- component: "ghcup:lib:ghcup" - component: "ghcup:lib:ghcup"
path: ./lib path: ./lib
- component: "ghcup:lib:ghcup-optparse"
path: ./lib-opt
- component: "ghcup:lib:ghcup-tui"
path: ./lib-tui
- component: "ghcup:exe:ghcup" - component: "ghcup:exe:ghcup"
path: ./app/ghcup path: ./app/ghcup
- component: "ghcup:lib:ghcup-optparse" - component: "ghcup:lib:ghcup-optparse"

View File

@ -0,0 +1,727 @@
{-# 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)
import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
import Control.Concurrent (threadDelay)
import qualified GHCup.GHC as GHC
import qualified GHCup.OptParse.Common as OptParse
import qualified GHCup.HLS as HLS
{- 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
compileGHC :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
=> CompileGHC.CompileGHCOptions -> (Int, ListResult) -> m (Either String ())
compileGHC compopts (_, lr@ListResult{lTool = GHC, ..}) = do
appstate <- ask
let run =
runResourceT
. runE @'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, NotInstalled
, DirNotEmpty
, ArchiveResult
, FileDoesNotExistError
, HadrianNotFound
, InvalidBuildConfig
, ProcessError
, CopyError
, BuildFailed
, UninstallFailed
, MergeFileTreeError
]
compileResult <- run (do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let vi = getVersionInfo (mkTVer lVer) GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
logInfo msg
logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
targetVer <- liftE $ GHCup.compileGHC
(GHC.SourceDist lVer)
(compopts ^. CompileGHC.crossTarget)
(compopts ^. CompileGHC.overwriteVer)
(compopts ^. CompileGHC.bootstrapGhc)
(compopts ^. CompileGHC.jobs)
(compopts ^. CompileGHC.buildConfig)
(compopts ^. CompileGHC.patches)
(compopts ^. CompileGHC.addConfArgs)
(compopts ^. CompileGHC.buildFlavour)
(compopts ^. CompileGHC.buildSystem)
(maybe GHCupInternal IsolateDir $ compopts ^. CompileGHC.isolateDir)
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask
let vi2 = getVersionInfo targetVer GHC dls2
when
(compopts ^. CompileGHC.setCompile)
(liftE . void $ GHCup.setGHC targetVer SetGHCOnly Nothing)
pure (vi2, targetVer)
)
case compileResult of
VRight (vi, tv) -> do
logInfo "GHC successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
liftIO $ putStr (T.unpack $ tVerToText tv)
pure $ Right ()
VLeft (V (AlreadyInstalled _ v)) -> do
logWarn $
"GHC ver " <> prettyVer v <> " already installed, remove it first to reinstall"
pure $ Right ()
VLeft (V (DirNotEmpty fp)) -> do
logError $
"Install directory " <> T.pack fp <> " is not empty."
pure $ Right ()
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs (appstate & settings) of
Never -> logError $ T.pack $ prettyHFError err
_ -> logError $ T.pack (prettyHFError err) <> "\n"
<> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir)
<> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n"
<> "Make sure to clean up " <> T.pack tmpdir <> " afterwards."
pure $ Right ()
VLeft e -> do
logError $ T.pack $ prettyHFError e
pure $ Right ()
-- This is the case when the tool is not GHC... which should be impossible but,
-- it exhaustes pattern matches
compileGHC _ (_, ListResult{lTool = _}) = pure (Right ())
compileHLS :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
=> CompileHLS.CompileHLSOptions -> (Int, ListResult) -> m (Either String ())
compileHLS compopts (_, lr@ListResult{lTool = HLS, ..}) = do
appstate <- ask
let run =
runResourceT
. runE @'[ AlreadyInstalled
, BuildFailed
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, GHCupSetError
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
, TarDirDoesNotExist
, TagNotFound
, DayNotFound
, NextVerNotFound
, NoToolVersionSet
, NotInstalled
, DirNotEmpty
, ArchiveResult
, UninstallFailed
, MergeFileTreeError
]
compileResult <- run (do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let vi = getVersionInfo (mkTVer lVer) GHC dls
forM_ (_viPreCompile =<< vi) $ \msg -> do
logInfo msg
logInfo
"...waiting for 5 seconds, you can still abort..."
liftIO $ threadDelay 5000000 -- for compilation, give the user a sec to intervene
ghcs <-
liftE $ forM (compopts ^. CompileHLS.targetGHCs)
(\ghc -> fmap (_tvVersion . fst) . OptParse.fromVersion (Just ghc) $ GHC)
targetVer <- liftE $ GHCup.compileHLS
(HLS.SourceDist lVer)
ghcs
(compopts ^. CompileHLS.jobs)
(compopts ^. CompileHLS.overwriteVer)
(maybe GHCupInternal IsolateDir $ compopts ^. CompileHLS.isolateDir)
(compopts ^. CompileHLS.cabalProject)
(compopts ^. CompileHLS.cabalProjectLocal)
(compopts ^. CompileHLS.updateCabal)
(compopts ^. CompileHLS.patches)
(compopts ^. CompileHLS.cabalArgs)
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls2 }} <- ask
let vi2 = getVersionInfo (mkTVer targetVer) GHC dls2
when
(compopts ^. CompileHLS.setCompile)
(liftE . void $ GHCup.setHLS targetVer SetHLSOnly Nothing)
pure (vi2, targetVer)
)
case compileResult of
VRight (vi, tv) -> do
logInfo "HLS successfully compiled and installed"
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
liftIO $ putStr (T.unpack $ prettyVer tv)
pure $ Right ()
VLeft err@(V (BuildFailed tmpdir _)) -> do
case keepDirs (appstate & settings) of
Never -> logError $ T.pack $ prettyHFError err
_ -> logError $ T.pack (prettyHFError err) <> "\n"
<> "Check the logs at " <> T.pack (fromGHCupPath $ appstate & dirs & logsDir)
<> " and the build directory "
<> T.pack tmpdir <> " for more clues." <> "\n"
<> "Make sure to clean up " <> T.pack tmpdir <> " afterwards."
pure $ Right ()
VLeft e -> do
logError $ T.pack $ prettyHFError e
pure $ Right ()
-- This is the case when the tool is not HLS... which should be impossible but,
-- it exhaustes pattern matches
compileHLS _ (_, ListResult{lTool = _}) = pure (Right ())
settings' :: IORef AppState
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
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)
let exitKey = KeyCombination (Vty.KChar 'c') [Vty.MCtrl]
case e of
Nothing -> pure ()
Just (_, r) -> do
-- Create new menus
contextMenu .= ContextMenu.create r exitKey
advanceInstallMenu .= AdvanceInstall.create exitKey
compileGHCMenu .= CompileGHC.create exitKey
compileHLSMenu .= CompileHLS.create exitKey
-- 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)

192
lib-tui/GHCup/Brick/App.hs Normal file
View File

@ -0,0 +1,192 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-
This module defines the brick App. The pattern is very simple:
- Pattern match on the Mode
- Dispatch drawing/events to the corresponding widget/s
In general each widget should know how to draw itself and how to handle its own events, so this
module should only contain:
- how to draw non-widget information. For example the footer
- how to change between modes (widgets aren't aware of the whole application state)
-}
module GHCup.Brick.App where
import qualified GHCup.Brick.Actions as Actions
import qualified GHCup.Brick.Attributes as Attributes
import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu, compileHLSMenu)
import GHCup.Brick.Common (Mode (..), Name (..))
import qualified GHCup.Brick.Common as Common
import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo
import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu
import qualified GHCup.Brick.Widgets.Navigation as Navigation
import qualified GHCup.Brick.Widgets.Tutorial as Tutorial
import qualified GHCup.Brick.Widgets.Menu as Menu
import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall
import GHCup.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
import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
import Control.Monad (when)
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]
CompileHLSPanel -> [CompileHLS.draw (st ^. compileHLSMenu), navg]
-- | On q, go back to navigation.
-- On Enter, to go to tutorial
keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState ()
keyInfoHandler ev = case ev of
VtyEvent (Vty.EvKey (Vty.KChar 'c') [Vty.MCtrl]) -> 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 'c') [Vty.MCtrl]) -> mode .= Navigation
_ -> pure ()
-- | Tab/Arrows to navigate.
navigationHandler :: BrickEvent Name e -> EventM Name BrickState ()
navigationHandler ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings'
case ev of
inner_event@(VtyEvent (Vty.EvKey key mods)) ->
case find (\(key', _, _) -> key' == KeyCombination key mods) (Actions.keyHandlers kb) of
Just (_, _, handler) -> handler
Nothing -> void $ Common.zoom appState $ Navigation.handler inner_event
inner_event -> Common.zoom appState $ Navigation.handler inner_event
contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState ()
contextMenuHandler ev = do
ctx <- use contextMenu
let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
(KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
case (ev, focusedElement) of
(_ , Nothing) -> pure ()
(VtyEvent (Vty.EvKey k m), Just n) | k == exitKey && m == mods -> mode .= Navigation
(VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel
(VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompileGHCButton) ) -> mode .= Common.CompileGHCPanel
(VtyEvent (Vty.EvKey Vty.KEnter []), Just (Common.MenuElement Common.CompileHLSButton) ) -> mode .= Common.CompileHLSPanel
_ -> Common.zoom contextMenu $ ContextMenu.handler ev
--
advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState ()
advanceInstallHandler ev = do
ctx <- use advanceInstallMenu
let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
(KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
case (ev, focusedElement) of
(_ , Nothing) -> pure ()
(VtyEvent (Vty.EvKey k m), Just n) | k == exitKey && m == mods -> mode .= ContextPanel
(VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
let iopts = ctx ^. Menu.menuStateL
Actions.withIOAction $ Actions.installWithOptions iopts
_ -> 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
(KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
case (ev, focusedElement) of
(_ , Nothing) -> pure ()
(VtyEvent (Vty.EvKey k m), Just n) | k == exitKey && m == mods -> mode .= ContextPanel
(VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
let iopts = ctx ^. Menu.menuStateL
when (Menu.isValidMenu ctx)
(Actions.withIOAction $ Actions.compileGHC iopts)
_ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev
compileHLSHandler :: BrickEvent Name e -> EventM Name BrickState ()
compileHLSHandler ev = do
ctx <- use compileHLSMenu
let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
(KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
case (ev, focusedElement) of
(_ , Nothing) -> pure ()
(VtyEvent (Vty.EvKey k m), Just n) | k == exitKey && m == mods -> mode .= ContextPanel
(VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
let iopts = ctx ^. Menu.menuStateL
when (Menu.isValidMenu ctx)
(Actions.withIOAction $ Actions.compileHLS iopts)
_ -> Common.zoom compileHLSMenu $ CompileHLS.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
CompileHLSPanel -> compileHLSHandler ev

View File

@ -0,0 +1,84 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-
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

View File

@ -0,0 +1,54 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-
This module contains the BrickState. One could be tempted to include this data structure in GHCup.Brick.Common,
but it is better to make a separated module in order to avoid cyclic dependencies.
This happens because the BrickState is sort of a container for all widgets,
but widgets depends on common functionality, hence:
BrickState `depends on` Widgets.XYZ `depends on` Common
The linear relation above breaks if BrickState is defined in Common.
-}
module GHCup.Brick.BrickState where
import GHCup.Types ( KeyBindings )
import GHCup.Brick.Common ( BrickData(..), BrickSettings(..), Mode(..))
import GHCup.Brick.Widgets.Navigation ( BrickInternalState)
import GHCup.Brick.Widgets.Menus.Context (ContextMenu)
import GHCup.Brick.Widgets.Menus.AdvanceInstall (AdvanceInstallMenu)
import GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCMenu)
import Optics.TH (makeLenses)
import GHCup.Brick.Widgets.Menus.CompileHLS (CompileHLSMenu)
data BrickState = BrickState
{ _appData :: BrickData
, _appSettings :: BrickSettings
, _appState :: BrickInternalState
, _contextMenu :: ContextMenu
, _advanceInstallMenu :: AdvanceInstallMenu
, _compileGHCMenu :: CompileGHCMenu
, _compileHLSMenu :: CompileHLSMenu
, _appKeys :: KeyBindings
, _mode :: Mode
}
--deriving Show
makeLenses ''BrickState

View File

@ -0,0 +1,216 @@
{-# 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
, CompileGHCButton, CompileHLSButton, CabalProjectEditBox
, CabalProjectLocalEditBox, UpdateCabalCheckBox
) ) 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 CompileGHCButton :: ResourceId
pattern CompileGHCButton = ResourceId 101
pattern CompileHLSButton :: ResourceId
pattern CompileHLSButton = ResourceId 102
pattern UrlEditBox :: ResourceId
pattern UrlEditBox = ResourceId 1
pattern SetCheckBox :: ResourceId
pattern SetCheckBox = ResourceId 2
pattern IsolateEditBox :: ResourceId
pattern IsolateEditBox = ResourceId 3
pattern ForceCheckBox :: ResourceId
pattern ForceCheckBox = ResourceId 4
pattern AdditionalEditBox :: ResourceId
pattern AdditionalEditBox = ResourceId 5
pattern TargetGhcEditBox :: ResourceId
pattern TargetGhcEditBox = ResourceId 6
pattern BootstrapGhcEditBox :: ResourceId
pattern BootstrapGhcEditBox = ResourceId 7
pattern JobsEditBox :: ResourceId
pattern JobsEditBox = ResourceId 8
pattern BuildConfigEditBox :: ResourceId
pattern BuildConfigEditBox = ResourceId 9
pattern PatchesEditBox :: ResourceId
pattern PatchesEditBox = ResourceId 10
pattern CrossTargetEditBox :: ResourceId
pattern CrossTargetEditBox = ResourceId 11
pattern AddConfArgsEditBox :: ResourceId
pattern AddConfArgsEditBox = ResourceId 12
pattern OvewrwiteVerEditBox :: ResourceId
pattern OvewrwiteVerEditBox = ResourceId 13
pattern BuildFlavourEditBox :: ResourceId
pattern BuildFlavourEditBox = ResourceId 14
pattern BuildSystemEditBox :: ResourceId
pattern BuildSystemEditBox = ResourceId 15
pattern CabalProjectEditBox :: ResourceId
pattern CabalProjectEditBox = ResourceId 16
pattern CabalProjectLocalEditBox :: ResourceId
pattern CabalProjectLocalEditBox = ResourceId 17
pattern UpdateCabalCheckBox :: ResourceId
pattern UpdateCabalCheckBox = ResourceId 18
-- | 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
| CompileHLSPanel
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

View 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 c+ctrl to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"]

View File

@ -0,0 +1,370 @@
{-# 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 deriving (Eq)
-- | A lens which does nothing. Usefull to defined no-op fields
emptyLens :: Lens' s ()
emptyLens = lens (const ()) (\s _ -> s)
-- | A FieldInput is a pair label-content
-- a - is the type of the field it manipulates
-- b - is its internal state (modified in the gui)
-- n - your application's resource name type
data FieldInput a b n =
FieldInput
{ inputState :: b -- ^ The state of the input field (what's rendered in the screen)
, inputValidator :: b -> Either ErrorMessage a -- ^ A validator function
, inputHelp :: HelpMessage -- ^ The input helpMessage
, inputRender :: Bool
-> ErrorStatus
-> HelpMessage
-> 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
isValidField :: MenuField s n -> Bool
isValidField = (== Valid) . fieldStatus
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.init . T.unlines . Edit.getEditContents
initEdit = Edit.editorText name (Just 1) ""
createEditableField :: (Eq n, Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> Lens' s a -> EditableField s n
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 True (Invalid err) _ _ amp = amp . centerV . renderAsErrMsg $ err
drawButton _ _ help _ amp = amp . centerV . renderAsHelpMsg $ help
createButtonField :: n -> Button s n
createButtonField = MenuField emptyLens createButtonInput "" Valid
{- *****************
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
isValidMenu :: Menu s n -> Bool
isValidMenu = all isValidField . menuFields
createMenu :: n -> s -> KeyCombination -> [Button s n] -> [MenuField s n] -> Menu s n
createMenu n initial exitK buttons fields = Menu fields initial buttons ring exitK n
where ring = F.focusRing $ [field & fieldName | field <- fields] ++ [button & fieldName | button <- buttons]
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
if all isValidField updated_fields
then menuButtonsL %= fmap (fieldStatusL .~ Valid)
else menuButtonsL %= fmap (fieldStatusL .~ Invalid "Some fields are invalid")
menuFieldsL .= updated_fields
_ -> pure ()
where
-- runs the Event with the inner handler of MenuField.
updateFields :: n -> BrickEvent n () -> [MenuField s n] -> EventM n (Menu s n) [MenuField s n]
updateFields n e [] = pure []
updateFields n e (x@(MenuField {fieldInput = i@(FieldInput {..}) , ..}):xs) =
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)

View File

@ -0,0 +1,125 @@
{-# 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)
import System.FilePath (isValid, isAbsolute, normalise)
import GHCup.Prelude (stripNewlineEnd)
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 -> absolutePathParser (T.unpack i)
False -> Right Nothing
absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath)
absolutePathParser f = case isValid f && isAbsolute f of
True -> Right . Just . stripNewlineEnd . normalise $ f
False -> Left "Please enter a valid absolute filepath."
additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
additionalValidator = Right . T.split isSpace
fields =
[ Menu.createEditableField (Common.MenuElement Common.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

View File

@ -0,0 +1,207 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module GHCup.Brick.Widgets.Menus.CompileGHC (
CompileGHCOptions,
CompileGHCMenu,
create,
handler,
draw,
bootstrapGhc,
jobs,
buildConfig,
patches,
crossTarget,
addConfArgs,
setCompile,
overwriteVer,
buildFlavour,
buildSystem,
isolateDir,
) where
import GHCup.Brick.Widgets.Menu (Menu)
import qualified GHCup.Brick.Widgets.Menu as Menu
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(..), VersionPattern )
import URI.ByteString (URI)
import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8
import GHCup.Utils (parseURI)
import Data.Bifunctor (Bifunctor(..))
import Data.Function ((&))
import Optics ((.~))
import Data.Char (isSpace)
import Data.Versions (Version, version)
import System.FilePath (isPathSeparator, isValid, isAbsolute, normalise)
import Control.Applicative (Alternative((<|>)))
import Text.Read (readEither)
import GHCup.Prelude (stripNewlineEnd)
import qualified GHCup.OptParse.Common as OptParse
data CompileGHCOptions = CompileGHCOptions
{ _bootstrapGhc :: Either Version FilePath
, _jobs :: Maybe Int
, _buildConfig :: Maybe FilePath
, _patches :: Maybe (Either FilePath [URI])
, _crossTarget :: Maybe T.Text
, _addConfArgs :: [T.Text]
, _setCompile :: Bool
, _overwriteVer :: Maybe [VersionPattern]
, _buildFlavour :: Maybe String
, _buildSystem :: Maybe BuildSystem
, _isolateDir :: Maybe FilePath
} 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 i)
readPath = do
mfilepath <- filepathV i
case mfilepath of
Nothing -> Left "Invalid Empty value"
Just f -> Right (Right f)
in if T.any isPathSeparator i
then readPath
else readVersion
False -> Left "Invalid Empty value"
versionV :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern])
versionV = whenEmpty Nothing (bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack)
jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int)
jobsV =
let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack
in whenEmpty Nothing parseInt
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 i =
case not $ emptyEditor i of
True -> absolutePathParser (T.unpack i)
False -> Right Nothing
absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath)
absolutePathParser f = case isValid f && isAbsolute f of
True -> Right . Just . stripNewlineEnd . normalise $ f
False -> Left "Please enter a valid absolute filepath."
additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
additionalValidator = Right . T.split isSpace
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 Make
| 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 overwriteVer
& Menu.fieldLabelL .~ "overwrite-version"
& Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one"
, Menu.createEditableField (Common.MenuElement Common.BuildSystemEditBox) systemV buildSystem
& Menu.fieldLabelL .~ "build system"
& Menu.fieldHelpMsgL .~ "either 'make' or 'hadrian'"
, Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour
& Menu.fieldLabelL .~ "flavour"
& Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
, Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir
& Menu.fieldLabelL .~ "isolated"
& 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"
& Menu.fieldStatusL .~ Menu.Invalid "bootstrap GHC is mandatory"
]
handler :: BrickEvent Name e -> EventM Name CompileGHCMenu ()
handler = Menu.handlerMenu
draw :: CompileGHCMenu -> Widget Name
draw = Common.frontwardLayer "Compile GHC" . Menu.drawMenu

View File

@ -0,0 +1,191 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE InstanceSigs #-}
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
module GHCup.Brick.Widgets.Menus.CompileHLS (
CompileHLSOptions,
CompileHLSMenu,
create,
handler,
draw,
jobs,
setCompile,
updateCabal,
overwriteVer,
isolateDir,
cabalProject,
cabalProjectLocal,
patches,
targetGHCs,
cabalArgs,
)
where
import GHCup.Brick.Widgets.Menu (Menu)
import qualified GHCup.Brick.Widgets.Menu as Menu
import GHCup.Brick.Common(Name(..))
import Brick
( BrickEvent(..),
EventM,
Widget(..))
import Prelude hiding ( appendFile )
import Optics.TH (makeLenses)
import qualified GHCup.Brick.Common as Common
import GHCup.Types (KeyCombination, VersionPattern, ToolVersion)
import URI.ByteString (URI)
import qualified Data.Text as T
import qualified Data.ByteString.UTF8 as UTF8
import GHCup.Utils (parseURI)
import Data.Bifunctor (Bifunctor(..))
import Data.Function ((&))
import Optics ((.~))
import Data.Char (isSpace)
import System.FilePath (isValid, isAbsolute, normalise)
import Control.Applicative (Alternative((<|>)))
import Text.Read (readEither)
import GHCup.Prelude (stripNewlineEnd)
import qualified GHCup.OptParse.Common as OptParse
data CompileHLSOptions = CompileHLSOptions
{ _jobs :: Maybe Int
, _setCompile :: Bool
, _updateCabal :: Bool
, _overwriteVer :: Maybe [VersionPattern]
, _isolateDir :: Maybe FilePath
, _cabalProject :: Maybe (Either FilePath URI)
, _cabalProjectLocal :: Maybe URI
, _patches :: Maybe (Either FilePath [URI])
, _targetGHCs :: [ToolVersion]
, _cabalArgs :: [T.Text]
} deriving (Eq, Show)
makeLenses ''CompileHLSOptions
type CompileHLSMenu = Menu CompileHLSOptions Name
create :: KeyCombination -> CompileHLSMenu
create k = Menu.createMenu CompileGHCBox initialState k buttons fields
where
initialState =
CompileHLSOptions
Nothing
False
False
Nothing
Nothing
Nothing
Nothing
Nothing
[]
[]
-- Brick's internal editor representation is [mempty].
emptyEditor i = T.null i || (i == "\n")
whenEmpty :: a -> (T.Text -> Either Menu.ErrorMessage a) -> T.Text -> Either Menu.ErrorMessage a
whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval
cabalProjectV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath URI))
cabalProjectV i =
case not $ emptyEditor i of
True ->
let readPath = Right . Left . stripNewlineEnd . T.unpack $ i
in bimap T.pack Just $ second Right (readUri i) <|> readPath
False -> Right Nothing
{- There is an unwanted dependency to ghcup-opt... Alternatives are
- copy-paste a bunch of code
- define a new common library
-}
ghcVersionTagEither :: T.Text -> Either Menu.ErrorMessage [ToolVersion]
ghcVersionTagEither = first T.pack . traverse (OptParse.ghcVersionTagEither . T.unpack) . T.split isSpace
overWriteVersionParser :: T.Text -> Either Menu.ErrorMessage (Maybe [VersionPattern])
overWriteVersionParser = bimap T.pack Just . OptParse.overWriteVersionParser . T.unpack
jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int)
jobsV =
let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack
in whenEmpty Nothing parseInt
readUri :: T.Text -> Either String URI
readUri = first show . parseURI . UTF8.fromString . T.unpack
patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI]))
patchesV = whenEmpty Nothing readPatches
where
readPatches j =
let
x = (bimap T.unpack (fmap Left) $ filepathV j)
y = second (Just . Right) $ traverse readUri (T.split isSpace j)
in first T.pack $ x <|> y
filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
filepathV i =
case not $ emptyEditor i of
True -> absolutePathParser (T.unpack i)
False -> Right Nothing
absolutePathParser :: FilePath -> Either Menu.ErrorMessage (Maybe FilePath)
absolutePathParser f = case isValid f && isAbsolute f of
True -> Right . Just . stripNewlineEnd . normalise $ f
False -> Left "Please enter a valid absolute filepath."
additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
additionalValidator = Right . T.split isSpace
fields =
[ Menu.createEditableField (Common.MenuElement Common.CabalProjectEditBox) cabalProjectV cabalProject
& Menu.fieldLabelL .~ "cabal project"
& Menu.fieldHelpMsgL .~ "If relative filepath, specifies the path to cabal.project inside the unpacked HLS tarball/checkout. Otherwise expects a full URI with https/http/file scheme."
, Menu.createEditableField (Common.MenuElement Common.CabalProjectLocalEditBox) (bimap T.pack Just . readUri) cabalProjectLocal
& Menu.fieldLabelL .~ "cabal project local"
& Menu.fieldHelpMsgL .~ "URI (https/http/file) to a cabal.project.local to be used for the build. Will be copied over."
, Menu.createCheckBoxField (Common.MenuElement Common.UpdateCabalCheckBox) updateCabal
& Menu.fieldLabelL .~ "cabal update"
& Menu.fieldHelpMsgL .~ "Run 'cabal update' before the build"
, Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs
& Menu.fieldLabelL .~ "jobs"
& Menu.fieldHelpMsgL .~ "How many jobs to use for make"
, Menu.createEditableField (Common.MenuElement Common.TargetGhcEditBox) ghcVersionTagEither targetGHCs
& Menu.fieldLabelL .~ "target GHC"
& Menu.fieldHelpMsgL .~ "For which GHC version to compile for (can be specified multiple times)"
, Menu.createEditableField (Common.MenuElement Common.PatchesEditBox) patchesV patches
& Menu.fieldLabelL .~ "patches"
& Menu.fieldHelpMsgL .~ "Either a URI to a patch (https/http/file) or Absolute path to patch directory"
, Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile
& Menu.fieldLabelL .~ "set"
& Menu.fieldHelpMsgL .~ "Set as active version after install"
, Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator cabalArgs
& Menu.fieldLabelL .~ "CONFIGURE_ARGS"
& Menu.fieldHelpMsgL .~ "Additional arguments to cabal install, prefix with '-- ' (longopts)"
, Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir
& Menu.fieldLabelL .~ "isolated"
& Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one"
, Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) overWriteVersionParser overwriteVer
& Menu.fieldLabelL .~ "overwrite version"
& Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one"
]
buttons = [
Menu.createButtonField (Common.MenuElement Common.OkButton)
& Menu.fieldLabelL .~ "Compile"
& Menu.fieldHelpMsgL .~ "Compile HLS from source with options below"
]
handler :: BrickEvent Name e -> EventM Name CompileHLSMenu ()
handler = Menu.handlerMenu
draw :: CompileHLSMenu -> Widget Name
draw = Common.frontwardLayer "Compile HLS" . Menu.drawMenu

View File

@ -0,0 +1,82 @@
{-# 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"
compileGhcButton =
Menu.createButtonField (MenuElement Common.CompileGHCButton)
& Menu.fieldLabelL .~ "Compile"
& Menu.fieldHelpMsgL .~ "Compile GHC from source"
compileHLSButton =
Menu.createButtonField (MenuElement Common.CompileHLSButton)
& Menu.fieldLabelL .~ "Compile"
& Menu.fieldHelpMsgL .~ "Compile HLS from source"
buttons =
case lTool lr of
GHC -> [advInstallButton, compileGhcButton]
HLS -> [advInstallButton, compileHLSButton]
_ -> [advInstallButton]
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

View File

@ -0,0 +1,151 @@
{-# 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.Core ( putCursor )
import Brick.Types ( Location(..) )
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
active = if b then putCursor Common.AllTools (Location (0,0)) else id
in hooray $ active $ dim
( marks
<+> Brick.padLeft (Pad 2)
( minHSize 6
(printTool lTool)
)
<+> minHSize minVerSize (Brick.str ver)
<+> (let l = mapMaybe printTag $ sort lTag'
in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l
then Brick.emptyWidget
else foldr1 (\x y -> x <+> Brick.str "," <+> y) l
)
<+> Brick.padLeft (Pad 5)
( let notes = printNotes listResult
in if null notes
then Brick.emptyWidget
else foldr1 (\x y -> x <+> Brick.str "," <+> y) notes
)
<+> Brick.vLimit 1 (Brick.fill ' ')
)
printTag Recommended = Just $ Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended"
printTag Latest = Just $ Brick.withAttr Attributes.latestAttr $ Brick.str "latest"
printTag Prerelease = Just $ Brick.withAttr Attributes.prereleaseAttr $ Brick.str "prerelease"
printTag Nightly = Just $ Brick.withAttr Attributes.nightlyAttr $ Brick.str "nightly"
printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag Old = Nothing
printTag LatestPrerelease = Just $ Brick.withAttr Attributes.latestPrereleaseAttr $ Brick.str "latest-prerelease"
printTag LatestNightly = Just $ Brick.withAttr Attributes.latestNightlyAttr $ Brick.str "latest-nightly"
printTag (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 ' ')

View 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

View 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 c+ctrl to exit the tutorial")

View File

@ -0,0 +1,79 @@
{-# 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 (..), KeyCombination (KeyCombination) )
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 qualified Graphics.Vty as Vty
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
import qualified GHCup.Brick.Widgets.Menus.CompileHLS as CompileHLS
brickMain :: AppState
-> IO ()
brickMain s = do
writeIORef Actions.settings' s
eAppData <- Actions.getAppData (Just $ ghcupInfo s)
case eAppData of
Right ad -> do
let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing
current_element = Navigation.sectionListSelectedElement initial_list
exit_key = KeyCombination (Vty.KChar 'c') [Vty.MCtrl] -- bQuit . keyBindings $ s
case current_element of
Nothing -> do
flip runReaderT s $ logError "Error building app state: empty ResultList"
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 exit_key)
(CompileGHC.create exit_key)
(CompileHLS.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