ghcup-hs/lib-tui/GHCup/Brick/Widgets/Navigation.hs
2024-03-13 18:14:36 +01:00

148 lines
6.5 KiB
Haskell

{-# 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 ' ')