Compare commits
	
		
			9 Commits
		
	
	
		
			master
			...
			advance-in
		
	
	| Author | SHA1 | Date | |
|---|---|---|---|
| 
						 | 
					e1454d0551 | ||
| 
						 | 
					06ace5324f | ||
| 
						 | 
					b619a65ede | ||
| 
						 | 
					33ace9557e | ||
| 
						 | 
					2a2385731b | ||
| 
						 | 
					16967bdc5f | ||
| 
						 | 
					3298f2293b | ||
| 
						 | 
					ddd76ab7ee | ||
| 
						 | 
					e768fcb46c | 
@ -11,7 +11,8 @@
 | 
			
		||||
module Main where
 | 
			
		||||
 | 
			
		||||
#if defined(BRICK)
 | 
			
		||||
import           BrickMain                    ( brickMain )
 | 
			
		||||
-- import           BrickMain                    ( brickMain )
 | 
			
		||||
import           GHCup.BrickMain (brickMain)
 | 
			
		||||
#endif
 | 
			
		||||
 | 
			
		||||
import qualified GHCup.GHC as GHC
 | 
			
		||||
 | 
			
		||||
							
								
								
									
										56
									
								
								ghcup.cabal
									
									
									
									
									
								
							
							
						
						
									
										56
									
								
								ghcup.cabal
									
									
									
									
									
								
							@ -323,6 +323,61 @@ library ghcup-optparse
 | 
			
		||||
  else
 | 
			
		||||
    build-depends:  unix ^>=2.7 || ^>=2.8
 | 
			
		||||
 | 
			
		||||
library ghcup-tui
 | 
			
		||||
  import:             app-common-depends
 | 
			
		||||
  exposed-modules:
 | 
			
		||||
    GHCup.BrickMain
 | 
			
		||||
    GHCup.Brick.Widgets.Navigation
 | 
			
		||||
    GHCup.Brick.Widgets.Tutorial
 | 
			
		||||
    GHCup.Brick.Widgets.KeyInfo
 | 
			
		||||
    GHCup.Brick.Widgets.SectionList
 | 
			
		||||
    GHCup.Brick.Widgets.Menu
 | 
			
		||||
    GHCup.Brick.Widgets.Menus.Context
 | 
			
		||||
    GHCup.Brick.Widgets.Menus.AdvanceInstall
 | 
			
		||||
    GHCup.Brick.Widgets.Menus.CompileGHC
 | 
			
		||||
    GHCup.Brick.Actions
 | 
			
		||||
    GHCup.Brick.App
 | 
			
		||||
    GHCup.Brick.BrickState
 | 
			
		||||
    GHCup.Brick.Attributes
 | 
			
		||||
    GHCup.Brick.Common
 | 
			
		||||
 | 
			
		||||
  hs-source-dirs:     lib-tui
 | 
			
		||||
  default-language:   Haskell2010
 | 
			
		||||
  default-extensions:
 | 
			
		||||
    LambdaCase
 | 
			
		||||
    MultiWayIf
 | 
			
		||||
    NamedFieldPuns
 | 
			
		||||
    PackageImports
 | 
			
		||||
    RecordWildCards
 | 
			
		||||
    ScopedTypeVariables
 | 
			
		||||
    StrictData
 | 
			
		||||
    TupleSections
 | 
			
		||||
 | 
			
		||||
  ghc-options:
 | 
			
		||||
    -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
 | 
			
		||||
    -fwarn-incomplete-record-updates
 | 
			
		||||
 | 
			
		||||
  build-depends:  
 | 
			
		||||
    , ghcup
 | 
			
		||||
    , ghcup-optparse
 | 
			
		||||
    , optics        ^>=0.4
 | 
			
		||||
    , brick         ^>=2.1
 | 
			
		||||
    , transformers  ^>=0.5
 | 
			
		||||
    , vty           ^>=6.0
 | 
			
		||||
    , optics        ^>=0.4
 | 
			
		||||
 | 
			
		||||
  if flag(internal-downloader)
 | 
			
		||||
    cpp-options: -DINTERNAL_DOWNLOADER
 | 
			
		||||
 | 
			
		||||
  if flag(tui)
 | 
			
		||||
    cpp-options:   -DBRICK
 | 
			
		||||
 | 
			
		||||
  if os(windows)
 | 
			
		||||
    cpp-options: -DIS_WINDOWS
 | 
			
		||||
 | 
			
		||||
  else
 | 
			
		||||
    build-depends: unix ^>=2.7
 | 
			
		||||
 | 
			
		||||
executable ghcup
 | 
			
		||||
  import:             app-common-depends
 | 
			
		||||
  main-is:            Main.hs
 | 
			
		||||
@ -346,6 +401,7 @@ executable ghcup
 | 
			
		||||
  build-depends:
 | 
			
		||||
    , ghcup
 | 
			
		||||
    , ghcup-optparse
 | 
			
		||||
    , ghcup-tui
 | 
			
		||||
 | 
			
		||||
  if flag(internal-downloader)
 | 
			
		||||
    cpp-options: -DINTERNAL_DOWNLOADER
 | 
			
		||||
 | 
			
		||||
							
								
								
									
										4
									
								
								hie.yaml
									
									
									
									
									
								
							
							
						
						
									
										4
									
								
								hie.yaml
									
									
									
									
									
								
							@ -2,6 +2,10 @@ cradle:
 | 
			
		||||
  cabal:
 | 
			
		||||
  - component: "ghcup:lib:ghcup"
 | 
			
		||||
    path: ./lib
 | 
			
		||||
  - component: "ghcup:lib:ghcup-optparse"
 | 
			
		||||
    path: ./lib-opt
 | 
			
		||||
  - component: "ghcup:lib:ghcup-tui"
 | 
			
		||||
    path: ./lib-tui
 | 
			
		||||
  - component: "ghcup:exe:ghcup"
 | 
			
		||||
    path: ./app/ghcup
 | 
			
		||||
  - component: "ghcup:lib:ghcup-optparse"
 | 
			
		||||
 | 
			
		||||
							
								
								
									
										551
									
								
								lib-tui/GHCup/Brick/Actions.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										551
									
								
								lib-tui/GHCup/Brick/Actions.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,551 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE TypeApplications  #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Actions where
 | 
			
		||||
 | 
			
		||||
import           GHCup
 | 
			
		||||
import           GHCup.Download
 | 
			
		||||
import           GHCup.Errors
 | 
			
		||||
import           GHCup.Types.Optics ( getDirs, getPlatformReq )
 | 
			
		||||
import           GHCup.Types         hiding ( LeanAppState(..) )
 | 
			
		||||
import           GHCup.Utils
 | 
			
		||||
import           GHCup.OptParse.Common (logGHCPostRm)
 | 
			
		||||
import           GHCup.Prelude ( decUTF8Safe, runBothE' )
 | 
			
		||||
import           GHCup.Prelude.Logger
 | 
			
		||||
import           GHCup.Prelude.Process
 | 
			
		||||
import           GHCup.Prompts
 | 
			
		||||
import           GHCup.Brick.Common (BrickData(..), BrickSettings(..), Name(..), Mode(..))
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import           GHCup.Brick.BrickState
 | 
			
		||||
import           GHCup.Brick.Widgets.SectionList
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu
 | 
			
		||||
import           GHCup.Brick.Widgets.Navigation (BrickInternalState)
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC
 | 
			
		||||
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import qualified Brick.Widgets.List as L
 | 
			
		||||
import qualified Brick.Focus as F
 | 
			
		||||
import           Control.Applicative
 | 
			
		||||
import           Control.Exception.Safe
 | 
			
		||||
#if !MIN_VERSION_base(4,13,0)
 | 
			
		||||
import           Control.Monad.Fail             ( MonadFail )
 | 
			
		||||
#endif
 | 
			
		||||
import           Control.Monad.Reader
 | 
			
		||||
import           Control.Monad.Trans.Except
 | 
			
		||||
import           Control.Monad.Trans.Resource
 | 
			
		||||
import           Data.Bool
 | 
			
		||||
import           Data.Functor
 | 
			
		||||
import           Data.Function ( (&), on)
 | 
			
		||||
import           Data.List
 | 
			
		||||
import           Data.Maybe
 | 
			
		||||
import           Data.IORef (IORef, readIORef, newIORef, modifyIORef)
 | 
			
		||||
import           Data.Versions hiding (Lens')
 | 
			
		||||
import           Haskus.Utils.Variant.Excepts
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
import           System.Exit
 | 
			
		||||
import           System.IO.Unsafe
 | 
			
		||||
import           System.Process                 ( system )
 | 
			
		||||
import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 | 
			
		||||
import           URI.ByteString
 | 
			
		||||
 | 
			
		||||
import qualified Data.Text                     as T
 | 
			
		||||
import qualified Data.Text.Lazy.Builder        as B
 | 
			
		||||
import qualified Data.Text.Lazy                as L
 | 
			
		||||
import qualified Graphics.Vty                  as Vty
 | 
			
		||||
import qualified Data.Vector                   as V
 | 
			
		||||
import System.Environment (getExecutablePath)
 | 
			
		||||
#if !IS_WINDOWS
 | 
			
		||||
import           GHCup.Prelude.File
 | 
			
		||||
import           System.FilePath
 | 
			
		||||
import qualified System.Posix.Process          as SPP
 | 
			
		||||
#endif
 | 
			
		||||
 | 
			
		||||
import           Optics.State (use)
 | 
			
		||||
import           Optics.State.Operators ( (.=))
 | 
			
		||||
import           Optics.Operators ((.~),(%~))
 | 
			
		||||
import           Optics.Getter (view)
 | 
			
		||||
import Optics.Optic ((%))
 | 
			
		||||
import Optics ((^.), to)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
{- Core Logic. 
 | 
			
		||||
 | 
			
		||||
This module defines the IO actions we can execute within the Brick App:
 | 
			
		||||
 - Install
 | 
			
		||||
 - Set
 | 
			
		||||
 - UnInstall
 | 
			
		||||
 - Launch the Changelog
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
-- | Update app data and list internal state based on new evidence.
 | 
			
		||||
-- This synchronises @BrickInternalState@ with @BrickData@
 | 
			
		||||
-- and @BrickSettings@.
 | 
			
		||||
updateList :: BrickData -> BrickState -> BrickState
 | 
			
		||||
updateList appD bst =
 | 
			
		||||
  let newInternalState = constructList appD (bst ^. appSettings) (Just (bst ^. appState))
 | 
			
		||||
  in  bst
 | 
			
		||||
        & appState .~ newInternalState
 | 
			
		||||
        & appData .~ appD
 | 
			
		||||
        & mode .~ Navigation
 | 
			
		||||
 | 
			
		||||
constructList :: BrickData
 | 
			
		||||
              -> BrickSettings
 | 
			
		||||
              -> Maybe BrickInternalState
 | 
			
		||||
              -> BrickInternalState
 | 
			
		||||
constructList appD settings =
 | 
			
		||||
  replaceLR (filterVisible (_showAllVersions settings))
 | 
			
		||||
            (_lr appD)
 | 
			
		||||
 | 
			
		||||
-- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0
 | 
			
		||||
selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState
 | 
			
		||||
selectBy tool predicate internal_state =
 | 
			
		||||
  let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state)
 | 
			
		||||
      tool_lens = sectionL (Singular tool) 
 | 
			
		||||
   in internal_state
 | 
			
		||||
        & sectionListFocusRingL .~ new_focus
 | 
			
		||||
        & tool_lens %~ L.listMoveTo 0            -- We move to 0 first
 | 
			
		||||
        & tool_lens %~ L.listFindBy predicate    -- The lookup by the predicate.
 | 
			
		||||
 | 
			
		||||
-- | Select the latests GHC tool
 | 
			
		||||
selectLatest :: BrickInternalState -> BrickInternalState
 | 
			
		||||
selectLatest = selectBy GHC (elem Latest . lTag)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | Replace the @appState@ or construct it based on a filter function
 | 
			
		||||
-- and a new @[ListResult]@ evidence.
 | 
			
		||||
-- When passed an existing @appState@, tries to keep the selected element.
 | 
			
		||||
replaceLR :: (ListResult -> Bool)
 | 
			
		||||
          -> [ListResult]
 | 
			
		||||
          -> Maybe BrickInternalState
 | 
			
		||||
          -> BrickInternalState
 | 
			
		||||
replaceLR filterF list_result s =
 | 
			
		||||
  let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e)
 | 
			
		||||
      newVec  =  [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)]
 | 
			
		||||
      newSectionList = sectionList AllTools newVec 1
 | 
			
		||||
  in case oldElem of
 | 
			
		||||
      Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList
 | 
			
		||||
      Nothing -> selectLatest newSectionList
 | 
			
		||||
 where
 | 
			
		||||
  toolEqual e1 e2 =
 | 
			
		||||
    lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
filterVisible :: Bool -> ListResult -> Bool
 | 
			
		||||
filterVisible v e | lInstalled e = True
 | 
			
		||||
                  | v
 | 
			
		||||
                  , Nightly `notElem` lTag e = True
 | 
			
		||||
                  | not v
 | 
			
		||||
                  , Old `notElem` lTag e
 | 
			
		||||
                  , Nightly `notElem` lTag e = True
 | 
			
		||||
                  | otherwise = (Old `notElem` lTag e)       &&
 | 
			
		||||
                                  (Nightly `notElem` lTag e)
 | 
			
		||||
 | 
			
		||||
-- | Suspend the current UI and run an IO action in terminal. If the
 | 
			
		||||
-- IO action returns a Left value, then it's thrown as userError.
 | 
			
		||||
withIOAction :: (Ord n, Eq n)
 | 
			
		||||
             => ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
 | 
			
		||||
             -> Brick.EventM n BrickState ()
 | 
			
		||||
