Use MonadState Instance to simplify install', del', set' and changelog'. Lensify the app
This commit is contained in:
		
							parent
							
								
									2caf491e9d
								
							
						
					
					
						commit
						aa9fbdbfc2
					
				@ -7,6 +7,9 @@
 | 
			
		||||
{-# LANGUAGE ViewPatterns      #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
 | 
			
		||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
 | 
			
		||||
{-# LANGUAGE FlexibleInstances #-}
 | 
			
		||||
{-# LANGUAGE MultiParamTypeClasses #-}
 | 
			
		||||
{-# LANGUAGE TemplateHaskell   #-}
 | 
			
		||||
 | 
			
		||||
module BrickMain where
 | 
			
		||||
 | 
			
		||||
@ -22,14 +25,57 @@ import           GHCup.Prelude.Logger
 | 
			
		||||
import           GHCup.Prelude.Process
 | 
			
		||||
import           GHCup.Prompts
 | 
			
		||||
 | 
			
		||||
import           Brick
 | 
			
		||||
import           Brick.Widgets.Border
 | 
			
		||||
import           Brick.Widgets.Border.Style
 | 
			
		||||
import           Brick.Widgets.Center
 | 
			
		||||
import Brick
 | 
			
		||||
    ( defaultMain,
 | 
			
		||||
      suspendAndResume,
 | 
			
		||||
      attrMap,
 | 
			
		||||
      showFirstCursor,
 | 
			
		||||
      hLimit,
 | 
			
		||||
      vBox,
 | 
			
		||||
      viewport,
 | 
			
		||||
      visible,
 | 
			
		||||
      fill,
 | 
			
		||||
      vLimit,
 | 
			
		||||
      forceAttr,
 | 
			
		||||
      putCursor,
 | 
			
		||||
      updateAttrMap,
 | 
			
		||||
      withDefAttr,
 | 
			
		||||
      padLeft,
 | 
			
		||||
      (<+>),
 | 
			
		||||
      emptyWidget,
 | 
			
		||||
      txtWrap,
 | 
			
		||||
      attrName,
 | 
			
		||||
      withAttr,
 | 
			
		||||
      (<=>),
 | 
			
		||||
      str,
 | 
			
		||||
      withBorderStyle,
 | 
			
		||||
      padBottom,
 | 
			
		||||
      halt,
 | 
			
		||||
      BrickEvent(VtyEvent, MouseDown),
 | 
			
		||||
      App(..),
 | 
			
		||||
      ViewportType(Vertical),
 | 
			
		||||
      Size(Greedy),
 | 
			
		||||
      Location(Location),
 | 
			
		||||
      Padding(Max, Pad),
 | 
			
		||||
      Widget(Widget, render),
 | 
			
		||||
      AttrMap,
 | 
			
		||||
      Direction(..),
 | 
			
		||||
      get,
 | 
			
		||||
      zoom, 
 | 
			
		||||
      EventM,
 | 
			
		||||
      suffixLenses,
 | 
			
		||||
      Named(..), modify )
 | 
			
		||||
import           Brick.Widgets.Border ( hBorder, borderWithLabel )
 | 
			
		||||
import           Brick.Widgets.Border.Style ( unicode )
 | 
			
		||||
import           Brick.Widgets.Center ( center )
 | 
			
		||||
import           Brick.Widgets.Dialog (buttonSelectedAttr)
 | 
			
		||||
import           Brick.Widgets.List             ( listSelectedFocusedAttr
 | 
			
		||||
                                                , listSelectedAttr
 | 
			
		||||
                                                , listAttr
 | 
			
		||||
                                                )
 | 
			
		||||
import qualified Brick.Widgets.List as L
 | 
			
		||||
import           Brick.Focus (FocusRing)
 | 
			
		||||
import qualified Brick.Focus as F
 | 
			
		||||
import           Codec.Archive
 | 
			
		||||
import           Control.Applicative
 | 
			
		||||
import           Control.Exception.Safe
 | 
			
		||||
@ -41,9 +87,10 @@ import           Control.Monad.Trans.Except
 | 
			
		||||
import           Control.Monad.Trans.Resource
 | 
			
		||||
import           Data.Bool
 | 
			
		||||
import           Data.Functor
 | 
			
		||||
import           Data.Function ( (&))
 | 
			
		||||
import           Data.List
 | 
			
		||||
import           Data.Maybe
 | 
			
		||||
import           Data.IORef
 | 
			
		||||
import           Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef)
 | 
			
		||||
import           Data.Vector                    ( Vector
 | 
			
		||||
                                                , (!?)
 | 
			
		||||
                                                )
 | 
			
		||||
@ -67,6 +114,153 @@ import           System.FilePath
 | 
			
		||||
import qualified System.Posix.Process          as SPP
 | 
			
		||||
#endif
 | 
			
		||||
 | 
			
		||||
import           Optics.TH (makeLenses, makeLensesFor)
 | 
			
		||||
import           Optics.State (use)
 | 
			
		||||
import           Optics.State.Operators ( (.=), (%=), (<%=))
 | 
			
		||||
import           Optics.Optic ((%))
 | 
			
		||||
import           Optics.Operators ((.~), (^.))
 | 
			
		||||
import           Optics.Getter (view)
 | 
			
		||||
import           Optics.Lens (Lens', lens, toLensVL, lensVL)
 | 
			
		||||
 | 
			
		||||
{- Brick's widget:
 | 
			
		||||
It is a FocusRing over many list's. Each list contains the information for each tool. Each list has an internal name (for Brick's runtime)
 | 
			
		||||
and a label which we can use in rendering. This data-structure helps to reuse Brick.Widget.List and to navegate easily across
 | 
			
		||||
 | 
			
		||||
Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing 
 | 
			
		||||
the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list). 
 | 
			
		||||
 | 
			
		||||
- To build a SectionList use the safe constructor sectionList
 | 
			
		||||
- To access sections use the lens provider sectionL and the name of the section you'd like to access
 | 
			
		||||
- You can modify Brick.Widget.List.GenericList within GenericSectionList via sectionL but do not
 | 
			
		||||
  modify the vector length
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
data GenericSectionList n t e
 | 
			
		||||
    = GenericSectionList
 | 
			
		||||
    { sectionListFocusRing :: FocusRing n                   -- ^ The FocusRing for all sections
 | 
			
		||||
    , sectionListElements :: !(Vector (L.GenericList n t e)) -- ^ A key-value vector
 | 
			
		||||
    , sectionListName :: n                                   -- ^ The section list name
 | 
			
		||||
    }
 | 
			
		||||
 | 
			
		||||
makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListElements", "sectionListElementsL"), ("sectionListName", "sectionListNameL")] ''GenericSectionList
 | 
			
		||||
 | 
			
		||||
type SectionList n e = GenericSectionList n V.Vector e
 | 
			
		||||
 | 
			
		||||
instance Named (GenericSectionList n t e) n where
 | 
			
		||||
    getName = sectionListName
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | 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
 | 
			
		||||
 | 
			
		||||
-- | 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 ()
 | 
			
		||||
                       -> EventM n (GenericSectionList n t e) ()
 | 
			
		||||
handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext
 | 
			
		||||
handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab []))     = sectionListFocusRingL %= F.focusPrev
 | 
			
		||||
handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KDown [])) = 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 -> zoom (toLensVL $ sectionL new_l) (modify L.listMoveToBeginning)
 | 
			
		||||
                else zoom (toLensVL $ sectionL l) $ L.handleListEvent ev
 | 
			
		||||
handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KUp [])) = 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 -> zoom (toLensVL $ sectionL new_l) (modify L.listMoveToEnd)
 | 
			
		||||
                else zoom (toLensVL $ sectionL l) $ L.handleListEvent ev
 | 
			
		||||
handleGenericListEvent (VtyEvent ev) = do
 | 
			
		||||
    ring <- use sectionListFocusRingL
 | 
			
		||||
    case F.focusGetCurrent ring of
 | 
			
		||||
        Nothing -> pure ()
 | 
			
		||||
        Just l  -> zoom (toLensVL $ sectionL l) $ L.handleListEvent ev
 | 
			
		||||
handleGenericListEvent _ = pure ()
 | 
			
		||||
 | 
			
		||||
-- This re-uses Brick.Widget.List.renderList
 | 
			
		||||
renderSectionList :: (Traversable t, Ord n, Show n, Eq n, L.Splittable t)
 | 
			
		||||
                  => (Bool -> n -> Widget n)             -- ^ Rendering function for separator between sections. True for selected before section
 | 
			
		||||
                  -> (Bool -> n -> Widget n -> Widget n) -- ^ Rendering function for the borders. True for selected section
 | 
			
		||||
                  -> (Bool -> e -> Widget n)             -- ^ Rendering function of the list element, True for the selected element
 | 
			
		||||
                  -> Bool                                -- ^ Whether the section list has focus
 | 
			
		||||
                  -> GenericSectionList n t e            -- ^ The section list to render
 | 
			
		||||
                  -> Widget n
 | 
			
		||||
