Put separators between tools
This commit is contained in:
parent
34ceaa0823
commit
7afd262b1b
@ -1,10 +1,11 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TypeApplications #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module BrickMain where
|
||||
|
||||
@ -20,7 +21,10 @@ import Brick
|
||||
import Brick.Widgets.Border
|
||||
import Brick.Widgets.Border.Style
|
||||
import Brick.Widgets.Center
|
||||
import Brick.Widgets.List
|
||||
import Brick.Widgets.List ( listSelectedFocusedAttr
|
||||
, listSelectedAttr
|
||||
, listAttr
|
||||
)
|
||||
#if !defined(TAR)
|
||||
import Codec.Archive
|
||||
#endif
|
||||
@ -35,7 +39,9 @@ import Data.Maybe
|
||||
import Data.Char
|
||||
import Data.IORef
|
||||
import Data.String.Interpolate
|
||||
import Data.Vector ( Vector )
|
||||
import Data.Vector ( Vector
|
||||
, (!?)
|
||||
)
|
||||
import Data.Versions hiding ( str )
|
||||
import Haskus.Utils.Variant.Excepts
|
||||
import Prelude hiding ( appendFile )
|
||||
@ -46,25 +52,35 @@ import URI.ByteString
|
||||
import qualified Data.Text as T
|
||||
import qualified Graphics.Vty as Vty
|
||||
import qualified Data.Vector as V
|
||||
import qualified Brick.Widgets.List as L
|
||||
|
||||
import Lens.Micro ( (^.) )
|
||||
|
||||
|
||||
data AppData = AppData {
|
||||
lr :: LR
|
||||
|
||||
data AppData = AppData
|
||||
{ lr :: [ListResult]
|
||||
, dls :: GHCupDownloads
|
||||
, pfreq :: PlatformRequest
|
||||
} deriving Show
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data AppSettings = AppSettings {
|
||||
showAll :: Bool
|
||||
} deriving Show
|
||||
data AppSettings = AppSettings
|
||||
{ showAll :: Bool
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data AppState = AppState {
|
||||
appData :: AppData
|
||||
data AppInternalState = AppInternalState
|
||||
{ clr :: Vector ListResult
|
||||
, ix :: Int
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data AppState = AppState
|
||||
{ appData :: AppData
|
||||
, appSettings :: AppSettings
|
||||
} deriving Show
|
||||
|
||||
type LR = GenericList String Vector ListResult
|
||||
, appState :: AppInternalState
|
||||
}
|
||||
deriving Show
|
||||
|
||||
|
||||
keyHandlers :: [ ( Char
|
||||
@ -82,27 +98,22 @@ keyHandlers =
|
||||
, (\AppSettings {..} ->
|
||||
if showAll then "Hide old versions" else "Show all versions"
|
||||
)
|
||||
, (\AppState {..} ->
|
||||
let newAppSettings =
|
||||
appSettings { showAll = not . showAll $ appSettings }
|
||||
in continue (AppState appData newAppSettings)
|
||||
)
|
||||
, hideShowHandler
|
||||
)
|
||||
]
|
||||
where
|
||||
hideShowHandler (AppState {..}) =
|
||||
let newAppSettings = appSettings { showAll = not . showAll $ appSettings }
|
||||
newInternalState = constructList appData newAppSettings (Just appState)
|
||||
in continue (AppState appData newAppSettings newInternalState)
|
||||
|
||||
|
||||
ui :: AppState -> Widget String
|
||||
ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}) } =
|
||||
( padBottom Max
|
||||
ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..}
|
||||
= ( padBottom Max
|
||||
$ ( withBorderStyle unicode
|
||||
$ borderWithLabel (str "GHCup")
|
||||
$ ( center
|
||||
$ (header <=> hBorder <=> renderList
|
||||
renderItem
|
||||
True
|
||||
(L.listReverse lr)
|
||||
)
|
||||
)
|
||||
$ (center $ (header <=> hBorder <=> renderList' appState))
|
||||
)
|
||||
)
|
||||
<=> footer
|
||||
@ -121,7 +132,8 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}) } =
|
||||
<+> (minHSize 15 $ str "Version")
|
||||
<+> (padLeft (Pad 1) $ minHSize 25 $ str "Tags")
|
||||
<+> (padLeft (Pad 5) $ str "Notes")
|
||||
renderItem b listResult@(ListResult {..}) =
|
||||
renderList' = withDefAttr listAttr . drawListElements renderItem True
|
||||
renderItem _ b listResult@(ListResult {..}) =
|
||||
let marks = if
|
||||
| lSet -> (withAttr "set" $ str "✔✔")
|
||||
| lInstalled -> (withAttr "installed" $ str "✓ ")
|
||||
@ -132,19 +144,17 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}) } =
|
||||
dim = if lNoBindist
|
||||
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
|
||||
else id
|
||||
active = if b then withAttr "active" else id
|
||||
in dim
|
||||
active = if b then forceAttr "active" else id
|
||||
in active $ dim
|
||||
( marks
|
||||
<+> (( padLeft (Pad 2)
|
||||
$ active
|
||||
$ minHSize 6
|
||||
$ (str (fmap toLower . show $ lTool))
|
||||
$ (printTool lTool)
|
||||
)
|
||||
)
|
||||
<+> (minHSize 15 $ active $ (str ver))
|
||||
<+> (minHSize 15 $ (str ver))
|
||||
<+> (let l = catMaybes . fmap printTag $ sort lTag
|
||||
in padLeft (Pad 1) $ minHSize 25 $
|
||||
if null l
|
||||
in padLeft (Pad 1) $ minHSize 25 $ if null l
|
||||
then emptyWidget
|
||||
else foldr1 (\x y -> x <+> str "," <+> y) l
|
||||
)
|
||||
@ -163,13 +173,93 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}) } =
|
||||
printTag Old = Nothing
|
||||
printTag (UnknownTag t) = Just $ str t
|
||||
|
||||
printTool Cabal = str "cabal"
|
||||
printTool GHC = str "GHC"
|
||||
printTool GHCup = str "GHCup"
|
||||
printTool HLS = str "HLS"
|
||||
|
||||
printNotes ListResult {..} =
|
||||
(if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
|
||||
)
|
||||
++ (if fromSrc then [withAttr "compiled" $ str "compiled"] else mempty)
|
||||
++ (if lStray then [withAttr "stray" $ str "stray"] else mempty)
|
||||
|
||||
-- | Draws the list elements.
|
||||
--
|
||||
-- Evaluates the underlying container up to, and a bit beyond, the
|
||||
-- selected element. The exact amount depends on available height
|
||||
-- for drawing and 'listItemHeight'. At most, it will evaluate up to
|
||||
-- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the
|
||||
-- available height.
|
||||
drawListElements :: (Int -> Bool -> ListResult -> Widget String)
|
||||
-> Bool
|
||||
-> AppInternalState
|
||||
-> Widget String
|
||||
drawListElements drawElem foc is@(AppInternalState clr ix) =
|
||||
Widget Greedy Greedy $ do
|
||||
c <- getContext
|
||||
|
||||
-- Take (numPerHeight * 2) elements, or whatever is left
|
||||
let
|
||||
es = slice start (numPerHeight * 2) clr
|
||||
|
||||
-- number of separators we insert between tools
|
||||
seps =
|
||||
let n = length . nub . fmap lTool . V.toList $ clr
|
||||
in if n < 0 then 0 else n - 1
|
||||
|
||||
start = max 0 $ ix - numPerHeight + 1
|
||||
|
||||
listItemHeight = 1
|
||||
listSelected = fmap fst $ listSelectedElement' is
|
||||
|
||||
-- The number of items to show is the available height
|
||||
-- divided by the item height...
|
||||
initialNumPerHeight = (c ^. availHeightL - seps) `div` listItemHeight
|
||||
-- ... but if the available height leaves a remainder of
|
||||
-- an item height then we need to ensure that we render an
|
||||
-- extra item to show a partial item at the top or bottom to
|
||||
-- give the expected result when an item is more than one
|
||||
-- row high. (Example: 5 rows available with item height
|
||||
-- of 3 yields two items: one fully rendered, the other
|
||||
-- rendered with only its top 2 or bottom 2 rows visible,
|
||||
-- depending on how the viewport state changes.)
|
||||
numPerHeight =
|
||||
initialNumPerHeight
|
||||
+ if initialNumPerHeight * listItemHeight == c ^. availHeightL
|
||||
then 0
|
||||
else 1
|
||||
|
||||
off = start * listItemHeight
|
||||
|
||||
drawnElements = flip V.imap es $ \i' e ->
|
||||
let j = i' + start
|
||||
|
||||
-- a separator between tool sections
|
||||
addSeparator w = case es !? (i' - 1) of
|
||||
Just e' | lTool e' /= lTool e ->
|
||||
hBorder <=> w
|
||||
_ -> w
|
||||
|
||||
isSelected = Just j == listSelected
|
||||
elemWidget = drawElem j isSelected e
|
||||
selItemAttr = if foc
|
||||
then withDefAttr listSelectedFocusedAttr
|
||||
else withDefAttr listSelectedAttr
|
||||
makeVisible = if isSelected then visible . selItemAttr else id
|
||||
in addSeparator $ makeVisible elemWidget
|
||||
|
||||
render
|
||||
$ viewport "GHCup" Vertical
|
||||
$ translateBy (Location (0, off))
|
||||
$ vBox
|
||||
$ V.toList drawnElements
|
||||
|
||||
slice :: Int {- ^ start index -}
|
||||
-> Int {- ^ length -}
|
||||
-> Vector a
|
||||
-> Vector a
|
||||
slice i' n = fst . V.splitAt n . snd . V.splitAt i'
|
||||
|
||||
minHSize :: Int -> Widget n -> Widget n
|
||||
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
|
||||
@ -213,43 +303,23 @@ eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
|
||||
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
|
||||
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
|
||||
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
|
||||
eventHandler AppState { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KUp) _))
|
||||
= continue (AppState (AppData (listMoveUp lr) dls pfreq) appSettings)
|
||||
eventHandler AppState { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KDown) _))
|
||||
= continue (AppState (AppData (listMoveDown lr) dls pfreq) appSettings)
|
||||
eventHandler as@(AppState appD appS) (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
|
||||
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
|
||||
continue (AppState { appState = (moveCursor appState Up), .. })
|
||||
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
|
||||
continue (AppState { appState = (moveCursor appState Down), .. })
|
||||
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
|
||||
case find (\(c', _, _) -> c' == c) keyHandlers of
|
||||
Nothing -> continue as
|
||||
Just ('a', _, handler) ->
|
||||
if (not $ showAll appS) -- it's not swapped to `showAll` yet, but it will in the handler
|
||||
then do
|
||||
newAppData <- liftIO $ replaceLR (\_ -> True) appD
|
||||
handler (AppState (selectLatest newAppData) appS)
|
||||
else do -- hide old versions
|
||||
newAppData <- liftIO $ replaceLR (filterVisible (not $ showAll appS)) appD
|
||||
handler (AppState (selectLatest newAppData) appS)
|
||||
Just (_, _, handler) -> handler as
|
||||
eventHandler st _ = continue st
|
||||
|
||||
|
||||
replaceLR :: (ListResult -> Bool) -> AppData -> IO AppData
|
||||
replaceLR filterF (AppData {..}) = do
|
||||
settings <- liftIO $ readIORef settings'
|
||||
l <- liftIO $ readIORef logger'
|
||||
let runLogger = myLoggerT l
|
||||
lV <- runLogger
|
||||
. flip runReaderT settings
|
||||
. fmap (V.fromList . filter filterF)
|
||||
. listVersions dls Nothing Nothing
|
||||
$ pfreq
|
||||
pure $ AppData { lr = L.listReplace lV Nothing $ lr, .. }
|
||||
|
||||
|
||||
filterVisible :: Bool -> ListResult -> Bool
|
||||
filterVisible showAll e
|
||||
| lInstalled e = True
|
||||
| showAll = True
|
||||
| otherwise = not (elem Old (lTag e))
|
||||
moveCursor :: AppInternalState -> Direction -> AppInternalState
|
||||
moveCursor ais@(AppInternalState {..}) direction =
|
||||
let newIx = if direction == Down then ix + 1 else ix - 1
|
||||
in case clr !? newIx of
|
||||
Just _ -> AppInternalState { ix = newIx, .. }
|
||||
Nothing -> ais
|
||||
|
||||
|
||||
-- | Suspend the current UI and run an IO action in terminal. If the
|
||||
@ -257,45 +327,92 @@ filterVisible showAll e
|
||||
withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
|
||||
-> AppState
|
||||
-> EventM n (Next AppState)
|
||||
withIOAction action as = case listSelectedElement (lr . appData $ as) of
|
||||
withIOAction action as = case listSelectedElement' (appState as) of
|
||||
Nothing -> continue as
|
||||
Just (ix, e) -> suspendAndResume $ do
|
||||
action as (ix, e) >>= \case
|
||||
Left err -> putStrLn $ ("Error: " <> err)
|
||||
Right _ -> putStrLn "Success"
|
||||
apps <-
|
||||
(fmap . fmap)
|
||||
(\AppData {..} -> AppState
|
||||
{ appData = AppData { lr = listMoveTo ix lr, .. }
|
||||
, appSettings = (appSettings as)
|
||||
}
|
||||
)
|
||||
$ getAppData Nothing (pfreq . appData $ as)
|
||||
case apps of
|
||||
Right nas -> do
|
||||
getAppData Nothing (pfreq . appData $ as) >>= \case
|
||||
Right data' -> do
|
||||
putStrLn "Press enter to continue"
|
||||
_ <- getLine
|
||||
pure nas
|
||||
pure (updateList data' as)
|
||||
Left err -> throwIO $ userError err
|
||||
|
||||
|
||||
-- | Update app data and list internal state based on new evidence.
|
||||
-- This synchronises @AppInternalState@ with @AppData@
|
||||
-- and @AppSettings@.
|
||||
updateList :: AppData -> AppState -> AppState
|
||||
updateList appD (AppState {..}) =
|
||||
let newInternalState = constructList appD appSettings (Just appState)
|
||||
in AppState { appState = newInternalState
|
||||
, appData = appD
|
||||
, appSettings = appSettings
|
||||
}
|
||||
|
||||
|
||||
constructList :: AppData
|
||||
-> AppSettings
|
||||
-> Maybe AppInternalState
|
||||
-> AppInternalState
|
||||
constructList appD appSettings mapp =
|
||||
replaceLR (filterVisible (showAll appSettings)) (lr appD) mapp
|
||||
|
||||
listSelectedElement' :: AppInternalState -> Maybe (Int, ListResult)
|
||||
listSelectedElement' (AppInternalState {..}) = fmap (ix, ) $ clr !? ix
|
||||
|
||||
|
||||
selectLatest :: Vector ListResult -> Int
|
||||
selectLatest v =
|
||||
case V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) v of
|
||||
Just ix -> ix
|
||||
Nothing -> 0
|
||||
|
||||
|
||||
-- | 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 AppInternalState
|
||||
-> AppInternalState
|
||||
replaceLR filterF lr s =
|
||||
let oldElem = s >>= listSelectedElement'
|
||||
newVec = V.fromList . filter filterF $ lr
|
||||
newSelected =
|
||||
case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
|
||||
Just ix -> ix
|
||||
Nothing -> selectLatest newVec
|
||||
in AppInternalState newVec newSelected
|
||||
where
|
||||
toolEqual e1 e2 =
|
||||
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
|
||||
|
||||
|
||||
filterVisible :: Bool -> ListResult -> Bool
|
||||
filterVisible showAll e | lInstalled e = True
|
||||
| showAll = True
|
||||
| otherwise = not (elem Old (lTag e))
|
||||
|
||||
|
||||
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
|
||||
install' AppState { appData = AppData {..} } (_, ListResult {..}) = do
|
||||
settings <- readIORef settings'
|
||||
l <- readIORef logger'
|
||||
let runLogger = myLoggerT l
|
||||
|
||||
let
|
||||
run =
|
||||
let run =
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runResourceT
|
||||
. runE
|
||||
@'[ AlreadyInstalled
|
||||
, UnknownArchive
|
||||
#if !defined(TAR)
|
||||
, ArchiveResult
|
||||
#endif
|
||||
, UnknownArchive
|
||||
, FileDoesNotExistError
|
||||
, CopyError
|
||||
, NoDownload
|
||||
@ -413,7 +530,12 @@ logger' = unsafePerformIO
|
||||
)
|
||||
|
||||
|
||||
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
|
||||
brickMain :: Settings
|
||||
-> Maybe URI
|
||||
-> LoggerConfig
|
||||
-> GHCupDownloads
|
||||
-> PlatformRequest
|
||||
-> IO ()
|
||||
brickMain s muri l av pfreq' = do
|
||||
writeIORef uri' muri
|
||||
writeIORef settings' s
|
||||
@ -423,24 +545,21 @@ brickMain s muri l av pfreq' = do
|
||||
|
||||
eAppData <- getAppData (Just av) pfreq'
|
||||
case eAppData of
|
||||
Right ad -> defaultMain app (AppState (selectLatest ad) defaultAppSettings) $> ()
|
||||
Right ad ->
|
||||
defaultMain
|
||||
app
|
||||
(AppState ad
|
||||
defaultAppSettings
|
||||
(constructList ad defaultAppSettings Nothing)
|
||||
)
|
||||
$> ()
|
||||
Left e -> do
|
||||
runLogger ($(logError) [i|Error building app state: #{show e}|])
|
||||
exitWith $ ExitFailure 2
|
||||
|
||||
|
||||
selectLatest :: AppData -> AppData
|
||||
selectLatest (AppData {..}) =
|
||||
(\ix -> AppData { lr = listMoveTo ix lr, .. } )
|
||||
. fromJust
|
||||
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
|
||||
$ (listElements lr)
|
||||
|
||||
|
||||
defaultAppSettings :: AppSettings
|
||||
defaultAppSettings = AppSettings {
|
||||
showAll = False
|
||||
}
|
||||
defaultAppSettings = AppSettings { showAll = False }
|
||||
|
||||
|
||||
getDownloads' :: IO (Either String GHCupDownloads)
|
||||
@ -453,16 +572,19 @@ getDownloads' = do
|
||||
r <-
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
. runE
|
||||
@'[JSONError, DownloadFailed, FileDoesNotExistError]
|
||||
$ fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)
|
||||
. runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
|
||||
$ fmap _ghcupDownloads
|
||||
$ liftE
|
||||
$ getDownloadsF (maybe GHCupURL OwnSource muri)
|
||||
|
||||
case r of
|
||||
VRight a -> pure $ Right a
|
||||
VLeft e -> pure $ Left [i|#{e}|]
|
||||
|
||||
|
||||
getAppData :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppData)
|
||||
getAppData :: Maybe GHCupDownloads
|
||||
-> PlatformRequest
|
||||
-> IO (Either String AppData)
|
||||
getAppData mg pfreq' = do
|
||||
settings <- readIORef settings'
|
||||
l <- readIORef logger'
|
||||
@ -470,12 +592,10 @@ getAppData mg pfreq' = do
|
||||
|
||||
r <- maybe getDownloads' (pure . Right) mg
|
||||
|
||||
runLogger
|
||||
. flip runReaderT settings
|
||||
$ do
|
||||
runLogger . flip runReaderT settings $ do
|
||||
case r of
|
||||
Right dls -> do
|
||||
lV <- listVersions dls Nothing Nothing pfreq'
|
||||
pure $ Right $ (AppData (list "Tool versions"
|
||||
(V.fromList . filter (filterVisible (showAll defaultAppSettings)) $ lV) 1) dls pfreq')
|
||||
pure $ Right $ (AppData (reverse lV) dls pfreq')
|
||||
Left e -> pure $ Left [i|#{e}|]
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user