withIOAction action = do
 | 
			
		||||
  as <- Brick.get
 | 
			
		||||
  case sectionListSelectedElement (view appState as) of
 | 
			
		||||
    Nothing      -> pure ()
 | 
			
		||||
    Just (curr_ix, e) -> do
 | 
			
		||||
      Brick.suspendAndResume $ do
 | 
			
		||||
        settings <- readIORef settings'
 | 
			
		||||
        flip runReaderT settings $ action (curr_ix, e) >>= \case
 | 
			
		||||
          Left  err -> liftIO $ putStrLn ("Error: " <> err)
 | 
			
		||||
          Right _   -> liftIO $ putStrLn "Success"
 | 
			
		||||
        getAppData Nothing >>= \case
 | 
			
		||||
          Right data' -> do
 | 
			
		||||
            putStrLn "Press enter to continue"
 | 
			
		||||
            _ <- getLine
 | 
			
		||||
            pure (updateList data' as)
 | 
			
		||||
          Left err -> throwIO $ userError err
 | 
			
		||||
 | 
			
		||||
installWithOptions :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
 | 
			
		||||
         => AdvanceInstall.InstallOptions
 | 
			
		||||
         -> (Int, ListResult)
 | 
			
		||||
         -> m (Either String ())
 | 
			
		||||
installWithOptions opts (_, ListResult {..}) = do
 | 
			
		||||
  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 | 
			
		||||
  let 
 | 
			
		||||
    misolated = opts ^. AdvanceInstall.isolateDirL
 | 
			
		||||
    shouldIsolate = maybe GHCupInternal IsolateDir (opts ^. AdvanceInstall.isolateDirL)
 | 
			
		||||
    shouldForce   = opts ^. AdvanceInstall.forceInstallL
 | 
			
		||||
    shouldSet     = opts ^. AdvanceInstall.instSetL
 | 
			
		||||
    extraArgs     = opts ^. AdvanceInstall.addConfArgsL
 | 
			
		||||
    v = GHCTargetVersion lCross lVer
 | 
			
		||||
  let run =
 | 
			
		||||
        runResourceT
 | 
			
		||||
          . runE
 | 
			
		||||
            @'[ AlreadyInstalled
 | 
			
		||||
              , ArchiveResult
 | 
			
		||||
              , UnknownArchive
 | 
			
		||||
              , FileDoesNotExistError
 | 
			
		||||
              , CopyError
 | 
			
		||||
              , NoDownload
 | 
			
		||||
              , NotInstalled
 | 
			
		||||
              , BuildFailed
 | 
			
		||||
              , TagNotFound
 | 
			
		||||
              , DigestError
 | 
			
		||||
              , ContentLengthError
 | 
			
		||||
              , GPGError
 | 
			
		||||
              , DownloadFailed
 | 
			
		||||
              , DirNotEmpty
 | 
			
		||||
              , NoUpdate
 | 
			
		||||
              , TarDirDoesNotExist
 | 
			
		||||
              , FileAlreadyExistsError
 | 
			
		||||
              , ProcessError
 | 
			
		||||
              , ToolShadowed
 | 
			
		||||
              , UninstallFailed
 | 
			
		||||
              , MergeFileTreeError
 | 
			
		||||
              , NoCompatiblePlatform
 | 
			
		||||
              , GHCup.Errors.ParseError
 | 
			
		||||
              , UnsupportedSetupCombo
 | 
			
		||||
              , DistroNotFound
 | 
			
		||||
              , NoCompatibleArch
 | 
			
		||||
              , InstallSetError
 | 
			
		||||
              ]
 | 
			
		||||
 | 
			
		||||
  run (do
 | 
			
		||||
      ce <- liftIO $ fmap (either (const Nothing) Just) $
 | 
			
		||||
        try @_ @SomeException $ getExecutablePath >>= canonicalizePath
 | 
			
		||||
      dirs <- lift getDirs
 | 
			
		||||
      case lTool of
 | 
			
		||||
        GHC   -> do
 | 
			
		||||
          let vi = getVersionInfo v GHC dls
 | 
			
		||||
          case opts ^. AdvanceInstall.instBindistL of
 | 
			
		||||
            Nothing -> do
 | 
			
		||||
              liftE $
 | 
			
		||||
                runBothE' 
 | 
			
		||||
                  (installGHCBin v shouldIsolate shouldForce  extraArgs)
 | 
			
		||||
                  (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing))
 | 
			
		||||
              pure (vi, dirs, ce) 
 | 
			
		||||
            Just uri -> do
 | 
			
		||||
              liftE $
 | 
			
		||||
                runBothE' 
 | 
			
		||||
                  (installGHCBindist
 | 
			
		||||
                      (DownloadInfo uri (Just $ RegexDir "ghc-.*") "" Nothing Nothing) 
 | 
			
		||||
                      v
 | 
			
		||||
                      shouldIsolate
 | 
			
		||||
                      shouldForce
 | 
			
		||||
                      extraArgs)
 | 
			
		||||
                  (when (shouldSet && isNothing misolated) (liftE $ void $ setGHC v SetGHCOnly Nothing))
 | 
			
		||||
              pure (vi, dirs, ce)
 | 
			
		||||
 | 
			
		||||
        Cabal -> do
 | 
			
		||||
          let vi = getVersionInfo v Cabal dls
 | 
			
		||||
          case opts ^. AdvanceInstall.instBindistL of
 | 
			
		||||
            Nothing -> do
 | 
			
		||||
              liftE $ 
 | 
			
		||||
                runBothE' 
 | 
			
		||||
                  (installCabalBin lVer shouldIsolate shouldForce)
 | 
			
		||||
                  (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer))
 | 
			
		||||
              pure (vi, dirs, ce)
 | 
			
		||||
            Just uri -> do
 | 
			
		||||
              liftE $ 
 | 
			
		||||
                runBothE' 
 | 
			
		||||
                  (installCabalBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce)
 | 
			
		||||
                  (when (shouldSet && isNothing misolated) (liftE $ void $ setCabal lVer))
 | 
			
		||||
              pure (vi, dirs, ce)
 | 
			
		||||
 | 
			
		||||
        GHCup -> do
 | 
			
		||||
          let vi = snd <$> getLatest dls GHCup
 | 
			
		||||
          liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
 | 
			
		||||
        HLS   -> do          
 | 
			
		||||
          let vi = getVersionInfo v HLS dls
 | 
			
		||||
          case opts ^. AdvanceInstall.instBindistL of
 | 
			
		||||
            Nothing -> do
 | 
			
		||||
              liftE $ 
 | 
			
		||||
                runBothE' 
 | 
			
		||||
                  (installHLSBin lVer shouldIsolate shouldForce)
 | 
			
		||||
                  (when (shouldSet && isNothing misolated) (liftE $ void $ setHLS lVer SetHLSOnly Nothing))
 | 
			
		||||
              pure (vi, dirs, ce) 
 | 
			
		||||
            Just uri -> do
 | 
			
		||||
              liftE $ 
 | 
			
		||||
                runBothE'                 
 | 
			
		||||
                  (installHLSBindist 
 | 
			
		||||
                    (DownloadInfo uri (if isWindows then Nothing else Just (RegexDir "haskell-language-server-*")) "" Nothing Nothing)
 | 
			
		||||
                    lVer
 | 
			
		||||
                    shouldIsolate
 | 
			
		||||
                    shouldForce)
 | 
			
		||||
                  (when (shouldSet && isNothing misolated)  (liftE $ void $ setHLS lVer SetHLSOnly Nothing))
 | 
			
		||||
              pure (vi, dirs, ce)
 | 
			
		||||
 | 
			
		||||
        Stack -> do
 | 
			
		||||
          let vi = getVersionInfo v Stack dls
 | 
			
		||||
          case opts ^. AdvanceInstall.instBindistL of
 | 
			
		||||
            Nothing -> do
 | 
			
		||||
              liftE $
 | 
			
		||||
                runBothE' 
 | 
			
		||||
                  (installStackBin lVer shouldIsolate shouldForce)
 | 
			
		||||
                  (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer))
 | 
			
		||||
              pure (vi, dirs, ce)
 | 
			
		||||
            Just uri -> do
 | 
			
		||||
              liftE $
 | 
			
		||||
                runBothE' 
 | 
			
		||||
                  (installStackBindist (DownloadInfo uri Nothing "" Nothing Nothing) lVer shouldIsolate shouldForce)
 | 
			
		||||
                  (when (shouldSet && isNothing misolated) (liftE $ void $ setStack lVer))
 | 
			
		||||
              pure (vi, dirs, ce)
 | 
			
		||||
 | 
			
		||||
    )
 | 
			
		||||
    >>= \case
 | 
			
		||||
          VRight (vi, Dirs{..}, Just ce) -> do
 | 
			
		||||
            forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
 | 
			
		||||
            case lTool of
 | 
			
		||||
              GHCup -> do
 | 
			
		||||
#if !IS_WINDOWS
 | 
			
		||||
                up <- liftIO $ fmap (either (const Nothing) Just)
 | 
			
		||||
                  $ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)
 | 
			
		||||
                when ((normalise <$> up) == Just (normalise ce)) $
 | 
			
		||||
                  -- TODO: track cli arguments of previous invocation
 | 
			
		||||
                  liftIO $ SPP.executeFile ce False ["tui"] Nothing
 | 
			
		||||
#else
 | 
			
		||||
                logInfo "Please restart 'ghcup' for the changes to take effect"
 | 
			
		||||
#endif
 | 
			
		||||
              _ -> pure ()
 | 
			
		||||
            pure $ Right ()
 | 
			
		||||
          VRight (vi, _, _) -> do
 | 
			
		||||
            forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
 | 
			
		||||
            logInfo "Please restart 'ghcup' for the changes to take effect"
 | 
			
		||||
            pure $ Right ()
 | 
			
		||||
          VLeft  (V (AlreadyInstalled _ _)) -> pure $ Right ()
 | 
			
		||||
          VLeft (V NoUpdate) -> pure $ Right ()
 | 
			
		||||
          VLeft e -> pure $ Left $ prettyHFError e <> "\n"
 | 
			
		||||
            <> "Also check the logs in ~/.ghcup/logs"
 | 
			
		||||
 | 
			
		||||
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) 
 | 
			
		||||
         => (Int, ListResult) -> m (Either String ())
 | 
			
		||||
install' = installWithOptions (AdvanceInstall.InstallOptions Nothing False Nothing False [])
 | 
			
		||||
 | 
			
		||||
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
 | 
			
		||||
     => (Int, ListResult)
 | 
			
		||||
     -> m (Either String ())
 | 
			
		||||
set' input@(_, ListResult {..}) = do
 | 
			
		||||
  settings <- liftIO $ readIORef settings'
 | 
			
		||||
 | 
			
		||||
  let run =
 | 
			
		||||
        flip runReaderT settings
 | 
			
		||||
          . runResourceT
 | 
			
		||||
          . runE
 | 
			
		||||
            @'[ AlreadyInstalled
 | 
			
		||||
              , ArchiveResult
 | 
			
		||||
              , UnknownArchive
 | 
			
		||||
              , FileDoesNotExistError
 | 
			
		||||
              , CopyError
 | 
			
		||||
              , NoDownload
 | 
			
		||||
              , NotInstalled
 | 
			
		||||
              , BuildFailed
 | 
			
		||||
              , TagNotFound
 | 
			
		||||
              , DigestError
 | 
			
		||||
              , ContentLengthError
 | 
			
		||||
              , GPGError
 | 
			
		||||
              , DownloadFailed
 | 
			
		||||
              , DirNotEmpty
 | 
			
		||||
              , NoUpdate
 | 
			
		||||
              , TarDirDoesNotExist
 | 
			
		||||
              , FileAlreadyExistsError
 | 
			
		||||
              , ProcessError
 | 
			
		||||
              , ToolShadowed
 | 
			
		||||
              , UninstallFailed
 | 
			
		||||
              , MergeFileTreeError
 | 
			
		||||
              , NoCompatiblePlatform
 | 
			
		||||
              , GHCup.Errors.ParseError
 | 
			
		||||
              , UnsupportedSetupCombo
 | 
			
		||||
              , DistroNotFound
 | 
			
		||||
              , NoCompatibleArch
 | 
			
		||||
              ]
 | 
			
		||||
 | 
			
		||||
  run (do
 | 
			
		||||
      case lTool of
 | 
			
		||||
        GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
 | 
			
		||||
        Cabal -> liftE $ setCabal lVer $> ()
 | 
			
		||||
        HLS   -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
 | 
			
		||||
        Stack -> liftE $ setStack lVer $> ()
 | 
			
		||||
        GHCup -> do
 | 
			
		||||
          promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: "
 | 
			
		||||
          case promptAnswer of
 | 
			
		||||
                PromptYes -> do
 | 
			
		||||
                  void $ liftE $ upgradeGHCup Nothing False False
 | 
			
		||||
                PromptNo -> pure ()
 | 
			
		||||
    )
 | 
			
		||||
    >>= \case
 | 
			
		||||
          VRight _ -> pure $ Right ()
 | 
			
		||||
          VLeft  e -> case e of
 | 
			
		||||
            (V (NotInstalled tool _)) -> do
 | 
			
		||||
              promptAnswer <- getUserPromptResponse userPrompt
 | 
			
		||||
              case promptAnswer of
 | 
			
		||||
                PromptYes -> do
 | 
			
		||||
                  res <- install' input
 | 
			
		||||
                  case res of
 | 
			
		||||
                    (Left err) -> pure $ Left err
 | 
			
		||||
                    (Right _) -> do
 | 
			
		||||
                      logInfo "Setting now..."
 | 
			
		||||
                      set' input
 | 
			
		||||
 | 
			
		||||
                PromptNo -> pure $ Left (prettyHFError e)
 | 
			
		||||
              where
 | 
			
		||||
                userPrompt = L.toStrict . B.toLazyText . B.fromString $
 | 
			
		||||
                  "This Version of "
 | 
			
		||||
                  <> show tool
 | 
			
		||||
                  <> " you are trying to set is not installed.\n"
 | 
			
		||||
                  <> "Would you like to install it first? [Y/N]: "
 | 
			
		||||
 | 
			
		||||
            _ -> pure $ Left (prettyHFError e)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
 | 
			
		||||
     => (Int, ListResult)
 | 
			
		||||
     -> m (Either String ())
 | 
			
		||||
del' (_, ListResult {..}) = do
 | 
			
		||||
  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 | 
			
		||||
 | 
			
		||||
  let run = runE @'[NotInstalled, UninstallFailed]
 | 
			
		||||
 | 
			
		||||
  run (do
 | 
			
		||||
      let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls
 | 
			
		||||
      case lTool of
 | 
			
		||||
        GHC   -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
 | 
			
		||||
        Cabal -> liftE $ rmCabalVer lVer $> vi
 | 
			
		||||
        HLS   -> liftE $ rmHLSVer lVer $> vi
 | 
			
		||||
        Stack -> liftE $ rmStackVer lVer $> vi
 | 
			
		||||
        GHCup -> pure Nothing
 | 
			
		||||
    )
 | 
			
		||||
    >>= \case
 | 
			
		||||
          VRight vi -> do
 | 
			
		||||
            when (lTool == GHC) $ logGHCPostRm (mkTVer lVer)
 | 
			
		||||
            forM_ (_viPostRemove =<< vi) $ \msg ->
 | 
			
		||||
              logInfo msg
 | 
			
		||||
            pure $ Right ()
 | 
			
		||||
          VLeft  e -> pure $ Left (prettyHFError e)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
changelog' :: (MonadReader AppState m, MonadIO m)
 | 
			
		||||
           => (Int, ListResult)
 | 
			
		||||
           -> m (Either String ())
 | 
			
		||||