renderSectionList render_separator render_border render_elem section_focus (GenericSectionList focus elms _) =
 | 
			
		||||
    V.foldl' (\wacc list ->
 | 
			
		||||
                let has_focus = is_focused_section list
 | 
			
		||||
                    list_name = L.listName list
 | 
			
		||||
                 in   wacc
 | 
			
		||||
                  <=> render_separator has_focus list_name
 | 
			
		||||
                  <=> inner_widget has_focus list_name list
 | 
			
		||||
             )
 | 
			
		||||
             emptyWidget elms
 | 
			
		||||
  where
 | 
			
		||||
    is_focused_section l = section_focus && Just (L.listName l) == F.focusGetCurrent focus
 | 
			
		||||
    inner_widget has_focus k l = render_border has_focus k (L.renderList render_elem has_focus l)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | 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 
 | 
			
		||||
 | 
			
		||||
{- GHCUp State
 | 
			
		||||
 | 
			
		||||
-}
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
installedSign :: String
 | 
			
		||||
#if IS_WINDOWS
 | 
			
		||||
@ -91,55 +285,71 @@ notInstalledSign = "✗ "
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
data BrickData = BrickData
 | 
			
		||||
  { lr    :: [ListResult]
 | 
			
		||||
  { _lr    :: [ListResult]
 | 
			
		||||
  }
 | 
			
		||||
  deriving Show
 | 
			
		||||
 | 
			
		||||
makeLenses ''BrickData
 | 
			
		||||
 | 
			
		||||
data BrickSettings = BrickSettings
 | 
			
		||||
  { showAllVersions    :: Bool
 | 
			
		||||
  { _showAllVersions    :: Bool
 | 
			
		||||
  , _showAllTools       :: Bool
 | 
			
		||||
  }
 | 
			
		||||
  deriving Show
 | 
			
		||||
  --deriving Show
 | 
			
		||||
 | 
			
		||||
makeLenses ''BrickSettings
 | 
			
		||||
 | 
			
		||||
data BrickInternalState = BrickInternalState
 | 
			
		||||
  { clr :: Vector ListResult
 | 
			
		||||
  , ix  :: Int
 | 
			
		||||
  { _clr   :: Vector ListResult
 | 
			
		||||
  , _ix    :: Int
 | 
			
		||||
  }
 | 
			
		||||
  deriving Show
 | 
			
		||||
  --deriving Show
 | 
			
		||||
 | 
			
		||||
makeLenses ''BrickInternalState
 | 
			
		||||
 | 
			
		||||
data BrickState = BrickState
 | 
			
		||||
  { appData     :: BrickData
 | 
			
		||||
  , appSettings :: BrickSettings
 | 
			
		||||
  , appState    :: BrickInternalState
 | 
			
		||||
  , appKeys     :: KeyBindings
 | 
			
		||||
  { _appData     :: BrickData
 | 
			
		||||
  , _appSettings :: BrickSettings
 | 
			
		||||
  , _appState    :: BrickInternalState
 | 
			
		||||
  , _appKeys     :: KeyBindings
 | 
			
		||||
  }
 | 
			
		||||
  deriving Show
 | 
			
		||||
  --deriving Show
 | 
			
		||||
 | 
			
		||||
makeLenses ''BrickState
 | 
			
		||||
 | 
			
		||||
keyHandlers :: KeyBindings
 | 
			
		||||
            -> [ ( KeyCombination
 | 
			
		||||
                 , BrickSettings -> String
 | 
			
		||||
                 , BrickState -> EventM String BrickState ()
 | 
			
		||||
                 , EventM String BrickState ()
 | 
			
		||||
                 )
 | 
			
		||||
               ]
 | 
			
		||||
keyHandlers KeyBindings {..} =
 | 
			
		||||
  [ (bQuit, const "Quit"     , \_ -> halt)
 | 
			
		||||
  [ (bQuit, const "Quit"     , 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)
 | 
			
		||||
       if _showAllVersions then "Don't show all versions" else "Show all versions"
 | 
			
		||||
    , hideShowHandler' (not . _showAllVersions) _showAllTools
 | 
			
		||||
    )
 | 
			
		||||
  , (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. })
 | 
			
		||||
  , (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. })
 | 
			
		||||
  , (bUp, const "Up", appState %= moveCursor 1 Up)
 | 
			
		||||
  , (bDown, const "Down", appState %= moveCursor 1 Down)
 | 
			
		||||
  ]
 | 
			
		||||
 where
 | 
			
		||||
  hideShowHandler f BrickState{..} =
 | 
			
		||||
    let newAppSettings   = appSettings { showAllVersions = f appSettings }
 | 
			
		||||
        newInternalState = constructList appData newAppSettings (Just appState)
 | 
			
		||||
    in  put (BrickState appData newAppSettings newInternalState appKeys)
 | 
			
		||||
  --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
 | 
			
		||||
  hideShowHandler' f p = do 
 | 
			
		||||
    app_settings <- use appSettings
 | 
			
		||||
    let 
 | 
			
		||||
      vers = f app_settings
 | 
			
		||||
      tools = p app_settings
 | 
			
		||||
      newAppSettings = app_settings & showAllVersions .~ vers & showAllTools .~ tools
 | 
			
		||||
    ad <- use appData
 | 
			
		||||
    current_app_state <- use appState
 | 
			
		||||
    appSettings .= newAppSettings
 | 
			
		||||
    appState    .= constructList ad app_settings (Just current_app_state)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
showKey :: Vty.Key -> String
 | 
			
		||||
@ -153,11 +363,11 @@ showMod = tail . show
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
ui :: AttrMap -> BrickState -> Widget String
 | 
			
		||||
ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
 | 
			
		||||
ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
 | 
			
		||||
  = padBottom Max
 | 
			
		||||
      ( withBorderStyle unicode
 | 
			
		||||
        $ borderWithLabel (str "GHCup")
 | 
			
		||||
          (center (header <=> hBorder <=> renderList' appState))
 | 
			
		||||
          (center (header <=> hBorder <=> renderList' _appState))
 | 
			
		||||
      )
 | 
			
		||||
    <=> footer
 | 
			
		||||
 | 
			
		||||
@ -168,7 +378,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
 | 
			
		||||
      . T.pack
 | 
			
		||||
      . foldr1 (\x y -> x <> "  " <> y)
 | 
			
		||||
      . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)
 | 
			
		||||
      $ keyHandlers appKeys
 | 
			
		||||
      $ keyHandlers _appKeys
 | 
			
		||||
  header =
 | 
			
		||||
    minHSize 2 emptyWidget
 | 
			
		||||
      <+> padLeft (Pad 2) (minHSize 6 $ str "Tool")
 | 
			
		||||
@ -176,8 +386,8 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
 | 
			
		||||
      <+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
 | 
			
		||||
      <+> padLeft (Pad 5) (str "Notes")
 | 
			
		||||
  renderList' bis@BrickInternalState{..} =
 | 
			
		||||
    let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr
 | 
			
		||||
        minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr
 | 
			
		||||
    let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) _clr
 | 
			
		||||
        minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) _clr
 | 
			
		||||
    in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis
 | 
			
		||||
  renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} =
 | 
			
		||||
    let marks = if
 | 
			
		||||
@ -283,11 +493,10 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
 | 
			
		||||
minHSize :: Int -> Widget n -> Widget n
 | 
			
		||||
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
app :: AttrMap -> AttrMap -> App BrickState e String
 | 
			
		||||
app :: AttrMap -> AttrMap -> App BrickState () String
 | 
			
		||||
app attrs dimAttrs =
 | 
			
		||||
  App { appDraw         = \st -> [ui dimAttrs st]
 | 
			
		||||
  , appHandleEvent  = \be -> get >>= \s -> eventHandler s be
 | 
			
		||||
  App { appDraw     = \st -> [ui dimAttrs st]
 | 
			
		||||
  , appHandleEvent  = eventHandler
 | 
			
		||||
  , appStartEvent   = return ()
 | 
			
		||||
  , appAttrMap      = const attrs
 | 
			
		||||
  , appChooseCursor = showFirstCursor
 | 
			
		||||
@ -312,6 +521,7 @@ defaultAttributes no_color = attrMap
 | 
			
		||||
  , (attrName "day"               , Vty.defAttr `withForeColor` Vty.blue)
 | 
			
		||||
  , (attrName "help"              , Vty.defAttr `withStyle`     Vty.italic)
 | 
			
		||||
  , (attrName "hooray"            , Vty.defAttr `withForeColor` Vty.brightWhite)
 | 
			
		||||
  , (buttonSelectedAttr           , Vty.defAttr `withBackColor` Vty.brightWhite)
 | 
			
		||||
  ]
 | 
			
		||||
  where
 | 
			
		||||
    withForeColor | no_color  = const
 | 
			
		||||
@ -332,56 +542,51 @@ dimAttributes no_color = attrMap
 | 
			
		||||
    withBackColor | no_color  = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
 | 
			
		||||
                  | otherwise = Vty.withBackColor
 | 
			
		||||
 | 
			
		||||
eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState ()
 | 
			
		||||
eventHandler st@BrickState{..} ev = do
 | 
			
		||||
eventHandler :: BrickEvent String e -> EventM String BrickState ()
 | 
			
		||||
eventHandler ev = do
 | 
			
		||||
  AppState { keyBindings = kb } <- liftIO $ readIORef settings'
 | 
			
		||||
  case ev of
 | 
			
		||||
    (MouseDown _ Vty.BScrollUp _ _) ->
 | 
			
		||||
      put (BrickState { appState = moveCursor 1 appState Up, .. })
 | 
			
		||||
    (MouseDown _ Vty.BScrollDown _ _) ->
 | 
			
		||||
      put (BrickState { appState = moveCursor 1 appState Down, .. })
 | 
			
		||||
    (VtyEvent (Vty.EvResize _ _)) -> put st
 | 
			
		||||
    (VtyEvent (Vty.EvKey Vty.KUp [])) ->
 | 
			
		||||
      put BrickState{ appState = moveCursor 1 appState Up, .. }
 | 
			
		||||
    (VtyEvent (Vty.EvKey Vty.KDown [])) ->
 | 
			
		||||
      put BrickState{ appState = moveCursor 1 appState Down, .. }
 | 
			
		||||
    (VtyEvent (Vty.EvKey key mods)) ->
 | 
			
		||||
      case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of
 | 
			
		||||
        Nothing -> put st
 | 
			
		||||
        Just (_, _, handler) -> handler st
 | 
			
		||||
    _ -> put st
 | 
			
		||||
    (MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up
 | 
			
		||||
    (MouseDown _ Vty.BScrollDown _ _) -> appState %= moveCursor 1 Down
 | 
			
		||||
    (VtyEvent (Vty.EvResize _ _)) -> pure ()
 | 
			
		||||
    (VtyEvent (Vty.EvKey Vty.KUp _)) -> appState %= moveCursor 1 Up
 | 
			
		||||
    (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 Down
 | 
			
		||||
    (VtyEvent (Vty.EvKey key _)) ->
 | 
			
		||||
      case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
 | 
			
		||||
        Nothing -> pure ()
 | 
			
		||||
        Just (_, _, handler) -> handler
 | 
			
		||||
    _ -> pure ()
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
 | 
			
		||||
moveCursor steps ais@BrickInternalState{..} direction =
 | 
			
		||||
  let newIx = if direction == Down then ix + steps else ix - steps
 | 
			
		||||
  in  case clr !? newIx of
 | 
			
		||||
        Just _  -> BrickInternalState { ix = newIx, .. }
 | 
			
		||||
moveCursor :: Int -> Direction -> BrickInternalState -> BrickInternalState
 | 
			
		||||
moveCursor steps direction ais@BrickInternalState{..} =
 | 
			
		||||
  let newIx = if direction == Down then _ix + steps else _ix - steps
 | 
			
		||||
  in  case _clr !? newIx of
 | 
			
		||||
        Just _  -> ais & ix .~ newIx
 | 
			
		||||
        Nothing -> ais
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | 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
 | 
			
		||||
             => (BrickState
 | 
			
		||||
                 -> (Int, ListResult)
 | 
			
		||||
                 -> ReaderT AppState IO (Either String a))
 | 
			
		||||
             -> BrickState
 | 
			
		||||
             => ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
 | 
			
		||||
             -> EventM n BrickState ()
 | 
			
		||||
withIOAction action as = case listSelectedElement' (appState as) of
 | 
			
		||||
  Nothing      -> put as
 | 
			
		||||
  Just (ix, e) -> do
 | 
			
		||||
    suspendAndResume $ do
 | 
			
		||||
      settings <- readIORef settings'
 | 
			
		||||
      flip runReaderT settings $ action as (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
 | 
			
		||||
withIOAction action = do
 | 
			
		||||
  as <- get
 | 
			
		||||
  case listSelectedElement' (view appState as) of
 | 
			
		||||
    Nothing      -> pure ()
 | 
			
		||||
    Just (curr_ix, e) -> do
 | 
			
		||||
      suspendAndResume $ do
 | 
			
		||||
        settings <- readIORef settings'
 | 
			
		||||
        flip runReaderT settings $ action (curr_ix, e) >>= \case
 | 
			
		||||
          Left  err -> liftIO $ putStrLn ("Error: " <> err)
 | 
			
		||||
          Right _   -> liftIO $ putStrLn "Success"
 | 
			
		||||
        getAppData Nothing >>= \case
 | 
			
		||||
          Right data' -> do
 | 
			
		||||
            putStrLn "Press enter to continue"
 | 
			
		||||
            _ <- getLine
 | 
			
		||||
            pure (updateList data' as)
 | 
			
		||||
          Left err -> throwIO $ userError err
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
-- | Update app data and list internal state based on new evidence.
 | 
			
		||||
@ -389,11 +594,11 @@ withIOAction action as = case listSelectedElement' (appState as) of
 | 
			
		||||
-- and @BrickSettings@.
 | 
			
		||||
updateList :: BrickData -> BrickState -> BrickState
 | 
			
		||||
updateList appD BrickState{..} =
 | 
			
		||||
  let newInternalState = constructList appD appSettings (Just appState)
 | 
			
		||||
  in  BrickState { appState    = newInternalState
 | 
			
		||||
                 , appData     = appD
 | 
			
		||||
                 , appSettings = appSettings
 | 
			
		||||
                 , appKeys     = appKeys
 | 
			
		||||
  let newInternalState = constructList appD _appSettings (Just _appState)
 | 
			
		||||
  in  BrickState { _appState    = newInternalState
 | 
			
		||||
                 , _appData     = appD
 | 
			
		||||
                 , _appSettings = _appSettings
 | 
			
		||||
                 , _appKeys     = _appKeys
 | 
			
		||||
                 }
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
@ -402,11 +607,12 @@ constructList :: BrickData
 | 
			
		||||
              -> Maybe BrickInternalState
 | 
			
		||||
              -> BrickInternalState
 | 
			
		||||
constructList appD appSettings =
 | 
			
		||||
  replaceLR (filterVisible (showAllVersions appSettings))
 | 
			
		||||
            (lr appD)
 | 
			
		||||
  replaceLR (filterVisible (_showAllVersions appSettings)
 | 
			
		||||
                           (_showAllTools appSettings))
 | 
			
		||||
            (_lr appD)
 | 
			
		||||
 | 
			
		||||
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
 | 
			
		||||
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
 | 
			
		||||
listSelectedElement' BrickInternalState{..} = fmap (_ix, ) $ _clr !? _ix
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
selectLatest :: Vector ListResult -> Int
 | 
			
		||||
@ -444,11 +650,10 @@ filterVisible v e | lInstalled e = True
 | 
			
		||||
                                  (Nightly `notElem` lTag e)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
 | 
			
		||||
         => BrickState
 | 
			
		||||
         -> (Int, ListResult)
 | 
			
		||||
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
 | 
			
		||||
         => (Int, ListResult)
 | 
			
		||||
         -> m (Either String ())
 | 
			
		||||
install' _ (_, ListResult {..}) = do
 | 
			
		||||
install' (_, ListResult {..}) = do
 | 
			
		||||
  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 | 
			
		||||
 | 
			
		||||
  let run =
 | 
			
		||||
@ -530,10 +735,9 @@ install' _ (_, ListResult {..}) = do
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
 | 
			
		||||
     => BrickState
 | 
			
		||||
     -> (Int, ListResult)
 | 
			
		||||
     => (Int, ListResult)
 | 
			
		||||
     -> m (Either String ())
 | 
			
		||||
set' bs input@(_, ListResult {..}) = do
 | 
			
		||||
set' input@(_, ListResult {..}) = do
 | 
			
		||||
  settings <- liftIO $ readIORef settings'
 | 
			
		||||
 | 
			
		||||
  let run =
 | 
			
		||||
@ -588,12 +792,12 @@ set' bs input@(_, ListResult {..}) = do
 | 
			
		||||
              promptAnswer <- getUserPromptResponse userPrompt
 | 
			
		||||
              case promptAnswer of
 | 
			
		||||
                PromptYes -> do
 | 
			
		||||
                  res <- install' bs input
 | 
			
		||||
                  res <- install' input
 | 
			
		||||
                  case res of
 | 
			
		||||
                    (Left err) -> pure $ Left err
 | 
			
		||||
                    (Right _) -> do
 | 
			
		||||
                      logInfo "Setting now..."
 | 
			
		||||
                      set' bs input
 | 
			
		||||
                      set' input
 | 
			
		||||
 | 
			
		||||
                PromptNo -> pure $ Left (prettyHFError e)
 | 
			
		||||
              where
 | 
			
		||||
@ -608,10 +812,9 @@ set' bs input@(_, ListResult {..}) = do
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
 | 
			
		||||
     => BrickState
 | 
			
		||||
     -> (Int, ListResult)
 | 
			
		||||
     => (Int, ListResult)
 | 
			
		||||
     -> m (Either String ())
 | 
			
		||||
del' _ (_, ListResult {..}) = do
 | 
			
		||||
del' (_, ListResult {..}) = do
 | 
			
		||||
  AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 | 
			
		||||
 | 
			
		||||
  let run = runE @'[NotInstalled, UninstallFailed]
 | 
			
		||||
@ -635,10 +838,9 @@ del' _ (_, ListResult {..}) = do
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
changelog' :: (MonadReader AppState m, MonadIO m)
 | 
			
		||||
           => BrickState
 | 
			
		||||
           -> (Int, ListResult)
 | 
			
		||||
           => (Int, ListResult)
 | 
			
		||||
           -> m (Either String ())
 | 
			
		||||
changelog' _ (_, ListResult {..}) = do
 | 
			
		||||
changelog' (_, ListResult {..}) = do
 | 
			
		||||
  AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
 | 
			
		||||
  case getChangeLog dls lTool (ToolVersion lVer) of
 | 
			
		||||
    Nothing -> pure $ Left $
 | 
			
		||||
@ -671,7 +873,6 @@ settings' = unsafePerformIO $ do
 | 
			
		||||
                      loggerConfig
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
brickMain :: AppState
 | 
			
		||||
          -> IO ()
 | 
			
		||||
brickMain s = do
 | 
			
		||||
@ -695,7 +896,7 @@ brickMain s = do
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
defaultAppSettings :: BrickSettings
 | 
			
		||||
defaultAppSettings = BrickSettings { showAllVersions = False }
 | 
			
		||||
defaultAppSettings = BrickSettings { _showAllVersions = False, _showAllTools = False }
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
getGHCupInfo :: IO (Either String GHCupInfo)
 | 
			
		||||
@ -724,3 +925,4 @@ getAppData mgi = runExceptT $ do
 | 
			
		||||
  flip runReaderT settings $ do
 | 
			
		||||
    lV <- listVersions Nothing [] False True (Nothing, Nothing)
 | 
			
		||||
    pure $ BrickData (reverse lV)
 | 
			
		||||
 | 
			
		||||
 | 
			
		||||
@ -327,6 +327,8 @@ executable ghcup
 | 
			
		||||
      , brick         ^>=2.1
 | 
			
		||||
      , transformers  ^>=0.5
 | 
			
		||||
      , vty           ^>=6.0
 | 
			
		||||
      , unix          ^>=2.7
 | 
			
		||||
      , optics        ^>=0.4
 | 
			
		||||
 | 
			
		||||
  if os(windows)
 | 
			
		||||
    cpp-options: -DIS_WINDOWS
 | 
			
		||||
@ -352,7 +354,7 @@ test-suite ghcup-test
 | 
			
		||||
  default-language:   Haskell2010
 | 
			
		||||
  default-extensions:
 | 
			
		||||
    LambdaCase
 | 
			
		||||
    MultiWayIf
 | 
			
		||||
    MultiWayIf++-
 | 
			
		||||
    PackageImports
 | 
			
		||||
    RecordWildCards
 | 
			
		||||
    ScopedTypeVariables
 | 
			
		||||
 | 
			
		||||
		Loading…
	
		Reference in New Issue
	
	Block a user