changelog' (_, ListResult {..}) = do
 | 
			
		||||
  AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 | 
			
		||||
  case getChangeLog dls lTool (ToolVersion lVer) of
 | 
			
		||||
    Nothing -> pure $ Left $
 | 
			
		||||
      "Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
 | 
			
		||||
    Just uri -> do
 | 
			
		||||
      case _rPlatform pfreq of
 | 
			
		||||
            Darwin  -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
 | 
			
		||||
            Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
 | 
			
		||||
            FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
 | 
			
		||||
            Windows -> do
 | 
			
		||||
              let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri)
 | 
			
		||||
              c <- liftIO $ system $ args
 | 
			
		||||
              case c of
 | 
			
		||||
                 (ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args]
 | 
			
		||||
                 ExitSuccess -> pure $ Right ()
 | 
			
		||||
 | 
			
		||||
       >>= \case
 | 
			
		||||
        Right _ -> pure $ Right ()
 | 
			
		||||
        Left  e -> pure $ Left $ prettyHFError e
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
settings' :: IORef AppState
 | 
			
		||||
{-# NOINLINE settings' #-}
 | 
			
		||||
settings' = unsafePerformIO $ do
 | 
			
		||||
  dirs <- getAllDirs
 | 
			
		||||
  let loggerConfig = LoggerConfig { lcPrintDebug  = False
 | 
			
		||||
                                  , consoleOutter = \_ -> pure ()
 | 
			
		||||
                                  , fileOutter    = \_ -> pure ()
 | 
			
		||||
                                  , fancyColors   = True
 | 
			
		||||
                                  }
 | 
			
		||||
  newIORef $ AppState defaultSettings
 | 
			
		||||
                      dirs
 | 
			
		||||
                      defaultKeyBindings
 | 
			
		||||
                      (GHCupInfo mempty mempty Nothing)
 | 
			
		||||
                      (PlatformRequest A_64 Darwin Nothing)
 | 
			
		||||
                      loggerConfig
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
getGHCupInfo :: IO (Either String GHCupInfo)
 | 
			
		||||
getGHCupInfo = do
 | 
			
		||||
  settings <- readIORef settings'
 | 
			
		||||
 | 
			
		||||
  r <-
 | 
			
		||||
    flip runReaderT settings
 | 
			
		||||
    . runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
 | 
			
		||||
    $ do
 | 
			
		||||
      pfreq <- lift getPlatformReq
 | 
			
		||||
      liftE $ getDownloadsF pfreq
 | 
			
		||||
 | 
			
		||||
  case r of
 | 
			
		||||
    VRight a -> pure $ Right a
 | 
			
		||||
    VLeft  e -> pure $ Left (prettyHFError e)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
getAppData :: Maybe GHCupInfo
 | 
			
		||||
           -> IO (Either String BrickData)
 | 
			
		||||
getAppData mgi = runExceptT $ do
 | 
			
		||||
  r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
 | 
			
		||||
  liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
 | 
			
		||||
  settings <- liftIO $ readIORef settings'
 | 
			
		||||
 | 
			
		||||
  flip runReaderT settings $ do
 | 
			
		||||
    lV <- listVersions Nothing [] False True (Nothing, Nothing)
 | 
			
		||||
    pure $ BrickData (reverse lV)
 | 
			
		||||
 | 
			
		||||
-- 
 | 
			
		||||
 | 
			
		||||
keyHandlers :: KeyBindings
 | 
			
		||||
            -> [ ( KeyCombination
 | 
			
		||||
                 , BrickSettings -> String
 | 
			
		||||
                 , Brick.EventM Name BrickState ()
 | 
			
		||||
                 )
 | 
			
		||||
               ]
 | 
			
		||||
keyHandlers KeyBindings {..} =
 | 
			
		||||
  [ (bQuit, const "Quit"     , Brick.halt)
 | 
			
		||||
  , (bInstall, const "Install"  , withIOAction install')
 | 
			
		||||
  , (bUninstall, const "Uninstall", withIOAction del')
 | 
			
		||||
  , (bSet, const "Set"      , withIOAction set')
 | 
			
		||||
  , (bChangelog, const "ChangeLog", withIOAction changelog')
 | 
			
		||||
  , ( bShowAllVersions
 | 
			
		||||
    , \BrickSettings {..} ->
 | 
			
		||||
       if _showAllVersions then "Don't show all versions" else "Show all versions"
 | 
			
		||||
    , hideShowHandler' (not . _showAllVersions)
 | 
			
		||||
    )
 | 
			
		||||
  , (bUp, const "Up", Common.zoom appState moveUp)
 | 
			
		||||
  , (bDown, const "Down", Common.zoom appState moveDown)
 | 
			
		||||
  , (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo)
 | 
			
		||||
  , (KeyCombination Vty.KEnter [], const "advance options", createMenuforTool )
 | 
			
		||||
  ]
 | 
			
		||||
 where
 | 
			
		||||
  createMenuforTool = do 
 | 
			
		||||
    e <- use (appState % to sectionListSelectedElement)
 | 
			
		||||
    case e of
 | 
			
		||||
      Nothing     -> pure ()
 | 
			
		||||
      Just (_, r) -> do
 | 
			
		||||
        -- Create new menus
 | 
			
		||||
        contextMenu .= ContextMenu.create r bQuit
 | 
			
		||||
        advanceInstallMenu .= AdvanceInstall.create bQuit
 | 
			
		||||
        compileGHCMenu .= CompileGHC.create bQuit
 | 
			
		||||
        -- Set mode to context
 | 
			
		||||
        mode           .= ContextPanel
 | 
			
		||||
    pure ()
 | 
			
		||||
 | 
			
		||||
  --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
 | 
			
		||||
  hideShowHandler' f = do 
 | 
			
		||||
    app_settings <- use appSettings
 | 
			
		||||
    let 
 | 
			
		||||
      vers = f app_settings
 | 
			
		||||
      newAppSettings = app_settings & Common.showAllVersions .~ vers
 | 
			
		||||
    ad <- use appData
 | 
			
		||||
    current_app_state <- use appState
 | 
			
		||||
    appSettings .= newAppSettings
 | 
			
		||||
    appState    .= constructList ad newAppSettings (Just current_app_state)
 | 
			
		||||
							
								
								
									
										184
									
								
								lib-tui/GHCup/Brick/App.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										184
									
								
								lib-tui/GHCup/Brick/App.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,184 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
 | 
			
		||||
{-
 | 
			
		||||
This module defines the brick App. The pattern is very simple:
 | 
			
		||||
 | 
			
		||||
- Pattern match on the Mode
 | 
			
		||||
- Dispatch drawing/events to the corresponding widget/s
 | 
			
		||||
 | 
			
		||||
In general each widget should know how to draw itself and how to handle its own events, so this
 | 
			
		||||
module should only contain:
 | 
			
		||||
 | 
			
		||||
- how to draw non-widget information. For example the footer
 | 
			
		||||
- how to change between modes (widgets aren't aware of the whole application state)
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.App where
 | 
			
		||||
 | 
			
		||||
import qualified GHCup.Brick.Actions as Actions
 | 
			
		||||
import qualified GHCup.Brick.Attributes as Attributes
 | 
			
		||||
import GHCup.Brick.BrickState (BrickState (..), advanceInstallMenu, appKeys, appSettings, appState, contextMenu, mode, compileGHCMenu)
 | 
			
		||||
import GHCup.Brick.Common (Mode (..), Name (..))
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import qualified GHCup.Brick.Widgets.KeyInfo as KeyInfo
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Navigation as Navigation
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Tutorial as Tutorial
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menu as Menu
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall
 | 
			
		||||
 | 
			
		||||
import GHCup.Types (AppState (AppState, keyBindings), KeyCombination (KeyCombination))
 | 
			
		||||
 | 
			
		||||
import qualified Brick.Focus as F
 | 
			
		||||
import Brick (
 | 
			
		||||
  App (..),
 | 
			
		||||
  AttrMap,
 | 
			
		||||
  BrickEvent (VtyEvent),
 | 
			
		||||
  EventM,
 | 
			
		||||
  Widget (..),
 | 
			
		||||
  (<=>),
 | 
			
		||||
 )
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import Control.Monad.Reader (
 | 
			
		||||
  MonadIO (liftIO),
 | 
			
		||||
  void,
 | 
			
		||||
 )
 | 
			
		||||
import Data.IORef (readIORef)
 | 
			
		||||
import Data.List (find, intercalate)
 | 
			
		||||
import Prelude hiding (appendFile)
 | 
			
		||||
 | 
			
		||||
import qualified Graphics.Vty as Vty
 | 
			
		||||
 | 
			
		||||
import qualified Data.Text as T
 | 
			
		||||
 | 
			
		||||
import Optics.Getter (to)
 | 
			
		||||
import Optics.Operators ((^.))
 | 
			
		||||
import Optics.Optic ((%))
 | 
			
		||||
import Optics.State (use)
 | 
			
		||||
import Optics.State.Operators ((.=))
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC
 | 
			
		||||
 | 
			
		||||
app :: AttrMap -> AttrMap -> App BrickState () Name
 | 
			
		||||
app attrs dimAttrs =
 | 
			
		||||
  App { appDraw         = drawUI dimAttrs
 | 
			
		||||
      , appHandleEvent  = eventHandler
 | 
			
		||||
      , appStartEvent   = return ()
 | 
			
		||||
      , appAttrMap      = const attrs
 | 
			
		||||
      , appChooseCursor = Brick.showFirstCursor
 | 
			
		||||
      }
 | 
			
		||||
 | 
			
		||||
drawUI :: AttrMap -> BrickState -> [Widget Name]
 | 
			
		||||
drawUI dimAttrs st =
 | 
			
		||||
  let 
 | 
			
		||||
    footer = Brick.withAttr Attributes.helpAttr
 | 
			
		||||
      . Brick.txtWrap
 | 
			
		||||
      . T.pack
 | 
			
		||||
      . foldr1 (\x y -> x <> "  " <> y)
 | 
			
		||||
      . fmap (\(KeyCombination key mods, pretty_setting, _) 
 | 
			
		||||
                  -> intercalate "+" (Common.showKey key : (Common.showMod <$> mods)) <> ":" <> pretty_setting (st ^. appSettings)
 | 
			
		||||
             )
 | 
			
		||||
      $ Actions.keyHandlers (st ^. appKeys)
 | 
			
		||||
    navg = Navigation.draw dimAttrs (st ^. appState) <=> footer
 | 
			
		||||
  in case st ^. mode of
 | 
			
		||||
       Navigation   -> [navg]
 | 
			
		||||
       Tutorial     -> [Tutorial.draw, navg]
 | 
			
		||||
       KeyInfo      -> [KeyInfo.draw (st ^. appKeys), navg]
 | 
			
		||||
       ContextPanel -> [ContextMenu.draw (st ^. contextMenu), navg]
 | 
			
		||||
       AdvanceInstallPanel -> [AdvanceInstall.draw (st ^. advanceInstallMenu), navg]
 | 
			
		||||
       CompileGHCPanel     -> [CompileGHC.draw (st ^. compileGHCMenu), navg]
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | On q, go back to navigation. 
 | 
			
		||||
--   On Enter, to go to tutorial
 | 
			
		||||
keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState ()
 | 
			
		||||
keyInfoHandler ev = case ev of
 | 
			
		||||
  VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation
 | 
			
		||||
  VtyEvent (Vty.EvKey Vty.KEnter _ )   -> mode .= Tutorial
 | 
			
		||||
  _ -> pure ()
 | 
			
		||||
 | 
			
		||||
-- | On q, go back to navigation. Else, do nothing
 | 
			
		||||
tutorialHandler :: BrickEvent Name e -> EventM Name BrickState ()
 | 
			
		||||
tutorialHandler ev =
 | 
			
		||||
  case ev of
 | 
			
		||||
    VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation
 | 
			
		||||
    _ -> pure ()
 | 
			
		||||
 | 
			
		||||
-- | Tab/Arrows to navigate. 
 | 
			
		||||
navigationHandler :: BrickEvent Name e -> EventM Name BrickState ()
 | 
			
		||||
navigationHandler ev = do
 | 
			
		||||
  AppState { keyBindings = kb } <- liftIO $ readIORef Actions.settings'
 | 
			
		||||
  case ev of
 | 
			
		||||
    inner_event@(VtyEvent (Vty.EvKey key _)) ->
 | 
			
		||||
      case find (\(key', _, _) -> key' == KeyCombination key []) (Actions.keyHandlers kb) of
 | 
			
		||||
        Just (_, _, handler) -> handler
 | 
			
		||||
        Nothing -> void $ Common.zoom appState $ Navigation.handler inner_event
 | 
			
		||||
    inner_event -> Common.zoom appState $ Navigation.handler inner_event
 | 
			
		||||
 | 
			
		||||
contextMenuHandler :: BrickEvent Name e -> EventM Name BrickState ()
 | 
			
		||||
contextMenuHandler ev = do
 | 
			
		||||
  ctx <- use contextMenu 
 | 
			
		||||
  let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
 | 
			
		||||
      buttons = ctx ^. Menu.menuButtonsL
 | 
			
		||||
      (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
 | 
			
		||||
  case (ev, focusedElement) of
 | 
			
		||||
    (_ , Nothing) -> pure ()
 | 
			
		||||
    (VtyEvent (Vty.EvKey k m), Just n) 
 | 
			
		||||
      |  k == exitKey 
 | 
			
		||||
          && m == mods 
 | 
			
		||||
          && n `elem` [Menu.fieldName button | button <- buttons]
 | 
			
		||||
      -> mode .= Navigation
 | 
			
		||||
    (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.AdvanceInstallButton) ) -> mode .= Common.AdvanceInstallPanel
 | 
			
		||||
    (VtyEvent (Vty.EvKey Vty.KEnter []),  Just (Common.MenuElement Common.CompilieButton) ) -> mode .= Common.CompileGHCPanel
 | 
			
		||||
    _ -> Common.zoom contextMenu $ ContextMenu.handler ev
 | 
			
		||||
-- 
 | 
			
		||||
advanceInstallHandler :: BrickEvent Name e -> EventM Name BrickState ()
 | 
			
		||||
advanceInstallHandler ev = do
 | 
			
		||||
  ctx <- use advanceInstallMenu 
 | 
			
		||||
  let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
 | 
			
		||||
      buttons = ctx ^. Menu.menuButtonsL
 | 
			
		||||
      (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
 | 
			
		||||
  case (ev, focusedElement) of
 | 
			
		||||
    (_ , Nothing) -> pure ()
 | 
			
		||||
    (VtyEvent (Vty.EvKey k m), Just n)
 | 
			
		||||
        | k == exitKey
 | 
			
		||||
            && m == mods
 | 
			
		||||
            && n `elem` [Menu.fieldName button | button <- buttons]
 | 
			
		||||
        -> mode .= ContextPanel
 | 
			
		||||
    (VtyEvent (Vty.EvKey Vty.KEnter []), Just (MenuElement Common.OkButton)) -> do
 | 
			
		||||
        let iopts = ctx ^. Menu.menuStateL
 | 
			
		||||
        Actions.withIOAction $ Actions.installWithOptions iopts
 | 
			
		||||
    _ -> Common.zoom advanceInstallMenu $ AdvanceInstall.handler ev
 | 
			
		||||
 | 
			
		||||
compileGHCHandler :: BrickEvent Name e -> EventM Name BrickState ()
 | 
			
		||||
compileGHCHandler ev = do
 | 
			
		||||
  ctx <- use compileGHCMenu 
 | 
			
		||||
  let focusedElement = ctx ^. Menu.menuFocusRingL % to F.focusGetCurrent
 | 
			
		||||
      buttons = ctx ^. Menu.menuButtonsL
 | 
			
		||||
      (KeyCombination exitKey mods) = ctx ^. Menu.menuExitKeyL
 | 
			
		||||
  case (ev, focusedElement) of
 | 
			
		||||
    (_ , Nothing) -> pure ()
 | 
			
		||||
    (VtyEvent (Vty.EvKey k m), Just n)
 | 
			
		||||
      | k == exitKey
 | 
			
		||||
          && m == mods
 | 
			
		||||
          && n `elem` [Menu.fieldName button | button <- buttons]
 | 
			
		||||
      -> mode .= ContextPanel
 | 
			
		||||
    _ -> Common.zoom compileGHCMenu $ CompileGHC.handler ev
 | 
			
		||||
 | 
			
		||||
eventHandler :: BrickEvent Name e -> EventM Name BrickState ()
 | 
			
		||||
eventHandler ev = do
 | 
			
		||||
  m <- use mode
 | 
			
		||||
  case m of
 | 
			
		||||
    KeyInfo      -> keyInfoHandler ev
 | 
			
		||||
    Tutorial     -> tutorialHandler ev
 | 
			
		||||
    Navigation   -> navigationHandler ev
 | 
			
		||||
    ContextPanel -> contextMenuHandler ev
 | 
			
		||||
    AdvanceInstallPanel -> advanceInstallHandler ev
 | 
			
		||||
    CompileGHCPanel     -> compileGHCHandler ev
 | 
			
		||||
							
								
								
									
										86
									
								
								lib-tui/GHCup/Brick/Attributes.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										86
									
								
								lib-tui/GHCup/Brick/Attributes.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,86 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
 | 
			
		||||
{-
 | 
			
		||||
This module defined the attributes. Despite of brick's capability to have a hierarchy of attributes, here
 | 
			
		||||
we go for the most-simple-approach: a plain hierarchy
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Attributes where
 | 
			
		||||
 | 
			
		||||
import           Brick    ( AttrMap)
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import qualified Brick.Widgets.List as L
 | 
			
		||||
import qualified Graphics.Vty                  as Vty
 | 
			
		||||
 | 
			
		||||
defaultAttributes :: Bool -> AttrMap
 | 
			
		||||
defaultAttributes no_color = Brick.attrMap
 | 
			
		||||
  Vty.defAttr
 | 
			
		||||
  [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue)
 | 
			
		||||
  , (L.listSelectedAttr        , Vty.defAttr)
 | 
			
		||||
  , (notInstalledAttr          , Vty.defAttr `withForeColor` Vty.red)
 | 
			
		||||
  , (setAttr                   , Vty.defAttr `withForeColor` Vty.green)
 | 
			
		||||
  , (installedAttr             , Vty.defAttr `withForeColor` Vty.green)
 | 
			
		||||
  , (recommendedAttr           , Vty.defAttr `withForeColor` Vty.green)
 | 
			
		||||
  , (hlsPoweredAttr            , Vty.defAttr `withForeColor` Vty.green)
 | 
			
		||||
  , (latestAttr                , Vty.defAttr `withForeColor` Vty.yellow)
 | 
			
		||||
  , (latestPrereleaseAttr      , Vty.defAttr `withForeColor` Vty.red)
 | 
			
		||||
  , (latestNightlyAttr         , Vty.defAttr `withForeColor` Vty.red)
 | 
			
		||||
  , (prereleaseAttr            , Vty.defAttr `withForeColor` Vty.red)
 | 
			
		||||
  , (nightlyAttr               , Vty.defAttr `withForeColor` Vty.red)
 | 
			
		||||
  , (compiledAttr              , Vty.defAttr `withForeColor` Vty.blue)
 | 
			
		||||
  , (strayAttr                 , Vty.defAttr `withForeColor` Vty.blue)
 | 
			
		||||
  , (dayAttr                   , Vty.defAttr `withForeColor` Vty.blue)
 | 
			
		||||
  , (helpAttr                  , Vty.defAttr `withStyle`     Vty.italic)
 | 
			
		||||
  , (hoorayAttr                , Vty.defAttr `withForeColor` Vty.brightWhite)
 | 
			
		||||
  , (helpMsgAttr               , Vty.defAttr `withForeColor` Vty.brightBlack)
 | 
			
		||||
  , (errMsgAttr                , Vty.defAttr `withForeColor` Vty.red)
 | 
			
		||||
  ]
 | 
			
		||||
  where
 | 
			
		||||
    withForeColor | no_color  = const
 | 
			
		||||
                  | otherwise = Vty.withForeColor
 | 
			
		||||
 | 
			
		||||
    withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
 | 
			
		||||
                  | otherwise = Vty.withBackColor
 | 
			
		||||
 | 
			
		||||
    withStyle                 = Vty.withStyle
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr :: Brick.AttrName
 | 
			
		||||
latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr :: Brick.AttrName
 | 
			
		||||
compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr, helpMsgAttr, errMsgAttr :: Brick.AttrName
 | 
			
		||||
 | 
			
		||||
notInstalledAttr = Brick.attrName "not-installed"
 | 
			
		||||
setAttr = Brick.attrName "set"
 | 
			
		||||
installedAttr = Brick.attrName "installed"
 | 
			
		||||
recommendedAttr = Brick.attrName "recommended"
 | 
			
		||||
hlsPoweredAttr = Brick.attrName "hls-powered"
 | 
			
		||||
latestAttr = Brick.attrName "latest"
 | 
			
		||||
latestPrereleaseAttr = Brick.attrName "latest-prerelease"
 | 
			
		||||
latestNightlyAttr = Brick.attrName "latest-nightly"
 | 
			
		||||
prereleaseAttr = Brick.attrName "prerelease"
 | 
			
		||||
nightlyAttr = Brick.attrName "nightly"
 | 
			
		||||
compiledAttr = Brick.attrName "compiled"
 | 
			
		||||
strayAttr = Brick.attrName "stray"
 | 
			
		||||
dayAttr = Brick.attrName "day"
 | 
			
		||||
helpAttr = Brick.attrName "help"
 | 
			
		||||
hoorayAttr = Brick.attrName "hooray"
 | 
			
		||||
helpMsgAttr = Brick.attrName "helpMsg"
 | 
			
		||||
errMsgAttr = Brick.attrName "errMsg"
 | 
			
		||||
 | 
			
		||||
dimAttributes :: Bool -> AttrMap
 | 
			
		||||
dimAttributes no_color = Brick.attrMap
 | 
			
		||||
  (Vty.defAttr `Vty.withStyle` Vty.dim)
 | 
			
		||||
  [ (Brick.attrName "active"    , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ??
 | 
			
		||||
  , (Brick.attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
 | 
			
		||||
  ]
 | 
			
		||||
  where
 | 
			
		||||
    withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
 | 
			
		||||
                  | otherwise = Vty.withBackColor
 | 
			
		||||
							
								
								
									
										52
									
								
								lib-tui/GHCup/Brick/BrickState.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										52
									
								
								lib-tui/GHCup/Brick/BrickState.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,52 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE TypeApplications  #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# LANGUAGE ViewPatterns      #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
{-# LANGUAGE TemplateHaskell   #-}
 | 
			
		||||
{-# LANGUAGE BangPatterns #-}
 | 
			
		||||
{-# LANGUAGE InstanceSigs #-}
 | 
			
		||||
 | 
			
		||||
{-
 | 
			
		||||
This module contains the BrickState. One could be tempted to include this data structure in GHCup.Brick.Common, 
 | 
			
		||||
but it is better to make a separated module in order to avoid cyclic dependencies.
 | 
			
		||||
 | 
			
		||||
This happens because the BrickState is sort of a container for all widgets, 
 | 
			
		||||
but widgets depends on common functionality, hence:
 | 
			
		||||
 | 
			
		||||
             BrickState `depends on` Widgets.XYZ `depends on` Common 
 | 
			
		||||
 | 
			
		||||
The linear relation above breaks if BrickState is defined in Common. 
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.BrickState where
 | 
			
		||||
 | 
			
		||||
import GHCup.Types                    ( KeyBindings )
 | 
			
		||||
import GHCup.Brick.Common             ( BrickData(..), BrickSettings(..), Mode(..))
 | 
			
		||||
import GHCup.Brick.Widgets.Navigation ( BrickInternalState)
 | 
			
		||||
import GHCup.Brick.Widgets.Menus.Context (ContextMenu)
 | 
			
		||||
import GHCup.Brick.Widgets.Menus.AdvanceInstall (AdvanceInstallMenu)
 | 
			
		||||
import GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCMenu)
 | 
			
		||||
import Optics.TH                      (makeLenses)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
data BrickState = BrickState
 | 
			
		||||
  { _appData            :: BrickData
 | 
			
		||||
  , _appSettings        :: BrickSettings
 | 
			
		||||
  , _appState           :: BrickInternalState
 | 
			
		||||
  , _contextMenu        :: ContextMenu
 | 
			
		||||
  , _advanceInstallMenu :: AdvanceInstallMenu
 | 
			
		||||
  , _compileGHCMenu     :: CompileGHCMenu
 | 
			
		||||
  , _appKeys            :: KeyBindings
 | 
			
		||||
  , _mode               :: Mode
 | 
			
		||||
  }
 | 
			
		||||
  --deriving Show
 | 
			
		||||
 | 
			
		||||
makeLenses ''BrickState
 | 
			
		||||
							
								
								
									
										204
									
								
								lib-tui/GHCup/Brick/Common.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										204
									
								
								lib-tui/GHCup/Brick/Common.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,204 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE TypeApplications  #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# LANGUAGE ViewPatterns      #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-missing-signatures #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
{-# LANGUAGE TemplateHaskell   #-}
 | 
			
		||||
{-# LANGUAGE BangPatterns #-}
 | 
			
		||||
{-# LANGUAGE InstanceSigs #-}
 | 
			
		||||
{-# LANGUAGE PatternSynonyms #-}
 | 
			
		||||
 | 
			
		||||
{-
 | 
			
		||||
This module contains common values used across the library. Crucially it contains two important types for the brick app:
 | 
			
		||||
 | 
			
		||||
- Name: List all resources (widgets) used by the app. see https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst#resource-names
 | 
			
		||||
- Mode: Use to dispatch events and drawings. see: https://github.com/jtdaugherty/brick/issues/476#issuecomment-1629151920
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Common  (
 | 
			
		||||
  installedSign,
 | 
			
		||||
  setSign,
 | 
			
		||||
  notInstalledSign,
 | 
			
		||||
  showKey,
 | 
			
		||||
  showMod,
 | 
			
		||||
  keyToWidget,
 | 
			
		||||
  separator,
 | 
			
		||||
  frontwardLayer,
 | 
			
		||||
  zoom,
 | 
			
		||||
  defaultAppSettings,
 | 
			
		||||
  lr,
 | 
			
		||||
  showAllVersions,
 | 
			
		||||
  Name(..),
 | 
			
		||||
  Mode(..),
 | 
			
		||||
  BrickData(..),
 | 
			
		||||
  BrickSettings(..),
 | 
			
		||||
  ResourceId (
 | 
			
		||||
      UrlEditBox, SetCheckBox, IsolateEditBox, ForceCheckBox, AdditionalEditBox
 | 
			
		||||
    , TargetGhcEditBox, BootstrapGhcEditBox, JobsEditBox, BuildConfigEditBox
 | 
			
		||||
    , PatchesEditBox, CrossTargetEditBox, AddConfArgsEditBox, OvewrwiteVerEditBox
 | 
			
		||||
    , BuildFlavourEditBox, BuildSystemEditBox, OkButton, AdvanceInstallButton
 | 
			
		||||
    , CompilieButton
 | 
			
		||||
  ) ) where
 | 
			
		||||
 | 
			
		||||
import           GHCup.List ( ListResult )
 | 
			
		||||
import           GHCup.Types ( Tool, KeyCombination (KeyCombination) )
 | 
			
		||||
import Data.List (intercalate)
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
import qualified Graphics.Vty                  as Vty
 | 
			
		||||
import           Optics.TH (makeLenses)
 | 
			
		||||
import           Optics.Lens (toLensVL)
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import qualified Brick.Widgets.Border as Border
 | 
			
		||||
import Brick ((<+>))
 | 
			
		||||
import qualified Data.Text as T
 | 
			
		||||
import qualified Brick.Widgets.Center as Brick
 | 
			
		||||
import qualified Brick.Widgets.Border.Style as Border
 | 
			
		||||
 | 
			
		||||
-- We could use regular ADTs but different menus share the same options.
 | 
			
		||||
-- example: all of ghcup compile ghc, ghcup compile hls, ghcup install cabal, etc...
 | 
			
		||||
-- all have a --set, --force, etc... common arguments. If we went for the ADT we'd end up
 | 
			
		||||
-- with SetCompileHLSOption, SetCompileGHCOption, SetInstallCabalOption, etc...
 | 
			
		||||
-- which isn't terrible, but verbose enough to reject it.
 | 
			
		||||
 | 
			
		||||
-- | A newtype for labeling resources in menus. It is bundled along with pattern synonyms
 | 
			
		||||
newtype ResourceId = ResourceId Int deriving (Eq, Ord, Show)
 | 
			
		||||
 | 
			
		||||
pattern OkButton :: ResourceId
 | 
			
		||||
pattern OkButton = ResourceId 0
 | 
			
		||||
pattern AdvanceInstallButton :: ResourceId
 | 
			
		||||
pattern AdvanceInstallButton = ResourceId 100
 | 
			
		||||
pattern CompilieButton :: ResourceId
 | 
			
		||||
pattern CompilieButton = ResourceId 101
 | 
			
		||||
 | 
			
		||||
pattern UrlEditBox :: ResourceId
 | 
			
		||||
pattern UrlEditBox = ResourceId 1
 | 
			
		||||
pattern SetCheckBox :: ResourceId
 | 
			
		||||
pattern SetCheckBox = ResourceId 2
 | 
			
		||||
pattern IsolateEditBox :: ResourceId
 | 
			
		||||
pattern IsolateEditBox = ResourceId 3
 | 
			
		||||
pattern ForceCheckBox :: ResourceId
 | 
			
		||||
pattern ForceCheckBox = ResourceId 4
 | 
			
		||||
pattern AdditionalEditBox :: ResourceId
 | 
			
		||||
pattern AdditionalEditBox = ResourceId 5
 | 
			
		||||
 | 
			
		||||
pattern TargetGhcEditBox :: ResourceId
 | 
			
		||||
pattern TargetGhcEditBox = ResourceId 6
 | 
			
		||||
pattern BootstrapGhcEditBox :: ResourceId
 | 
			
		||||
pattern BootstrapGhcEditBox = ResourceId 7
 | 
			
		||||
pattern JobsEditBox :: ResourceId
 | 
			
		||||
pattern JobsEditBox = ResourceId 8
 | 
			
		||||
pattern BuildConfigEditBox :: ResourceId
 | 
			
		||||
pattern BuildConfigEditBox = ResourceId 9
 | 
			
		||||
pattern PatchesEditBox :: ResourceId
 | 
			
		||||
pattern PatchesEditBox = ResourceId 10
 | 
			
		||||
pattern CrossTargetEditBox :: ResourceId
 | 
			
		||||
pattern CrossTargetEditBox = ResourceId 11
 | 
			
		||||
pattern AddConfArgsEditBox :: ResourceId
 | 
			
		||||
pattern AddConfArgsEditBox = ResourceId 12
 | 
			
		||||
pattern OvewrwiteVerEditBox :: ResourceId
 | 
			
		||||
pattern OvewrwiteVerEditBox = ResourceId 13
 | 
			
		||||
pattern BuildFlavourEditBox :: ResourceId
 | 
			
		||||
pattern BuildFlavourEditBox = ResourceId 14
 | 
			
		||||
pattern BuildSystemEditBox :: ResourceId
 | 
			
		||||
pattern BuildSystemEditBox = ResourceId 15
 | 
			
		||||
 | 
			
		||||
-- | Name data type. Uniquely identifies each widget in the TUI. 
 | 
			
		||||
-- some constructors might end up unused, but still is a good practise
 | 
			
		||||
-- to have all of them defined, just in case
 | 
			
		||||
data Name = AllTools                   -- ^ The main list widget
 | 
			
		||||
          | Singular Tool              -- ^ The particular list for each tool
 | 
			
		||||
          | KeyInfoBox                 -- ^ The text box widget with action informacion
 | 
			
		||||
          | TutorialBox                -- ^ The tutorial widget
 | 
			
		||||
          | ContextBox                 -- ^ The resource for Context Menu
 | 
			
		||||
          | CompileGHCBox              -- ^ The resource for CompileGHC Menu 
 | 
			
		||||
          | AdvanceInstallBox          -- ^ The resource for AdvanceInstall Menu 
 | 
			
		||||
          | MenuElement ResourceId     -- ^ Each element in a Menu. Resources must not be share for visible
 | 
			
		||||
                                       --   Menus, but MenuA and MenuB can share resources if they both are
 | 
			
		||||
                                       --   invisible, or just one of them is visible.
 | 
			
		||||
 | 
			
		||||
          deriving (Eq, Ord, Show)
 | 
			
		||||
 | 
			
		||||
-- | Mode type. It helps to dispatch events to different handlers.
 | 
			
		||||
data Mode = Navigation
 | 
			
		||||
          | KeyInfo
 | 
			
		||||
          | Tutorial
 | 
			
		||||
          | ContextPanel
 | 
			
		||||
          | AdvanceInstallPanel 
 | 
			
		||||
          | CompileGHCPanel
 | 
			
		||||
          deriving (Eq, Show, Ord)
 | 
			
		||||
 | 
			
		||||
installedSign :: String
 | 
			
		||||
#if IS_WINDOWS
 | 
			
		||||
installedSign = "I "
 | 
			
		||||
#else
 | 
			
		||||
installedSign = "✓ "
 | 
			
		||||
#endif
 | 
			
		||||
 | 
			
		||||
setSign :: String
 | 
			
		||||
#if IS_WINDOWS
 | 
			
		||||
setSign = "IS"
 | 
			
		||||
#else
 | 
			
		||||
setSign = "✔✔"
 | 
			
		||||
#endif
 | 
			
		||||
 | 
			
		||||
notInstalledSign :: String
 | 
			
		||||
#if IS_WINDOWS
 | 
			
		||||
notInstalledSign = "X "
 | 
			
		||||
#else
 | 
			
		||||
notInstalledSign = "✗ "
 | 
			
		||||
#endif
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
showKey :: Vty.Key -> String
 | 
			
		||||
showKey (Vty.KChar c) = [c]
 | 
			
		||||
showKey Vty.KUp = "↑"
 | 
			
		||||
showKey Vty.KDown = "↓"
 | 
			
		||||
showKey key = tail (show key)
 | 
			
		||||
 | 
			
		||||
showMod :: Vty.Modifier -> String
 | 
			
		||||
showMod = tail . show
 | 
			
		||||
 | 
			
		||||
-- | Given a KeyComb, produces a string widget with and user friendly text
 | 
			
		||||
keyToWidget :: KeyCombination -> Brick.Widget n
 | 
			
		||||
keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (showKey key : (showMod <$> mods))
 | 
			
		||||
 | 
			
		||||
-- | A section separator with max width. Looks like this:    -------- o --------
 | 
			
		||||
separator :: Brick.Widget n
 | 
			
		||||
separator = Border.hBorder <+> Brick.str " o " <+> Border.hBorder
 | 
			
		||||
 | 
			
		||||
-- | Used to create a layer on top of the main navigation widget (tutorial, info, menus...)
 | 
			
		||||
frontwardLayer :: T.Text -> Brick.Widget n -> Brick.Widget n
 | 
			
		||||
frontwardLayer layer_name =
 | 
			
		||||
    Brick.centerLayer
 | 
			
		||||
      . Brick.hLimitPercent 75
 | 
			
		||||
      . Brick.vLimitPercent 50
 | 
			
		||||
      . Brick.withBorderStyle Border.unicode
 | 
			
		||||
      . Border.borderWithLabel (Brick.txt layer_name)
 | 
			
		||||
 | 
			
		||||
-- I refuse to give this a type signature. 
 | 
			
		||||
 | 
			
		||||
-- | Given a lens, zoom on it. It is needed because Brick uses microlens but GHCup uses optics.
 | 
			
		||||
zoom l = Brick.zoom (toLensVL l)
 | 
			
		||||
 | 
			
		||||
data BrickData = BrickData
 | 
			
		||||
  { _lr    :: [ListResult]
 | 
			
		||||
  }
 | 
			
		||||
  deriving Show
 | 
			
		||||
 | 
			
		||||
makeLenses ''BrickData
 | 
			
		||||
 | 
			
		||||
data BrickSettings = BrickSettings { _showAllVersions :: Bool}
 | 
			
		||||
  --deriving Show
 | 
			
		||||
 | 
			
		||||
makeLenses ''BrickSettings
 | 
			
		||||
 | 
			
		||||
defaultAppSettings :: BrickSettings
 | 
			
		||||
defaultAppSettings = BrickSettings False
 | 
			
		||||
							
								
								
									
										72
									
								
								lib-tui/GHCup/Brick/Widgets/KeyInfo.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										72
									
								
								lib-tui/GHCup/Brick/Widgets/KeyInfo.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,72 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
 | 
			
		||||
{-
 | 
			
		||||
A very simple information-only widget with no handler. 
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Widgets.KeyInfo where
 | 
			
		||||
 | 
			
		||||
import           GHCup.Types ( KeyBindings(..) )
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
import Brick
 | 
			
		||||
    ( Padding(Max),
 | 
			
		||||
      Widget(..), 
 | 
			
		||||
      (<+>),
 | 
			
		||||
      (<=>))
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import           Brick.Widgets.Center ( center )
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
draw :: KeyBindings -> Widget Common.Name
 | 
			
		||||
draw KeyBindings {..} =
 | 
			
		||||
  let
 | 
			
		||||
    mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max)
 | 
			
		||||
  in Common.frontwardLayer "Key Actions"
 | 
			
		||||
      $ Brick.vBox [
 | 
			
		||||
        center $
 | 
			
		||||
         mkTextBox [
 | 
			
		||||
            Brick.hBox [
 | 
			
		||||
              Brick.txt "Press "
 | 
			
		||||
            , Common.keyToWidget bUp, Brick.txt " and ", Common.keyToWidget bDown
 | 
			
		||||
            , Brick.txtWrap " to navigate the list of tools"
 | 
			
		||||
            ]
 | 
			
		||||
          , Brick.hBox [
 | 
			
		||||
              Brick.txt "Press "
 | 
			
		||||
            , Common.keyToWidget bInstall
 | 
			
		||||
            , Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards"
 | 
			
		||||
            ]
 | 
			
		||||
          , Brick.hBox [
 | 
			
		||||
              Brick.txt "Press "
 | 
			
		||||
            , Common.keyToWidget bSet
 | 
			
		||||
            , Brick.txtWrap " to set a tool as the one for use"
 | 
			
		||||
            ]
 | 
			
		||||
          , Brick.hBox [
 | 
			
		||||
              Brick.txt "Press "
 | 
			
		||||
            , Common.keyToWidget bUninstall
 | 
			
		||||
            , Brick.txtWrap " to uninstall a tool"
 | 
			
		||||
            ]
 | 
			
		||||
          , Brick.hBox [
 | 
			
		||||
              Brick.txt "Press "
 | 
			
		||||
            , Common.keyToWidget bChangelog
 | 
			
		||||
            , Brick.txtWrap " to open the tool's changelog. It will open a web browser"
 | 
			
		||||
            ]
 | 
			
		||||
          , Brick.hBox [
 | 
			
		||||
              Brick.txt "Press "
 | 
			
		||||
            , Common.keyToWidget bShowAllVersions
 | 
			
		||||
            , Brick.txtWrap " to show older version of each tool"
 | 
			
		||||
            ]
 | 
			
		||||
          ]
 | 
			
		||||
        ]
 | 
			
		||||
      <=> Brick.hBox [Brick.txt "Press q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"]
 | 
			
		||||
							
								
								
									
										360
									
								
								lib-tui/GHCup/Brick/Widgets/Menu.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										360
									
								
								lib-tui/GHCup/Brick/Widgets/Menu.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,360 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE TypeApplications  #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# LANGUAGE ViewPatterns      #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
{-# LANGUAGE TemplateHaskell   #-}
 | 
			
		||||
{-# LANGUAGE BangPatterns #-}
 | 
			
		||||
{-# LANGUAGE InstanceSigs #-}
 | 
			
		||||
{-# LANGUAGE GADTs #-}
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
{- **************
 | 
			
		||||
 | 
			
		||||
A general system inspired by Brick.Form. It uses optics instead of microlenses and it is less generic than
 | 
			
		||||
Brick.Form, but generic enough to serve our purpose.
 | 
			
		||||
 | 
			
		||||
A Menu consists in
 | 
			
		||||
  a) A state value
 | 
			
		||||
  b) A list of fields. Each field is capable of modifying a part of the state
 | 
			
		||||
  c) some metadata
 | 
			
		||||
 | 
			
		||||
A field (type MenuField) consists in
 | 
			
		||||
  a) a Lens to a part of the Menu state, so the Menu can call that lens to modify its own state
 | 
			
		||||
  b) an input widget
 | 
			
		||||
 | 
			
		||||
An input (type FieldInput) consist in
 | 
			
		||||
  a) some state
 | 
			
		||||
  b) a validator function
 | 
			
		||||
  c) a handler and a renderer
 | 
			
		||||
 | 
			
		||||
We have to use existential types to achive a composable API since every FieldInput has a different 
 | 
			
		||||
internal type, and every MenuField has a different Lens. For example: 
 | 
			
		||||
  - The menu state is a record (MyRecord {uri: URI, flag : Bool}) 
 | 
			
		||||
  - Then, there are two MenuField:
 | 
			
		||||
    - One MenuField has (Lens' MyRecord URI) and the other has (Lens' MyRecord Bool)
 | 
			
		||||
    - The MenuFields has FieldInputs with internal state Text and Bool, respectively
 | 
			
		||||
  - Obviously, the MenuField has to be polimorphic in the Lens' and in the Input internal state,
 | 
			
		||||
    But we must hide that polimorphisim (existential), in order to store all MenuField in a List
 | 
			
		||||
 | 
			
		||||
************** -}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Widgets.Menu where
 | 
			
		||||
 | 
			
		||||
import qualified GHCup.Brick.Attributes as Attributes
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
 | 
			
		||||
import Brick
 | 
			
		||||
    ( BrickEvent(..),
 | 
			
		||||
      EventM,
 | 
			
		||||
      Widget(..),
 | 
			
		||||
      (<+>))
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import qualified Brick.Widgets.Border as Border
 | 
			
		||||
import qualified Brick.Widgets.List as L
 | 
			
		||||
import qualified Brick.Widgets.Edit as Edit
 | 
			
		||||
import           Brick.Focus (FocusRing)
 | 
			
		||||
import qualified Brick.Focus as F
 | 
			
		||||
import           Data.Function ( (&))
 | 
			
		||||
import           Prelude             hiding ( appendFile )
 | 
			
		||||
 | 
			
		||||
import qualified Data.Text                     as T
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
import           Optics.TH (makeLensesFor)
 | 
			
		||||
import qualified Graphics.Vty as Vty
 | 
			
		||||
import Optics.State.Operators ((%=), (.=))
 | 
			
		||||
import Optics.Optic ((%))
 | 
			
		||||
import Optics.State (use)
 | 
			
		||||
import GHCup.Types (KeyCombination)
 | 
			
		||||
import Optics (Lens', to, lens)
 | 
			
		||||
import Optics.Operators ( (^.), (.~) )
 | 
			
		||||
import Data.Foldable (foldl')
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | Just some type synonym to make things explicit
 | 
			
		||||
type Formatter n = Bool -> Widget n -> Widget n
 | 
			
		||||
-- | A label
 | 
			
		||||
type Label = T.Text
 | 
			
		||||
-- | A help message of an entry
 | 
			
		||||
type HelpMessage = T.Text
 | 
			
		||||
-- | A button name
 | 
			
		||||
type ButtonName n = n
 | 
			
		||||
 | 
			
		||||
idFormatter :: Formatter n
 | 
			
		||||
idFormatter = const id
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | An error message
 | 
			
		||||
type ErrorMessage = T.Text
 | 
			
		||||
data ErrorStatus = Valid | Invalid ErrorMessage
 | 
			
		||||
 | 
			
		||||
-- | A lens which does nothing. Usefull to defined no-op fields
 | 
			
		||||
emptyLens :: Lens' s ()
 | 
			
		||||
emptyLens = lens (const ()) (\s _ -> s)
 | 
			
		||||
 | 
			
		||||
-- | A FieldInput is a pair label-content
 | 
			
		||||
--   a - is the type of the field it manipulates
 | 
			
		||||
--   b - is its internal state (modified in the gui)
 | 
			
		||||
--   n - your application's resource name type
 | 
			
		||||
data FieldInput a b n =
 | 
			
		||||
  FieldInput
 | 
			
		||||
    { inputState :: b                                     -- ^ The state of the input field (what's rendered in the screen)
 | 
			
		||||
    , inputValidator :: b -> Either ErrorMessage a        -- ^ A validator function
 | 
			
		||||
    , inputHelp   :: HelpMessage                          -- ^ The input helpMessage
 | 
			
		||||
    , inputRender :: Bool
 | 
			
		||||
                  -> ErrorStatus
 | 
			
		||||
                  -> HelpMessage
 | 
			
		||||
                  -> b
 | 
			
		||||
                  -> (Widget n -> Widget n)
 | 
			
		||||
                  -> Widget n                             -- ^ How to draw the input, with focus a help message and input. 
 | 
			
		||||
                                                          --   A extension function can be applied too
 | 
			
		||||
    , inputHandler :: BrickEvent n () -> EventM n b ()    -- ^ The handler
 | 
			
		||||
    }
 | 
			
		||||
 | 
			
		||||
makeLensesFor
 | 
			
		||||
  [ ("inputState", "inputStateL")
 | 
			
		||||
  , ("inputValidator", "inputValidatorL")
 | 
			
		||||
  , ("inputName", "inputNameL")
 | 
			
		||||
  , ("inputHelp", "inputHelpL")
 | 
			
		||||
  ]
 | 
			
		||||
  ''FieldInput
 | 
			
		||||
 | 
			
		||||
-- | The MenuField is an existential type which stores a Lens' to a part of the Menu state.
 | 
			
		||||
--   In also contains a Field input which internal state is hidden
 | 
			
		||||
data MenuField s n where
 | 
			
		||||
  MenuField ::
 | 
			
		||||
      { fieldAccesor   :: Lens' s a                   -- ^ A Lens pointing to some part of the state
 | 
			
		||||
      , fieldInput     :: FieldInput a b n            -- ^ The input which modifies the state
 | 
			
		||||
      , fieldLabel     :: Label                       -- ^ The label
 | 
			
		||||
      , fieldStatus    :: ErrorStatus                 -- ^ Whether the current is valid or not.
 | 
			
		||||
      , fieldName      :: n
 | 
			
		||||
      } -> MenuField s n
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
makeLensesFor
 | 
			
		||||
  [ ("fieldLabel", "fieldLabelL")
 | 
			
		||||
  , ("fieldStatus", "fieldStatusL")
 | 
			
		||||
  ]
 | 
			
		||||
  ''MenuField
 | 
			
		||||
 | 
			
		||||
-- | A fancy lens to the help message
 | 
			
		||||
fieldHelpMsgL :: Lens' (MenuField s n) HelpMessage
 | 
			
		||||
fieldHelpMsgL = lens g s
 | 
			
		||||
  where g (MenuField {..})= fieldInput ^. inputHelpL
 | 
			
		||||
        s (MenuField{..}) msg = MenuField {fieldInput = fieldInput & inputHelpL .~ msg , ..}
 | 
			
		||||
 | 
			
		||||
-- | How to draw a field given a formater
 | 
			
		||||
drawField :: Formatter n -> Bool -> MenuField s n -> Widget n
 | 
			
		||||
drawField amp focus (MenuField { fieldInput = FieldInput {..}, ..}) =
 | 
			
		||||
  let input = inputRender focus fieldStatus inputHelp inputState (amp focus)
 | 
			
		||||
    in if focus
 | 
			
		||||
        then Brick.visible input
 | 
			
		||||
        else input
 | 
			
		||||
 | 
			
		||||
instance Brick.Named (MenuField s n) n where
 | 
			
		||||
  getName :: MenuField s n -> n
 | 
			
		||||
  getName entry = entry & fieldName
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
{- *****************
 | 
			
		||||
  CheckBox widget
 | 
			
		||||
***************** -}
 | 
			
		||||
 | 
			
		||||
type CheckBoxField = MenuField
 | 
			
		||||
 | 
			
		||||
createCheckBoxInput :: FieldInput Bool Bool n
 | 
			
		||||
createCheckBoxInput = FieldInput False Right "" checkBoxRender checkBoxHandler
 | 
			
		||||
  where
 | 
			
		||||
    border = Border.border . Brick.padRight (Brick.Pad 1) . Brick.padLeft (Brick.Pad 2)
 | 
			
		||||
    drawBool b =
 | 
			
		||||
        if b
 | 
			
		||||
          then border . Brick.withAttr Attributes.installedAttr    $ Brick.str Common.installedSign
 | 
			
		||||
          else border . Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign
 | 
			
		||||
    checkBoxRender focus _ help check f =
 | 
			
		||||
      let core = f $ drawBool check
 | 
			
		||||
      in if focus 
 | 
			
		||||
        then core
 | 
			
		||||
        else core <+> (Brick.padLeft (Brick.Pad 1) . centerV . renderAsHelpMsg $ help)
 | 
			
		||||
    checkBoxHandler = \case
 | 
			
		||||
        VtyEvent (Vty.EvKey Vty.KEnter []) -> Brick.modify not
 | 
			
		||||
        _ -> pure ()
 | 
			
		||||
 | 
			
		||||
createCheckBoxField :: n -> Lens' s Bool -> CheckBoxField s n
 | 
			
		||||
createCheckBoxField name access = MenuField access createCheckBoxInput "" Valid name
 | 
			
		||||
 | 
			
		||||
{- *****************
 | 
			
		||||
  Editable widget
 | 
			
		||||
***************** -}
 | 
			
		||||
 | 
			
		||||
type EditableField = MenuField
 | 
			
		||||
 | 
			
		||||
createEditableInput :: (Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> FieldInput a (Edit.Editor T.Text n) n
 | 
			
		||||
createEditableInput name validator = FieldInput initEdit validateEditContent "" drawEdit Edit.handleEditorEvent
 | 
			
		||||
  where
 | 
			
		||||
    drawEdit focus errMsg help edi amp =
 | 
			
		||||
      let 
 | 
			
		||||
        borderBox = amp . Border.border . Brick.padRight Brick.Max
 | 
			
		||||
        editorRender = Edit.renderEditor (Brick.txt . T.unlines) focus edi
 | 
			
		||||
        isEditorEmpty = Edit.getEditContents edi == [mempty]
 | 
			
		||||
      in case errMsg of
 | 
			
		||||
           Valid | isEditorEmpty -> borderBox $ renderAsHelpMsg help
 | 
			
		||||
                 | otherwise -> borderBox editorRender
 | 
			
		||||
           Invalid msg 
 | 
			
		||||
             | focus && isEditorEmpty -> borderBox $ renderAsHelpMsg help
 | 
			
		||||
             | focus     -> borderBox editorRender
 | 
			
		||||
             | otherwise -> borderBox $ renderAsErrMsg msg
 | 
			
		||||
    validateEditContent = validator . T.unlines . Edit.getEditContents
 | 
			
		||||
    initEdit = Edit.editorText name (Just 1) ""
 | 
			
		||||
 | 
			
		||||
createEditableField :: (Eq n, Ord n, Show n) => n -> (T.Text -> Either ErrorMessage a) -> Lens' s a  -> EditableField s n
 | 
			
		||||
createEditableField name validator access = MenuField access input "" Valid name
 | 
			
		||||
  where
 | 
			
		||||
    input = createEditableInput name validator
 | 
			
		||||
 | 
			
		||||
{- *****************
 | 
			
		||||
  Button widget
 | 
			
		||||
***************** -}
 | 
			
		||||
 | 
			
		||||
type Button = MenuField
 | 
			
		||||
 | 
			
		||||
createButtonInput :: FieldInput () () n
 | 
			
		||||
createButtonInput = FieldInput () Right "" drawButton (const $ pure ())
 | 
			
		||||
  where drawButton _ _ help _ amp = amp . centerV . renderAsHelpMsg $ help
 | 
			
		||||
 | 
			
		||||
createButtonField :: n -> Button s n
 | 
			
		||||
createButtonField = MenuField emptyLens createButtonInput "" Valid
 | 
			
		||||
 | 
			
		||||
{- *****************
 | 
			
		||||
  Utilities
 | 
			
		||||
***************** -}
 | 
			
		||||
 | 
			
		||||
-- | highlights a widget (using List.listSelectedFocusedAttr)
 | 
			
		||||
highlighted :: Widget n -> Widget n
 | 
			
		||||
highlighted = Brick.withAttr L.listSelectedFocusedAttr
 | 
			
		||||
 | 
			
		||||
-- | Given a text, crates a highlighted label on focus. An amplifier can be passed
 | 
			
		||||
renderAslabel :: T.Text -> Bool -> Widget n
 | 
			
		||||
renderAslabel t focus =
 | 
			
		||||
  if focus
 | 
			
		||||
    then highlighted $ Brick.txt t
 | 
			
		||||
    else Brick.txt t
 | 
			
		||||
 | 
			
		||||
-- | Creates a left align column. 
 | 
			
		||||
-- Example:       |- col2 is align dispite the length of col1
 | 
			
		||||
--   row1_col1         row1_col2
 | 
			
		||||
--   row2_col1_large   row2_col2
 | 
			
		||||
leftify :: Int -> Brick.Widget n -> Brick.Widget n
 | 
			
		||||
leftify i = Brick.hLimit i . Brick.padRight Brick.Max
 | 
			
		||||
 | 
			
		||||
-- | center a line in three rows. 
 | 
			
		||||
centerV :: Widget n -> Widget n
 | 
			
		||||
centerV = Brick.padTopBottom 1
 | 
			
		||||
 | 
			
		||||
-- | render some Text using helpMsgAttr
 | 
			
		||||
renderAsHelpMsg :: T.Text -> Widget n
 | 
			
		||||
renderAsHelpMsg = Brick.withAttr Attributes.helpMsgAttr . Brick.txt
 | 
			
		||||
 | 
			
		||||
-- | render some Text using errMsgAttr
 | 
			
		||||
renderAsErrMsg :: T.Text -> Widget n
 | 
			
		||||
renderAsErrMsg = Brick.withAttr Attributes.errMsgAttr . Brick.txt
 | 
			
		||||
 | 
			
		||||
{- *****************
 | 
			
		||||
  Menu widget
 | 
			
		||||
***************** -}
 | 
			
		||||
 | 
			
		||||
-- | A menu is a list of Fields and a state. Informally we can think about s in terms of the record type returned by 
 | 
			
		||||
-- a form. 
 | 
			
		||||
data Menu s n
 | 
			
		||||
    = Menu
 | 
			
		||||
    { menuFields    :: [MenuField s n]   -- ^ The datatype representing the list of entries. Precisely, any array-like data type is highly unconvinient.
 | 
			
		||||
    , menuState     :: s
 | 
			
		||||
    , menuButtons   :: [Button s n]      -- ^ The buttons. Commonly, the handlers for buttons are defined outside the menu handler.
 | 
			
		||||
    , menuFocusRing :: FocusRing n       -- ^ The focus ring with the resource name for each entry and each button, in the order you want to loop them.
 | 
			
		||||
    , menuExitKey   :: KeyCombination    -- ^ The key to exit the Menu
 | 
			
		||||
    , menuName      :: n                 -- ^ The resource Name.
 | 
			
		||||
    }
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
makeLensesFor
 | 
			
		||||
  [ ("menuFields", "menuFieldsL"), ("menuState", "menuStateL")
 | 
			
		||||
  , ("menuButtons", "menuButtonsL"), ("menuFocusRing", "menuFocusRingL")
 | 
			
		||||
  , ("menuExitKey", "menuExitKeyL"), ("menuName", "menuNameL")
 | 
			
		||||
  ]
 | 
			
		||||
  ''Menu
 | 
			
		||||
 | 
			
		||||
createMenu :: n -> s -> KeyCombination -> [Button s n] -> [MenuField s n] -> Menu s n
 | 
			
		||||
createMenu n initial exitK buttons fields = Menu fields initial buttons ring exitK n
 | 
			
		||||
  where ring = F.focusRing $ [field & fieldName | field <- fields] ++ [button & fieldName | button <- buttons]
 | 
			
		||||
 | 
			
		||||
handlerMenu :: forall n e s. Eq n => BrickEvent n e -> EventM n (Menu s n) ()
 | 
			
		||||
handlerMenu ev =
 | 
			
		||||
  case ev of
 | 
			
		||||
    VtyEvent (Vty.EvKey (Vty.KChar '\t') [])  -> menuFocusRingL %= F.focusNext
 | 
			
		||||
    VtyEvent (Vty.EvKey Vty.KBackTab [])      -> menuFocusRingL %= F.focusPrev
 | 
			
		||||
    VtyEvent (Vty.EvKey Vty.KDown [])         -> menuFocusRingL %= F.focusNext
 | 
			
		||||
    VtyEvent (Vty.EvKey Vty.KUp [])           -> menuFocusRingL %= F.focusPrev
 | 
			
		||||
    VtyEvent e -> do
 | 
			
		||||
      focused <- use $ menuFocusRingL % to F.focusGetCurrent
 | 
			
		||||
      fields  <- use menuFieldsL
 | 
			
		||||
      case focused of
 | 
			
		||||
        Nothing -> pure ()
 | 
			
		||||
        Just n  -> do 
 | 
			
		||||
          updated_fields <- updateFields n (VtyEvent e) fields
 | 
			
		||||
          menuFieldsL .= updated_fields
 | 
			
		||||
    _ -> pure ()
 | 
			
		||||
 where
 | 
			
		||||
  updateFields :: n -> BrickEvent n () -> [MenuField s n] -> EventM n (Menu s n) [MenuField s n]
 | 
			
		||||
  updateFields n e [] = pure []
 | 
			
		||||
  updateFields n e (x@(MenuField {fieldInput = i@(FieldInput {..}) , ..}):xs) =
 | 
			
		||||
    if Brick.getName x == n
 | 
			
		||||
      then do
 | 
			
		||||
       newb <- Brick.nestEventM' inputState (inputHandler e)
 | 
			
		||||
       let newField = MenuField {fieldInput = (FieldInput {inputState=newb, ..}) , ..}
 | 
			
		||||
       case inputValidator newb of
 | 
			
		||||
        Left errmsg -> pure $ (newField & fieldStatusL .~ Invalid errmsg):xs
 | 
			
		||||
        Right a     -> menuStateL % fieldAccesor .= a >> pure ((newField & fieldStatusL .~ Valid):xs)
 | 
			
		||||
      else fmap (x:) (updateFields n e xs)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
drawMenu :: (Eq n, Ord n, Show n, Brick.Named (MenuField s n) n) => Menu s n -> Widget n
 | 
			
		||||
drawMenu menu = 
 | 
			
		||||
  Brick.vBox
 | 
			
		||||
      [ Brick.vBox buttonWidgets
 | 
			
		||||
      , Common.separator
 | 
			
		||||
      , Brick.withVScrollBars Brick.OnRight
 | 
			
		||||
          $ Brick.viewport (menu ^. menuNameL) Brick.Vertical
 | 
			
		||||
          $ Brick.vBox fieldWidgets
 | 
			
		||||
      , Brick.txt " "
 | 
			
		||||
      , Brick.padRight Brick.Max $ 
 | 
			
		||||
          Brick.txt "Press " 
 | 
			
		||||
          <+> Common.keyToWidget (menu ^. menuExitKeyL)
 | 
			
		||||
          <+> Brick.txt " to go back"
 | 
			
		||||
      ]
 | 
			
		||||
  where
 | 
			
		||||
    fieldLabels  = [field & fieldLabel | field <- menu ^. menuFieldsL]
 | 
			
		||||
    buttonLabels = [button & fieldLabel | button <- menu ^. menuButtonsL]
 | 
			
		||||
    allLabels    = fieldLabels ++ buttonLabels
 | 
			
		||||
 | 
			
		||||
    maxWidth = foldl' max 5 (fmap Brick.textWidth allLabels)
 | 
			
		||||
 | 
			
		||||
    -- A list of functions which draw a highlighted label with right padding at the left of a widget. 
 | 
			
		||||
    amplifiers =
 | 
			
		||||
      let labelsWidgets = fmap renderAslabel fieldLabels
 | 
			
		||||
       in fmap (\f b -> ((centerV . leftify (maxWidth + 10) $ f b) <+>) ) labelsWidgets
 | 
			
		||||
    drawFields = fmap drawField amplifiers
 | 
			
		||||
    fieldWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawFields (menu ^. menuFieldsL)
 | 
			
		||||
 | 
			
		||||
    buttonAmplifiers =
 | 
			
		||||
      let buttonAsWidgets = fmap renderAslabel buttonLabels
 | 
			
		||||
       in fmap (\f b -> ((leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets
 | 
			
		||||
    drawButtons = fmap drawField buttonAmplifiers
 | 
			
		||||
    buttonWidgets = zipWith (F.withFocusRing (menu ^. menuFocusRingL)) drawButtons (menu ^. menuButtonsL)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
							
								
								
									
										118
									
								
								lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										118
									
								
								lib-tui/GHCup/Brick/Widgets/Menus/AdvanceInstall.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,118 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE TypeApplications  #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# LANGUAGE ViewPatterns      #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
{-# LANGUAGE TemplateHaskell   #-}
 | 
			
		||||
{-# LANGUAGE BangPatterns #-}
 | 
			
		||||
{-# LANGUAGE InstanceSigs #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Widgets.Menus.AdvanceInstall (
 | 
			
		||||
  InstallOptions (..),
 | 
			
		||||
  AdvanceInstallMenu,
 | 
			
		||||
  create,
 | 
			
		||||
  handler,
 | 
			
		||||
  draw,
 | 
			
		||||
  instBindistL,
 | 
			
		||||
  instSetL,
 | 
			
		||||
  isolateDirL,
 | 
			
		||||
  forceInstallL,
 | 
			
		||||
  addConfArgsL,
 | 
			
		||||
) where
 | 
			
		||||
 | 
			
		||||
import GHCup.Brick.Widgets.Menu (Menu)
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menu as Menu
 | 
			
		||||
import           GHCup.Brick.Common(Name(..))
 | 
			
		||||
import Brick
 | 
			
		||||
    ( BrickEvent(..),
 | 
			
		||||
      EventM,
 | 
			
		||||
      Widget(..))
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
import           Optics.TH (makeLensesFor)
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import GHCup.Types (KeyCombination)
 | 
			
		||||
import URI.ByteString (URI)
 | 
			
		||||
import qualified Data.Text as T
 | 
			
		||||
import qualified Data.ByteString.UTF8 as UTF8
 | 
			
		||||
import GHCup.Utils (parseURI)
 | 
			
		||||
import Data.Bifunctor (Bifunctor(..))
 | 
			
		||||
import Data.Function ((&))
 | 
			
		||||
import Optics ((.~))
 | 
			
		||||
import Data.Char (isSpace)
 | 
			
		||||
 | 
			
		||||
data InstallOptions = InstallOptions
 | 
			
		||||
  { instBindist  :: Maybe URI
 | 
			
		||||
  , instSet      :: Bool
 | 
			
		||||
  , isolateDir   :: Maybe FilePath
 | 
			
		||||
  , forceInstall :: Bool
 | 
			
		||||
  , addConfArgs  :: [T.Text]
 | 
			
		||||
  } deriving (Eq, Show)
 | 
			
		||||
 | 
			
		||||
makeLensesFor [
 | 
			
		||||
   ("instBindist", "instBindistL")
 | 
			
		||||
  , ("instSet", "instSetL")
 | 
			
		||||
  , ("isolateDir", "isolateDirL")
 | 
			
		||||
  , ("forceInstall", "forceInstallL")
 | 
			
		||||
  , ("addConfArgs", "addConfArgsL")
 | 
			
		||||
  ]
 | 
			
		||||
  ''InstallOptions
 | 
			
		||||
 | 
			
		||||
type AdvanceInstallMenu = Menu InstallOptions Name
 | 
			
		||||
 | 
			
		||||
create :: KeyCombination -> AdvanceInstallMenu
 | 
			
		||||
create k = Menu.createMenu AdvanceInstallBox initialState k [ok] fields
 | 
			
		||||
  where
 | 
			
		||||
    initialState = InstallOptions Nothing False Nothing False []
 | 
			
		||||
    -- Brick's internal editor representation is [mempty].
 | 
			
		||||
    emptyEditor i = T.null i || (i == "\n")
 | 
			
		||||
    
 | 
			
		||||
    uriValidator :: T.Text -> Either Menu.ErrorMessage (Maybe URI)
 | 
			
		||||
    uriValidator i = 
 | 
			
		||||
      case not $ emptyEditor i of
 | 
			
		||||
        True  -> bimap (T.pack . show) Just . parseURI . UTF8.fromString . T.unpack $ i
 | 
			
		||||
        False -> Right Nothing
 | 
			
		||||
 | 
			
		||||
    filepathValidator :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
 | 
			
		||||
    filepathValidator i = 
 | 
			
		||||
      case not $ emptyEditor i of
 | 
			
		||||
        True  -> Right . Just . T.unpack $ i
 | 
			
		||||
        False -> Right Nothing
 | 
			
		||||
 | 
			
		||||
    additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
 | 
			
		||||
    additionalValidator = Right . T.split isSpace
 | 
			
		||||
 | 
			
		||||
    fields = 
 | 
			
		||||
      [ Menu.createEditableField (Common.MenuElement Common.UrlEditBox) uriValidator instBindistL
 | 
			
		||||
          & Menu.fieldLabelL .~ "url"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Install the specified version from this bindist"
 | 
			
		||||
      , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) instSetL
 | 
			
		||||
          & Menu.fieldLabelL .~ "set"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Set as active version after install"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathValidator isolateDirL
 | 
			
		||||
          & Menu.fieldLabelL .~ "isolated"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one"
 | 
			
		||||
      , Menu.createCheckBoxField (Common.MenuElement Common.ForceCheckBox) forceInstallL
 | 
			
		||||
          & Menu.fieldLabelL .~ "force"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Force install (THIS IS UNSAFE, only use it in Dockerfiles or CI)"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgsL
 | 
			
		||||
          & Menu.fieldLabelL .~ "CONFIGURE_ARGS"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure, prefix with '-- ' (longopts)"
 | 
			
		||||
      ]
 | 
			
		||||
    
 | 
			
		||||
    ok = Menu.createButtonField (Common.MenuElement Common.OkButton)
 | 
			
		||||
          & Menu.fieldLabelL .~ "Advance Install"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Install with options below"
 | 
			
		||||
 | 
			
		||||
handler :: BrickEvent Name e -> EventM Name AdvanceInstallMenu ()
 | 
			
		||||
handler = Menu.handlerMenu
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
draw :: AdvanceInstallMenu -> Widget Name
 | 
			
		||||
draw = Common.frontwardLayer "Advance Install" . Menu.drawMenu
 | 
			
		||||
							
								
								
									
										177
									
								
								lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										177
									
								
								lib-tui/GHCup/Brick/Widgets/Menus/CompileGHC.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,177 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE TypeApplications  #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# LANGUAGE ViewPatterns      #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
{-# LANGUAGE TemplateHaskell   #-}
 | 
			
		||||
{-# LANGUAGE BangPatterns #-}
 | 
			
		||||
{-# LANGUAGE InstanceSigs #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-incomplete-patterns #-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Widgets.Menus.CompileGHC (CompileGHCOptions, CompileGHCMenu, create, handler, draw) where
 | 
			
		||||
 | 
			
		||||
import GHCup.Brick.Widgets.Menu (Menu)
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menu as Menu
 | 
			
		||||
import           GHCup.Brick.Common(Name(..))
 | 
			
		||||
import Brick
 | 
			
		||||
    ( BrickEvent(..),
 | 
			
		||||
      EventM,
 | 
			
		||||
      Widget(..))
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
import           Optics.TH (makeLenses)
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import GHCup.Types (KeyCombination, BuildSystem (Hadrian))
 | 
			
		||||
import URI.ByteString (URI)
 | 
			
		||||
import qualified Data.Text as T
 | 
			
		||||
import qualified Data.ByteString.UTF8 as UTF8
 | 
			
		||||
import GHCup.Utils (parseURI)
 | 
			
		||||
import Data.Bifunctor (Bifunctor(..))
 | 
			
		||||
import Data.Function ((&))
 | 
			
		||||
import Optics ((.~))
 | 
			
		||||
import Data.Char (isSpace)
 | 
			
		||||
import Data.Versions (Version, version)
 | 
			
		||||
import System.FilePath (isPathSeparator)
 | 
			
		||||
import Control.Applicative (Alternative((<|>)))
 | 
			
		||||
import Text.Read (readEither)
 | 
			
		||||
 | 
			
		||||
data CompileGHCOptions = CompileGHCOptions
 | 
			
		||||
  { _bootstrapGhc :: Either Version FilePath
 | 
			
		||||
  , _jobs         :: Maybe Int
 | 
			
		||||
  , _buildConfig  :: Maybe FilePath
 | 
			
		||||
  , _patches      :: Maybe (Either FilePath [URI])
 | 
			
		||||
  , _crossTarget  :: Maybe T.Text
 | 
			
		||||
  , _addConfArgs  :: [T.Text]
 | 
			
		||||
  , _setCompile   :: Bool
 | 
			
		||||
  , _ovewrwiteVer :: Maybe Version
 | 
			
		||||
  , _buildFlavour :: Maybe String
 | 
			
		||||
  , _buildSystem  :: Maybe BuildSystem
 | 
			
		||||
  , _isolateDir   :: Maybe FilePath
 | 
			
		||||
  } deriving (Eq, Show)
 | 
			
		||||
 | 
			
		||||
makeLenses ''CompileGHCOptions
 | 
			
		||||
 | 
			
		||||
type CompileGHCMenu = Menu CompileGHCOptions Name
 | 
			
		||||
 | 
			
		||||
create :: KeyCombination -> CompileGHCMenu
 | 
			
		||||
create k = Menu.createMenu CompileGHCBox initialState k buttons fields
 | 
			
		||||
  where
 | 
			
		||||
    initialState = 
 | 
			
		||||
      CompileGHCOptions 
 | 
			
		||||
        (Right "")
 | 
			
		||||
        Nothing
 | 
			
		||||
        Nothing
 | 
			
		||||
        Nothing
 | 
			
		||||
        Nothing
 | 
			
		||||
        []
 | 
			
		||||
        False
 | 
			
		||||
        Nothing
 | 
			
		||||
        Nothing
 | 
			
		||||
        Nothing
 | 
			
		||||
        Nothing
 | 
			
		||||
    -- Brick's internal editor representation is [mempty].
 | 
			
		||||
    emptyEditor i = T.null i || (i == "\n")
 | 
			
		||||
    whenEmpty :: a -> (T.Text -> Either Menu.ErrorMessage a) -> T.Text -> Either Menu.ErrorMessage a
 | 
			
		||||
    whenEmpty emptyval f i = if not (emptyEditor i) then f i else Right emptyval
 | 
			
		||||
 | 
			
		||||
    bootstrapV :: T.Text -> Either Menu.ErrorMessage (Either Version FilePath)
 | 
			
		||||
    bootstrapV i =
 | 
			
		||||
      case not $ emptyEditor i of
 | 
			
		||||
        True  -> 
 | 
			
		||||
          let readVersion = bimap (const "Not a valid version") Left (version (T.init i)) -- Brick adds \n at the end, hence T.init
 | 
			
		||||
              readPath
 | 
			
		||||
                 = if isPathSeparator (T.head i) 
 | 
			
		||||
                    then pure $ Right (T.unpack i)
 | 
			
		||||
                    else Left "Not an absolute Path"
 | 
			
		||||
           in if T.any isPathSeparator i 
 | 
			
		||||
                then readPath
 | 
			
		||||
                else readVersion
 | 
			
		||||
        False -> Left "Invalid Empty value"
 | 
			
		||||
 | 
			
		||||
    versionV :: T.Text -> Either Menu.ErrorMessage (Maybe Version)
 | 
			
		||||
    versionV = bimap (const "Not a valid version") Just . version . T.init  -- Brick adds \n at the end, hence T.init
 | 
			
		||||
 | 
			
		||||
    jobsV :: T.Text -> Either Menu.ErrorMessage (Maybe Int)
 | 
			
		||||
    jobsV = 
 | 
			
		||||
      let parseInt = bimap (const "Invalid value. Must be an integer") Just . readEither @Int . T.unpack
 | 
			
		||||
       in whenEmpty Nothing parseInt 
 | 
			
		||||
 | 
			
		||||
    patchesV :: T.Text -> Either Menu.ErrorMessage (Maybe (Either FilePath [URI]))
 | 
			
		||||
    patchesV = whenEmpty Nothing readPatches
 | 
			
		||||
      where 
 | 
			
		||||
        readUri :: T.Text -> Either String URI
 | 
			
		||||
        readUri = first show . parseURI . UTF8.fromString . T.unpack 
 | 
			
		||||
        readPatches j = 
 | 
			
		||||
          let 
 | 
			
		||||
            x = (bimap T.unpack (fmap Left) $ filepathV j)
 | 
			
		||||
            y = second (Just . Right) $ traverse readUri (T.split isSpace j)
 | 
			
		||||
          in first T.pack $ x <|> y
 | 
			
		||||
 | 
			
		||||
    filepathV :: T.Text -> Either Menu.ErrorMessage (Maybe FilePath)
 | 
			
		||||
    filepathV = whenEmpty Nothing (Right . Just . T.unpack)
 | 
			
		||||
 | 
			
		||||
    additionalValidator :: T.Text -> Either Menu.ErrorMessage [T.Text]
 | 
			
		||||
    additionalValidator = Right . T.split isSpace
 | 
			
		||||
 | 
			
		||||
    systemV :: T.Text -> Either Menu.ErrorMessage (Maybe BuildSystem)
 | 
			
		||||
    systemV = whenEmpty Nothing readSys
 | 
			
		||||
      where 
 | 
			
		||||
        readSys i
 | 
			
		||||
          | T.toLower i == "hadrian" = Right $ Just Hadrian
 | 
			
		||||
          | T.toLower i == "make"    = Right $ Just Hadrian
 | 
			
		||||
          | otherwise = Left "Not a valid Build System"
 | 
			
		||||
 | 
			
		||||
    fields = 
 | 
			
		||||
      [ Menu.createEditableField (Common.MenuElement Common.BootstrapGhcEditBox) bootstrapV bootstrapGhc
 | 
			
		||||
           & Menu.fieldLabelL .~ "bootstrap-ghc"
 | 
			
		||||
           & Menu.fieldHelpMsgL .~ "The GHC version (or full path) to bootstrap with (must be installed)"
 | 
			
		||||
           & Menu.fieldStatusL .~ Menu.Invalid "Invalid Empty value"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.JobsEditBox) jobsV jobs
 | 
			
		||||
          & Menu.fieldLabelL .~ "jobs"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "How many jobs to use for make"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.BuildConfigEditBox) filepathV buildConfig
 | 
			
		||||
          & Menu.fieldLabelL .~ "build config"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Absolute path to build config file"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.PatchesEditBox) patchesV patches
 | 
			
		||||
          & Menu.fieldLabelL .~ "patches"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Either a URI to a patch (https/http/file) or Absolute path to patch directory"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.CrossTargetEditBox) (Right . Just) crossTarget
 | 
			
		||||
          & Menu.fieldLabelL .~ "cross target"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Build cross-compiler for this platform"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.AdditionalEditBox) additionalValidator addConfArgs
 | 
			
		||||
          & Menu.fieldLabelL .~ "CONFIGURE_ARGS"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Additional arguments to bindist configure, prefix with '-- ' (longopts)"
 | 
			
		||||
      , Menu.createCheckBoxField (Common.MenuElement Common.SetCheckBox) setCompile
 | 
			
		||||
          & Menu.fieldLabelL .~ "set"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Set as active version after install"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.OvewrwiteVerEditBox) versionV ovewrwiteVer
 | 
			
		||||
          & Menu.fieldLabelL .~ "overwrite-version"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Allows to overwrite the finally installed VERSION with a different one"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.BuildFlavourEditBox) (Right . Just . T.unpack) buildFlavour
 | 
			
		||||
          & Menu.fieldLabelL .~ "flavour"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.BuildSystemEditBox) systemV buildSystem
 | 
			
		||||
          & Menu.fieldLabelL .~ "build system"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "Set the compile build flavour (this value depends on the build system type: 'make' vs 'hadrian')"
 | 
			
		||||
      , Menu.createEditableField (Common.MenuElement Common.IsolateEditBox) filepathV isolateDir
 | 
			
		||||
          & Menu.fieldLabelL .~ "isolated"
 | 
			
		||||
          & Menu.fieldHelpMsgL .~ "install in an isolated absolute directory instead of the default one"
 | 
			
		||||
      ]
 | 
			
		||||
 | 
			
		||||
    buttons = [
 | 
			
		||||
       Menu.createButtonField (Common.MenuElement Common.OkButton)
 | 
			
		||||
           & Menu.fieldLabelL .~ "Compile"
 | 
			
		||||
           & Menu.fieldHelpMsgL .~ "Compile GHC from source with options below"
 | 
			
		||||
      ]
 | 
			
		||||
 | 
			
		||||
handler :: BrickEvent Name e -> EventM Name CompileGHCMenu ()
 | 
			
		||||
handler = Menu.handlerMenu
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
draw :: CompileGHCMenu -> Widget Name
 | 
			
		||||
draw = Common.frontwardLayer "Compile GHC" . Menu.drawMenu
 | 
			
		||||
							
								
								
									
										78
									
								
								lib-tui/GHCup/Brick/Widgets/Menus/Context.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										78
									
								
								lib-tui/GHCup/Brick/Widgets/Menus/Context.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,78 @@
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Widgets.Menus.Context (ContextMenu, create, draw, handler) where
 | 
			
		||||
 | 
			
		||||
import Brick (
 | 
			
		||||
  Widget (..), BrickEvent, EventM,
 | 
			
		||||
 )
 | 
			
		||||
import Data.Function ((&))
 | 
			
		||||
import Prelude hiding (appendFile)
 | 
			
		||||
 | 
			
		||||
import Data.Versions (prettyVer)
 | 
			
		||||
import GHCup.List ( ListResult(..) )
 | 
			
		||||
import GHCup.Types (KeyCombination, Tool (..))
 | 
			
		||||
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menu as Menu
 | 
			
		||||
import GHCup.Brick.Common (Name (..))
 | 
			
		||||
import GHCup.Brick.Widgets.Menu (Menu)
 | 
			
		||||
import qualified Brick.Widgets.Core as Brick
 | 
			
		||||
import qualified Brick.Widgets.Border as Border
 | 
			
		||||
import qualified Brick.Focus as F
 | 
			
		||||
import Brick.Widgets.Core ((<+>))
 | 
			
		||||
 | 
			
		||||
import Optics (to)
 | 
			
		||||
import Optics.Operators ((.~), (^.))
 | 
			
		||||
import Optics.Optic ((%))
 | 
			
		||||
import Data.Foldable (foldl')
 | 
			
		||||
 | 
			
		||||
type ContextMenu = Menu ListResult Name
 | 
			
		||||
 | 
			
		||||
create :: ListResult -> KeyCombination -> ContextMenu
 | 
			
		||||
create lr exit_key = Menu.createMenu Common.ContextBox lr exit_key buttons []
 | 
			
		||||
 where
 | 
			
		||||
  advInstallButton =
 | 
			
		||||
    Menu.createButtonField (MenuElement Common.AdvanceInstallButton)
 | 
			
		||||
      & Menu.fieldLabelL .~ "Install"
 | 
			
		||||
      & Menu.fieldHelpMsgL .~ "Advance Installation Settings"
 | 
			
		||||
  compileButton =
 | 
			
		||||
    Menu.createButtonField (MenuElement Common.CompilieButton)
 | 
			
		||||
      & Menu.fieldLabelL .~ "Compile"
 | 
			
		||||
      & Menu.fieldHelpMsgL .~ "Compile tool from source"
 | 
			
		||||
  buttons =
 | 
			
		||||
    case lTool lr of
 | 
			
		||||
      GHC -> [advInstallButton, compileButton]
 | 
			
		||||
      HLS -> [advInstallButton, compileButton]
 | 
			
		||||
      _ -> [advInstallButton]
 | 
			
		||||
 | 
			
		||||
draw :: ContextMenu -> Widget Name
 | 
			
		||||
draw menu = 
 | 
			
		||||
  Common.frontwardLayer
 | 
			
		||||
    ("Context Menu for " <> tool_str <> " " <> prettyVer (lVer $ menu ^. Menu.menuStateL))
 | 
			
		||||
    $ Brick.vBox
 | 
			
		||||
        [ Brick.vBox buttonWidgets
 | 
			
		||||
        , Brick.txt " "
 | 
			
		||||
        , Brick.padRight Brick.Max $ 
 | 
			
		||||
            Brick.txt "Press " 
 | 
			
		||||
            <+> Common.keyToWidget (menu ^. Menu.menuExitKeyL)
 | 
			
		||||
            <+> Brick.txt " to go back"
 | 
			
		||||
        ]
 | 
			
		||||
  where
 | 
			
		||||
    buttonLabels = [button & Menu.fieldLabel | button <- menu ^. Menu.menuButtonsL]
 | 
			
		||||
    maxWidth = foldl' max 5 (fmap Brick.textWidth buttonLabels)
 | 
			
		||||
 | 
			
		||||
    buttonAmplifiers =
 | 
			
		||||
      let buttonAsWidgets = fmap Menu.renderAslabel buttonLabels
 | 
			
		||||
       in fmap (\f b -> ((Menu.leftify (maxWidth + 10) . Border.border $ f b) <+>) ) buttonAsWidgets
 | 
			
		||||
    drawButtons = fmap Menu.drawField buttonAmplifiers
 | 
			
		||||
    buttonWidgets = zipWith (F.withFocusRing (menu ^. Menu.menuFocusRingL)) drawButtons (menu ^. Menu.menuButtonsL)
 | 
			
		||||
    tool_str =
 | 
			
		||||
      case menu ^. Menu.menuStateL % to lTool of
 | 
			
		||||
        GHC -> "GHC"
 | 
			
		||||
        GHCup -> "GHCup"
 | 
			
		||||
        Cabal -> "Cabal"
 | 
			
		||||
        HLS -> "HLS"
 | 
			
		||||
        Stack -> "Stack"
 | 
			
		||||
 | 
			
		||||
handler :: BrickEvent Name e -> EventM Name ContextMenu ()
 | 
			
		||||
handler = Menu.handlerMenu
 | 
			
		||||
							
								
								
									
										148
									
								
								lib-tui/GHCup/Brick/Widgets/Navigation.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										148
									
								
								lib-tui/GHCup/Brick/Widgets/Navigation.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,148 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
 | 
			
		||||
{- Brick's navigation widget:
 | 
			
		||||
It is a FocusRing over many list's. Each list contains the information for each tool. Each list has an internal name (for Brick's runtime)
 | 
			
		||||
and a label which we can use in rendering. This data-structure helps to reuse Brick.Widget.List and to navegate easily across
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Widgets.Navigation (BrickInternalState, create, handler, draw) where
 | 
			
		||||
 | 
			
		||||
import GHCup.List ( ListResult(..) )
 | 
			
		||||
import GHCup.Types
 | 
			
		||||
    ( GHCTargetVersion(GHCTargetVersion),
 | 
			
		||||
      Tool(..),
 | 
			
		||||
      Tag(..),
 | 
			
		||||
      tVerToText,
 | 
			
		||||
      tagToString )
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import qualified GHCup.Brick.Attributes as Attributes
 | 
			
		||||
import qualified GHCup.Brick.Widgets.SectionList as SectionList
 | 
			
		||||
import Brick
 | 
			
		||||
    ( BrickEvent(..),
 | 
			
		||||
      Padding(Max, Pad),
 | 
			
		||||
      AttrMap,
 | 
			
		||||
      EventM,
 | 
			
		||||
      Widget(..),
 | 
			
		||||
      (<+>),
 | 
			
		||||
      (<=>))
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import           Brick.Widgets.Border ( hBorder, borderWithLabel)
 | 
			
		||||
import           Brick.Widgets.Border.Style ( unicode )
 | 
			
		||||
import           Brick.Widgets.Center ( center )
 | 
			
		||||
import qualified Brick.Widgets.List as L
 | 
			
		||||
import           Data.List ( intercalate, sort )
 | 
			
		||||
import           Data.Maybe ( mapMaybe )
 | 
			
		||||
import           Data.Vector ( Vector)
 | 
			
		||||
import           Data.Versions ( prettyPVP, prettyVer )
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
import qualified Data.Text                     as T
 | 
			
		||||
import qualified Data.Vector                   as V
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
type BrickInternalState = SectionList.SectionList Common.Name ListResult
 | 
			
		||||
 | 
			
		||||
-- | How to create a navigation widget
 | 
			
		||||
create :: Common.Name                         -- The name of the section list
 | 
			
		||||
       -> [(Common.Name, Vector ListResult)]  -- a list of tuples (section name, collection of elements)
 | 
			
		||||
       -> Int                                 -- The height of each item in a list. Commonly 1 
 | 
			
		||||
       -> BrickInternalState
 | 
			
		||||
create = SectionList.sectionList
 | 
			
		||||
 | 
			
		||||
-- | How the navigation handler handle events
 | 
			
		||||
handler :: BrickEvent Common.Name e -> EventM Common.Name BrickInternalState ()
 | 
			
		||||
handler = SectionList.handleGenericListEvent
 | 
			
		||||
 | 
			
		||||
-- | How to draw the navigation widget
 | 
			
		||||
draw :: AttrMap -> BrickInternalState -> Widget Common.Name
 | 
			
		||||
draw dimAttrs section_list
 | 
			
		||||
  = Brick.padBottom Max
 | 
			
		||||
      ( Brick.withBorderStyle unicode
 | 
			
		||||
        $ borderWithLabel (Brick.str "GHCup")
 | 
			
		||||
          (center (header <=> hBorder <=> renderList' section_list))
 | 
			
		||||
      )
 | 
			
		||||
 where
 | 
			
		||||
  header =
 | 
			
		||||
    minHSize 2 Brick.emptyWidget
 | 
			
		||||
      <+> Brick.padLeft (Pad 2) (minHSize 6 $ Brick.str "Tool")
 | 
			
		||||
      <+> minHSize 15 (Brick.str "Version")
 | 
			
		||||
      <+> Brick.padLeft (Pad 1) (minHSize 25 $ Brick.str "Tags")
 | 
			
		||||
      <+> Brick.padLeft (Pad 5) (Brick.str "Notes")
 | 
			
		||||
  renderList' bis =
 | 
			
		||||
    let allElements = V.concatMap L.listElements $ SectionList.sectionListElements bis
 | 
			
		||||
        minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) allElements
 | 
			
		||||
        minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) allElements
 | 
			
		||||
    in Brick.withDefAttr L.listAttr $ SectionList.renderSectionList (renderItem minTagSize minVerSize) True bis
 | 
			
		||||
  renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} =
 | 
			
		||||
    let marks = if
 | 
			
		||||
          | lSet       -> (Brick.withAttr Attributes.setAttr $ Brick.str Common.setSign)
 | 
			
		||||
          | lInstalled -> (Brick.withAttr Attributes.installedAttr $ Brick.str Common.installedSign)
 | 
			
		||||
          | otherwise  -> (Brick.withAttr Attributes.notInstalledAttr $ Brick.str Common.notInstalledSign)
 | 
			
		||||
        ver = case lCross of
 | 
			
		||||
          Nothing -> T.unpack . prettyVer $ lVer
 | 
			
		||||
          Just c  -> T.unpack (c <> "-" <> prettyVer lVer)
 | 
			
		||||
        dim
 | 
			
		||||
          | lNoBindist && not lInstalled
 | 
			
		||||
            && not b -- TODO: overloading dim and active ignores active
 | 
			
		||||
                       --       so we hack around it here
 | 
			
		||||
          = Brick.updateAttrMap (const dimAttrs) . Brick.withAttr (Brick.attrName "no-bindist")
 | 
			
		||||
          | otherwise  = id
 | 
			
		||||
        hooray
 | 
			
		||||
          | elem Latest lTag' && not lInstalled =
 | 
			
		||||
              Brick.withAttr Attributes.hoorayAttr
 | 
			
		||||
          | otherwise = id
 | 
			
		||||
    in  hooray $ dim
 | 
			
		||||
          (   marks
 | 
			
		||||
          <+> Brick.padLeft (Pad 2)
 | 
			
		||||
               ( minHSize 6
 | 
			
		||||
                 (printTool lTool)
 | 
			
		||||
               )
 | 
			
		||||
          <+> minHSize minVerSize (Brick.str ver)
 | 
			
		||||
          <+> (let l = mapMaybe printTag $ sort lTag'
 | 
			
		||||
               in  Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l
 | 
			
		||||
                     then Brick.emptyWidget
 | 
			
		||||
                     else foldr1 (\x y -> x <+> Brick.str "," <+> y) l
 | 
			
		||||
              )
 | 
			
		||||
          <+> Brick.padLeft (Pad 5)
 | 
			
		||||
              ( let notes = printNotes listResult
 | 
			
		||||
                in  if null notes
 | 
			
		||||
                      then Brick.emptyWidget
 | 
			
		||||
                      else foldr1 (\x y -> x <+> Brick.str "," <+> y) notes
 | 
			
		||||
              )
 | 
			
		||||
          <+> Brick.vLimit 1 (Brick.fill ' ')
 | 
			
		||||
          )
 | 
			
		||||
 | 
			
		||||
  printTag Recommended    = Just $ Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended"
 | 
			
		||||
  printTag Latest         = Just $ Brick.withAttr Attributes.latestAttr $ Brick.str "latest"
 | 
			
		||||
  printTag Prerelease     = Just $ Brick.withAttr Attributes.prereleaseAttr $ Brick.str "prerelease"
 | 
			
		||||
  printTag Nightly        = Just $ Brick.withAttr Attributes.nightlyAttr $ Brick.str "nightly"
 | 
			
		||||
  printTag (Base pvp'')   = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp''))
 | 
			
		||||
  printTag Old            = Nothing
 | 
			
		||||
  printTag LatestPrerelease = Just $ Brick.withAttr Attributes.latestPrereleaseAttr $ Brick.str "latest-prerelease"
 | 
			
		||||
  printTag LatestNightly    = Just $ Brick.withAttr Attributes.latestNightlyAttr $ Brick.str "latest-nightly"
 | 
			
		||||
  printTag (UnknownTag t) = Just $ Brick.str t
 | 
			
		||||
 | 
			
		||||
  printTool Cabal = Brick.str "cabal"
 | 
			
		||||
  printTool GHC = Brick.str "GHC"
 | 
			
		||||
  printTool GHCup = Brick.str "GHCup"
 | 
			
		||||
  printTool HLS = Brick.str "HLS"
 | 
			
		||||
  printTool Stack = Brick.str "Stack"
 | 
			
		||||
 | 
			
		||||
  printNotes ListResult {..} =
 | 
			
		||||
    (if hlsPowered then [Brick.withAttr Attributes.hlsPoweredAttr $ Brick.str "hls-powered"] else mempty
 | 
			
		||||
      )
 | 
			
		||||
      ++ (if lStray then [Brick.withAttr Attributes.strayAttr $ Brick.str "stray"] else mempty)
 | 
			
		||||
      ++ (case lReleaseDay of
 | 
			
		||||
            Nothing -> mempty
 | 
			
		||||
            Just d  -> [Brick.withAttr Attributes.dayAttr $ Brick.str (show d)])
 | 
			
		||||
 | 
			
		||||
  minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ')
 | 
			
		||||
							
								
								
									
										193
									
								
								lib-tui/GHCup/Brick/Widgets/SectionList.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										193
									
								
								lib-tui/GHCup/Brick/Widgets/SectionList.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,193 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE TypeApplications  #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# LANGUAGE ViewPatterns      #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
{-# LANGUAGE TemplateHaskell   #-}
 | 
			
		||||
{-# LANGUAGE BangPatterns #-}
 | 
			
		||||
{-# LANGUAGE InstanceSigs #-}
 | 
			
		||||
 | 
			
		||||
{- A general system for lists with sections
 | 
			
		||||
 | 
			
		||||
Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing 
 | 
			
		||||
the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). 
 | 
			
		||||
 | 
			
		||||
- To build a SectionList use the safe constructor sectionList
 | 
			
		||||
- To access sections use the lens provider sectionL and the name of the section you'd like to access
 | 
			
		||||
- You can modify Brick.Widget.List.GenericList within GenericSectionList via sectionL but do not
 | 
			
		||||
  modify the vector length
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Widgets.SectionList where
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
import Brick
 | 
			
		||||
    ( BrickEvent(VtyEvent, MouseDown),
 | 
			
		||||
      EventM,
 | 
			
		||||
      Size(..),
 | 
			
		||||
      Widget(..), 
 | 
			
		||||
      ViewportType (Vertical),
 | 
			
		||||
      (<=>))
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import           Brick.Widgets.Border ( hBorder)
 | 
			
		||||
import qualified Brick.Widgets.List as L
 | 
			
		||||
import           Brick.Focus (FocusRing)
 | 
			
		||||
import qualified Brick.Focus as F
 | 
			
		||||
import           Data.Function ( (&))
 | 
			
		||||
import Data.Maybe ( fromMaybe )
 | 
			
		||||
import           Data.Vector ( Vector )
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
 | 
			
		||||
import qualified Graphics.Vty                  as Vty
 | 
			
		||||
import qualified Data.Vector                   as V
 | 
			
		||||
 | 
			
		||||
import           Optics.TH (makeLensesFor)
 | 
			
		||||
import           Optics.State (use)
 | 
			
		||||
import           Optics.State.Operators ( (%=), (<%=))
 | 
			
		||||
import           Optics.Operators ((.~), (^.))
 | 
			
		||||
import           Optics.Lens (Lens', lens)
 | 
			
		||||
 | 
			
		||||
data GenericSectionList n t e
 | 
			
		||||
    = GenericSectionList
 | 
			
		||||
    { sectionListFocusRing :: FocusRing n                   -- ^ The FocusRing for all sections
 | 
			
		||||
    , sectionListElements :: !(Vector (L.GenericList n t e)) -- ^ A vector of brick's built-in list
 | 
			
		||||
    , sectionListName :: n                                   -- ^ The section list name
 | 
			
		||||
    }
 | 
			
		||||
 | 
			
		||||
makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListElements", "sectionListElementsL"), ("sectionListName", "sectionListNameL")] ''GenericSectionList
 | 
			
		||||
 | 
			
		||||
type SectionList n e = GenericSectionList n V.Vector e
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses. 
 | 
			
		||||
sectionList :: Foldable t 
 | 
			
		||||
            => n                     -- The name of the section list
 | 
			
		||||
            -> [(n, t e)]            -- a list of tuples (section name, collection of elements)
 | 
			
		||||
            -> Int
 | 
			
		||||
            -> GenericSectionList n t e
 | 
			
		||||
sectionList name elements height
 | 
			
		||||
  = GenericSectionList
 | 
			
		||||
  { sectionListFocusRing = F.focusRing [section_name | (section_name, _) <- elements]
 | 
			
		||||
  , sectionListElements  = V.fromList [L.list section_name els height | (section_name, els) <- elements]
 | 
			
		||||
  , sectionListName = name
 | 
			
		||||
  }
 | 
			
		||||
-- | This lens constructor, takes a name and looks if a section has such a name.
 | 
			
		||||
--   Used to dispatch events to sections. It is a partial function only meant to 
 | 
			
		||||
--   be used with the FocusRing inside GenericSectionList
 | 
			
		||||
sectionL :: Eq n => n -> Lens' (GenericSectionList n t e) (L.GenericList n t e)
 | 
			
		||||
sectionL section_name = lens g s
 | 
			
		||||
    where is_section_name = (== section_name) . L.listName
 | 
			
		||||
          g section_list =
 | 
			
		||||
            let elms   = section_list ^. sectionListElementsL
 | 
			
		||||
                zeroth = elms V.! 0 -- TODO: This crashes for empty vectors. 
 | 
			
		||||
            in fromMaybe zeroth (V.find is_section_name elms)
 | 
			
		||||
          s gl@(GenericSectionList _ elms _) list =
 | 
			
		||||
            case V.findIndex is_section_name elms of
 | 
			
		||||
                 Nothing -> gl
 | 
			
		||||
                 Just i  -> let new_elms = V.update elms (V.fromList [(i, list)])
 | 
			
		||||
                             in gl & sectionListElementsL .~ new_elms
 | 
			
		||||
 | 
			
		||||
moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) ()
 | 
			
		||||
moveDown = do 
 | 
			
		||||
    ring <- use sectionListFocusRingL
 | 
			
		||||
    case F.focusGetCurrent ring of 
 | 
			
		||||
        Nothing -> pure ()
 | 
			
		||||
        Just l  -> do      -- If it is the last element, move to the first element of the next focus; else, just handle regular list event.
 | 
			
		||||
            current_list <- use (sectionL l)
 | 
			
		||||
            let current_idx = L.listSelected current_list
 | 
			
		||||
                list_length = current_list & length
 | 
			
		||||
            if current_idx == Just (list_length - 1)
 | 
			
		||||
                then do 
 | 
			
		||||
                    new_focus <- sectionListFocusRingL <%= F.focusNext
 | 
			
		||||
                    case F.focusGetCurrent new_focus of
 | 
			
		||||
                        Nothing -> pure () -- |- Optic.Zoom.zoom doesn't typecheck but Lens.Micro.Mtl.zoom does. It is re-exported by Brick
 | 
			
		||||
                        Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToBeginning)
 | 
			
		||||
                else Common.zoom  (sectionL l) $ Brick.modify L.listMoveDown
 | 
			
		||||
 | 
			
		||||
moveUp :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) ()
 | 
			
		||||
moveUp = do
 | 
			
		||||
    ring <- use sectionListFocusRingL
 | 
			
		||||
    case F.focusGetCurrent ring of
 | 
			
		||||
        Nothing -> pure ()
 | 
			
		||||
        Just l  -> do  -- If it is the first element, move to the last element of the prev focus; else, just handle regular list event.
 | 
			
		||||
            current_list <- use (sectionL l)
 | 
			
		||||
            let current_idx = L.listSelected current_list
 | 
			
		||||
            if current_idx == Just 0
 | 
			
		||||
                then do 
 | 
			
		||||
                    new_focus <- sectionListFocusRingL <%= F.focusPrev
 | 
			
		||||
                    case F.focusGetCurrent new_focus of
 | 
			
		||||
                        Nothing -> pure ()  
 | 
			
		||||
                        Just new_l -> Common.zoom (sectionL new_l) (Brick.modify L.listMoveToEnd)
 | 
			
		||||
                else Common.zoom (sectionL l) $ Brick.modify L.listMoveUp
 | 
			
		||||
 | 
			
		||||
-- | Handle events for list cursor movement.  Events handled are:
 | 
			
		||||
--
 | 
			
		||||
-- * Up (up arrow key). If first element of section, then jump prev section
 | 
			
		||||
-- * Down (down arrow key). If last element of section, then jump next section
 | 
			
		||||
-- * Page Up (PgUp)
 | 
			
		||||
-- * Page Down (PgDown)
 | 
			
		||||
-- * Go to next section (Tab)
 | 
			
		||||
-- * Go to prev section (BackTab)
 | 
			
		||||
handleGenericListEvent :: (Foldable t, L.Splittable t, Ord n)
 | 
			
		||||
                       => BrickEvent n a
 | 
			
		||||
                       -> EventM n (GenericSectionList n t e) ()
 | 
			
		||||
handleGenericListEvent (VtyEvent (Vty.EvResize _ _))              = pure ()
 | 
			
		||||
handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext
 | 
			
		||||
handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab []))     = sectionListFocusRingL %= F.focusPrev
 | 
			
		||||
handleGenericListEvent (MouseDown _ Vty.BScrollDown _ _)          = moveDown
 | 
			
		||||
handleGenericListEvent (MouseDown _ Vty.BScrollUp _ _)            = moveUp
 | 
			
		||||
handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KDown []))        = moveDown
 | 
			
		||||
handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KUp []))          = moveUp
 | 
			
		||||
handleGenericListEvent (VtyEvent ev) = do
 | 
			
		||||
    ring <- use sectionListFocusRingL
 | 
			
		||||
    case F.focusGetCurrent ring of
 | 
			
		||||
        Nothing -> pure ()
 | 
			
		||||
        Just l  -> Common.zoom (sectionL l) $ L.handleListEvent ev
 | 
			
		||||
handleGenericListEvent _ = pure ()
 | 
			
		||||
 | 
			
		||||
-- This re-uses Brick.Widget.List.renderList
 | 
			
		||||
renderSectionList :: forall n t e . (Traversable t, Ord n, Show n, Eq n, L.Splittable t, Semigroup (t e))
 | 
			
		||||
                  => (Bool -> e -> Widget n)             -- ^ Rendering function of the list element, True for the selected element
 | 
			
		||||
                  -> Bool                                -- ^ Whether the section list has focus
 | 
			
		||||
                  -> GenericSectionList n t e            -- ^ The section list to render
 | 
			
		||||
                  -> Widget n
 | 
			
		||||
renderSectionList renderElem sectionFocus ge@(GenericSectionList focus elms slName) =
 | 
			
		||||
    Brick.Widget Brick.Greedy Brick.Greedy $ Brick.render $ Brick.viewport slName Brick.Vertical $
 | 
			
		||||
      V.ifoldl' (\(!accWidget) !i list ->
 | 
			
		||||
                      let hasFocusList = sectionIsFocused list
 | 
			
		||||
                          makeVisible = if hasFocusList then Brick.visibleRegion (Brick.Location (c, r)) (1, 1) else id
 | 
			
		||||
                          appendBorder = if i == 0 then id else (hBorder <=>)
 | 
			
		||||
                          newWidget = appendBorder (makeVisible $ renderInnerList hasFocusList list)
 | 
			
		||||
                      in accWidget <=> newWidget
 | 
			
		||||
                      )
 | 
			
		||||
      Brick.emptyWidget
 | 
			
		||||
      elms
 | 
			
		||||
 where
 | 
			
		||||
  -- A section is focused if the whole thing is focused, and the inner list has focus
 | 
			
		||||
  sectionIsFocused :: L.GenericList n t e -> Bool
 | 
			
		||||
  sectionIsFocused l = sectionFocus && (Just (L.listName l) == F.focusGetCurrent focus)
 | 
			
		||||
 | 
			
		||||
  renderInnerList :: Bool -> L.GenericList n t e -> Widget n
 | 
			
		||||
  renderInnerList hasFocus l = Brick.vLimit (length l) $ L.renderList (\b -> renderElem (b && hasFocus)) hasFocus l
 | 
			
		||||
 | 
			
		||||
  -- compute the location to focus on within the active section
 | 
			
		||||
  (c, r) :: (Int, Int) = case sectionListSelectedElement ge of
 | 
			
		||||
                           Nothing -> (0, 0)
 | 
			
		||||
                           Just (selElIx, _) -> (0, selElIx)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | Equivalent to listSelectedElement
 | 
			
		||||
sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e)
 | 
			
		||||
sectionListSelectedElement generic_section_list = do
 | 
			
		||||
  current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent 
 | 
			
		||||
  let current_section = generic_section_list ^. sectionL current_focus
 | 
			
		||||
  L.listSelectedElement current_section 
 | 
			
		||||
							
								
								
									
										77
									
								
								lib-tui/GHCup/Brick/Widgets/Tutorial.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										77
									
								
								lib-tui/GHCup/Brick/Widgets/Tutorial.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,77 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
 | 
			
		||||
{-
 | 
			
		||||
A very simple information-only widget with no handler. 
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
module GHCup.Brick.Widgets.Tutorial (draw) where
 | 
			
		||||
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import qualified GHCup.Brick.Attributes as Attributes
 | 
			
		||||
 | 
			
		||||
import Brick
 | 
			
		||||
    ( Padding(Max),
 | 
			
		||||
      Widget(..),
 | 
			
		||||
      (<=>))
 | 
			
		||||
import qualified Brick
 | 
			
		||||
import           Brick.Widgets.Center ( center )
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
draw :: Widget Common.Name
 | 
			
		||||
draw =
 | 
			
		||||
  let
 | 
			
		||||
    mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max)
 | 
			
		||||
 | 
			
		||||
  in Common.frontwardLayer "Tutorial"
 | 
			
		||||
      $ Brick.vBox
 | 
			
		||||
          (fmap center
 | 
			
		||||
            [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."]
 | 
			
		||||
            , Common.separator
 | 
			
		||||
            , mkTextBox [
 | 
			
		||||
                Brick.hBox [
 | 
			
		||||
                  Brick.txt "This symbol "
 | 
			
		||||
                , Brick.withAttr Attributes.installedAttr (Brick.str Common.installedSign)
 | 
			
		||||
                , Brick.txtWrap " means that the tool is installed but not in used"
 | 
			
		||||
                ]
 | 
			
		||||
              , Brick.hBox [
 | 
			
		||||
                  Brick.txt "This symbol "
 | 
			
		||||
                , Brick.withAttr Attributes.setAttr (Brick.str Common.setSign)
 | 
			
		||||
                , Brick.txtWrap " means that the tool is installed and in used"
 | 
			
		||||
                ]
 | 
			
		||||
              , Brick.hBox [
 | 
			
		||||
                  Brick.txt "This symbol "
 | 
			
		||||
                , Brick.withAttr Attributes.notInstalledAttr (Brick.str Common.notInstalledSign)
 | 
			
		||||
                , Brick.txt " means that the tool isn't installed"
 | 
			
		||||
                ]
 | 
			
		||||
              ]
 | 
			
		||||
            , Common.separator
 | 
			
		||||
            , mkTextBox [
 | 
			
		||||
                Brick.hBox [
 | 
			
		||||
                  Brick.withAttr Attributes.recommendedAttr $ Brick.str "recommended"
 | 
			
		||||
                , Brick.txtWrap " tag is based on community adoption, known bugs, etc... So It makes this version the least experimental"
 | 
			
		||||
                ]
 | 
			
		||||
              , Brick.hBox [
 | 
			
		||||
                  Brick.withAttr Attributes.latestAttr $ Brick.str "latest"
 | 
			
		||||
                , Brick.txtWrap " tag is for the latest distributed version of the tool"
 | 
			
		||||
                ]
 | 
			
		||||
              , Brick.hBox [
 | 
			
		||||
                  Brick.withAttr Attributes.latestAttr $ Brick.str "hls-powered"
 | 
			
		||||
                , Brick.txt " denotes the compiler version supported by the currently set ("
 | 
			
		||||
                , Brick.withAttr Attributes.setAttr (Brick.str Common.setSign)
 | 
			
		||||
                , Brick.txt ") hls"
 | 
			
		||||
                ]
 | 
			
		||||
              , Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version"
 | 
			
		||||
              ]
 | 
			
		||||
            , Brick.txt " "
 | 
			
		||||
            ])
 | 
			
		||||
        <=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial")
 | 
			
		||||
							
								
								
									
										76
									
								
								lib-tui/GHCup/BrickMain.hs
									
									
									
									
									
										Normal file
									
								
							
							
						
						
									
										76
									
								
								lib-tui/GHCup/BrickMain.hs
									
									
									
									
									
										Normal file
									
								
							@ -0,0 +1,76 @@
 | 
			
		||||
{-# LANGUAGE CPP               #-}
 | 
			
		||||
{-# LANGUAGE DataKinds         #-}
 | 
			
		||||
{-# LANGUAGE FlexibleContexts  #-}
 | 
			
		||||
{-# LANGUAGE OverloadedStrings #-}
 | 
			
		||||
{-# LANGUAGE RankNTypes        #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
 | 
			
		||||
{-
 | 
			
		||||
This module contains the entrypoint for the brick application and nothing else.
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
module GHCup.BrickMain where
 | 
			
		||||
 | 
			
		||||
import GHCup.Types
 | 
			
		||||
    ( Settings(noColor),
 | 
			
		||||
      AppState(ghcupInfo, settings, keyBindings, loggerConfig), KeyBindings (..) )
 | 
			
		||||
import GHCup.Prelude.Logger ( logError )
 | 
			
		||||
import qualified GHCup.Brick.Actions as Actions
 | 
			
		||||
import qualified GHCup.Brick.Common as Common
 | 
			
		||||
import qualified GHCup.Brick.App as BrickApp
 | 
			
		||||
import qualified GHCup.Brick.Attributes as Attributes
 | 
			
		||||
import qualified GHCup.Brick.BrickState as AppState
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.Context as ContextMenu
 | 
			
		||||
import qualified GHCup.Brick.Widgets.SectionList as Navigation
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.AdvanceInstall as AdvanceInstall
 | 
			
		||||
import qualified GHCup.Brick.Widgets.Menus.CompileGHC as CompileGHC
 | 
			
		||||
import qualified Brick
 | 
			
		||||
 | 
			
		||||
import Control.Monad.Reader ( ReaderT(runReaderT) )
 | 
			
		||||
import Data.Functor ( ($>) )
 | 
			
		||||
import           Data.IORef (writeIORef)
 | 
			
		||||
import           Prelude                 hiding ( appendFile )
 | 
			
		||||
import System.Exit ( ExitCode(ExitFailure), exitWith )
 | 
			
		||||
 | 
			
		||||
import qualified Data.Text                     as T
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
brickMain :: AppState
 | 
			
		||||
          -> IO ()
 | 
			
		||||
brickMain s = do
 | 
			
		||||
  writeIORef Actions.settings' s
 | 
			
		||||
 | 
			
		||||
  eAppData <- Actions.getAppData (Just $ ghcupInfo s)
 | 
			
		||||
  case eAppData of
 | 
			
		||||
    Right ad -> do
 | 
			
		||||
      let initial_list = Actions.constructList ad Common.defaultAppSettings Nothing
 | 
			
		||||
          current_element = Navigation.sectionListSelectedElement initial_list
 | 
			
		||||
          exit_key = bQuit . keyBindings $ s 
 | 
			
		||||
      case current_element of
 | 
			
		||||
        Nothing -> do
 | 
			
		||||
          flip runReaderT s $ logError "Error building app state: empty ResultList" 
 | 
			
		||||
          exitWith $ ExitFailure 2
 | 
			
		||||
        Just (_, e) ->
 | 
			
		||||
          let initapp = 
 | 
			
		||||
                BrickApp.app 
 | 
			
		||||
                  (Attributes.defaultAttributes $ noColor $ settings s)
 | 
			
		||||
                  (Attributes.dimAttributes $ noColor $ settings s)
 | 
			
		||||
              initstate =
 | 
			
		||||
                AppState.BrickState ad
 | 
			
		||||
                      Common.defaultAppSettings
 | 
			
		||||
                      initial_list
 | 
			
		||||
                      (ContextMenu.create e exit_key)
 | 
			
		||||
                      (AdvanceInstall.create (bQuit . keyBindings $ s ))
 | 
			
		||||
                      (CompileGHC.create exit_key)
 | 
			
		||||
                      (keyBindings s)
 | 
			
		||||
                      Common.Navigation
 | 
			
		||||
          in Brick.defaultMain initapp initstate 
 | 
			
		||||
          $> ()
 | 
			
		||||
    Left e -> do
 | 
			
		||||
      flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e)
 | 
			
		||||
      exitWith $ ExitFailure 2
 | 
			
		||||
		Loading…
	
		Reference in New Issue
	
	Block a user