Put separators between tools

app/ghcup/BrickMain.hs

@@ -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
-  , dls :: GHCupDownloads
+  { lr    :: [ListResult]
+  , dls   :: GHCupDownloads
   , pfreq :: PlatformRequest
-} deriving Show
+  }
+  deriving Show
 
-data AppSettings = AppSettings {
+data AppSettings = AppSettings
-    showAll :: Bool
+  { showAll :: Bool
-} deriving Show
+  }
+  deriving Show
 
-data AppState = AppState {
+data AppInternalState = AppInternalState
-    appData :: AppData
+  { clr :: Vector ListResult
+  , ix  :: Int
+  }
+  deriving Show
+
+data AppState = AppState
+  { appData     :: AppData
   , appSettings :: AppSettings
-} deriving Show
+  , appState    :: AppInternalState
-
+  }
-type LR = GenericList String Vector ListResult
+  deriving Show
 
 
 keyHandlers :: [ ( Char
@@ -82,27 +98,22 @@ keyHandlers =
     , (\AppSettings {..} ->
         if showAll then "Hide old versions" else "Show all versions"
       )
-    , (\AppState {..} ->
+    , hideShowHandler
-        let newAppSettings =
-                appSettings { showAll = not . showAll $ appSettings }
-        in  continue (AppState appData newAppSettings)
-      )
     )
   ]
+ 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 {..}) } =
+ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}), ..}
-  ( padBottom Max
+  = ( padBottom Max
     $ ( withBorderStyle unicode
       $ borderWithLabel (str "GHCup")
-      $ ( center
+      $ (center $ (header <=> hBorder <=> renderList' appState))
-        $ (header <=> hBorder <=> renderList
-            renderItem
-            True
-            (L.listReverse lr)
-          )
-        )
       )
     )
     <=> 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,21 +144,19 @@ 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
+        active = if b then forceAttr "active" else id
-    in  dim
+    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 $
+               in  padLeft (Pad 1) $ minHSize 25 $ if null l
-                  if null l
+                     then emptyWidget
-                  then emptyWidget
+                     else foldr1 (\x y -> x <+> str "," <+> y) l
-                  else foldr1 (\x y -> x <+> str "," <+> y) l
               )
           <+> ( padLeft (Pad 5)
               $ let notes = printNotes listResult
@@ -156,12 +166,17 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}) } =
               )
           )
 
-  printTag Recommended        = Just $ withAttr "recommended" $ str "recommended"
+  printTag Recommended    = Just $ withAttr "recommended" $ str "recommended"
-  printTag Latest             = Just $ withAttr "latest" $ str "latest"
+  printTag Latest         = Just $ withAttr "latest" $ str "latest"
-  printTag Prerelease         = Just $ withAttr "prerelease" $ str "prerelease"
+  printTag Prerelease     = Just $ withAttr "prerelease" $ str "prerelease"
-  printTag (Base       pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
+  printTag (Base pvp'')   = Just $ str ("base-" ++ T.unpack (prettyPVP pvp''))
-  printTag Old                = Nothing
+  printTag Old            = Nothing
-  printTag (UnknownTag t    ) = Just $ str t
+  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
@@ -169,7 +184,82 @@ ui AppState { appData = AppData {..}, appSettings = as@(AppSettings {..}) } =
       ++ (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) _))
+eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
-  = continue (AppState (AppData (listMoveUp lr) dls pfreq) appSettings)
+  continue (AppState { appState = (moveCursor appState Up), .. })
-eventHandler AppState { appData = AppData {..}, ..} (VtyEvent (Vty.EvKey (Vty.KDown) _))
+eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
-  = continue (AppState (AppData (listMoveDown lr) dls pfreq) appSettings)
+  continue (AppState { appState = (moveCursor appState Down), .. })
-eventHandler as@(AppState appD appS) (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
+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
+moveCursor :: AppInternalState -> Direction -> AppInternalState
-replaceLR filterF (AppData {..}) = do
+moveCursor ais@(AppInternalState {..}) direction =
-  settings <- liftIO $ readIORef settings'
+  let newIx = if direction == Down then ix + 1 else ix - 1
-  l        <- liftIO $ readIORef logger'
+  in  case clr !? newIx of
-  let runLogger = myLoggerT l
+        Just _  -> AppInternalState { ix = newIx, .. }
-  lV <- runLogger
+        Nothing -> ais
-    . 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))
 
 
 -- | Suspend the current UI and run an IO action in terminal. If the
@@ -257,56 +327,103 @@ 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 <-
+    getAppData Nothing (pfreq . appData $ as) >>= \case
-      (fmap . fmap)
+      Right data' -> do
-          (\AppData {..} -> AppState
-            { appData     = AppData { lr = listMoveTo ix lr, .. }
-            , appSettings = (appSettings as)
-            }
-          )
-        $ getAppData Nothing (pfreq . appData $ as)
-    case apps of
-      Right nas -> 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
+install' AppState { appData = AppData {..} } (_, ListResult {..}) = do
   settings <- readIORef settings'
   l        <- readIORef logger'
   let runLogger = myLoggerT l
 
-  let
+  let run =
-    run =
+        runLogger
-      runLogger
+          . flip runReaderT settings
-        . flip runReaderT settings
+          . runResourceT
-        . runResourceT
+          . runE
-        . runE
+            @'[ AlreadyInstalled
-          @'[AlreadyInstalled
-            , UnknownArchive
 #if !defined(TAR)
-            , ArchiveResult
+              , ArchiveResult
 #endif
-            , FileDoesNotExistError
+              , UnknownArchive
-            , CopyError
+              , FileDoesNotExistError
-            , NoDownload
+              , CopyError
-            , NotInstalled
+              , NoDownload
-            , BuildFailed
+              , NotInstalled
-            , TagNotFound
+              , BuildFailed
-            , DigestError
+              , TagNotFound
-            , DownloadFailed
+              , DigestError
-            , NoUpdate
+              , DownloadFailed
-            , TarDirDoesNotExist
+              , NoUpdate
-            ]
+              , TarDirDoesNotExist
+              ]
 
   (run $ do
       case lTool of
@@ -336,7 +453,7 @@ set' _ (_, ListResult {..}) = do
   let run =
         runLogger
           . flip runReaderT settings
-          . runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
+          . runE @'[FileDoesNotExistError , NotInstalled , TagNotFound]
 
   (run $ do
       case lTool of
@@ -371,15 +488,15 @@ del' _ (_, ListResult {..}) = do
 
 
 changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
-changelog' AppState { appData = AppData {..}} (_, ListResult {..}) = do
+changelog' AppState { appData = AppData {..} } (_, ListResult {..}) = do
   case getChangeLog dls lTool (Left lVer) of
     Nothing -> pure $ Left
       [i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
     Just uri -> do
       let cmd = case _rPlatform pfreq of
-                  Darwin  -> "open"
+            Darwin  -> "open"
-                  Linux _ -> "xdg-open"
+            Linux _ -> "xdg-open"
-                  FreeBSD -> "xdg-open"
+            FreeBSD -> "xdg-open"
       exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
         Right _ -> pure $ Right ()
         Left  e -> pure $ Left [i|#{e}|]
@@ -395,12 +512,12 @@ settings' :: IORef Settings
 settings' = unsafePerformIO $ do
   dirs <- getDirs
   newIORef Settings { cache      = True
-                     , noVerify   = False
+                    , noVerify   = False
-                     , keepDirs   = Never
+                    , keepDirs   = Never
-                     , downloader = Curl
+                    , downloader = Curl
-                     , verbose    = False
+                    , verbose    = False
-                     , ..
+                    , ..
-                     }
+                    }
 
 
 logger' :: IORef LoggerConfig
@@ -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 ->
-    Left  e  -> do
+      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 {
+defaultAppSettings = AppSettings { showAll = False }
-    showAll = False
-  }
 
 
 getDownloads' :: IO (Either String GHCupDownloads)
@@ -453,16 +572,19 @@ getDownloads' = do
   r <-
     runLogger
     . flip runReaderT settings
-    . runE
+    . runE @'[JSONError , DownloadFailed , FileDoesNotExistError]
-      @'[JSONError, DownloadFailed, FileDoesNotExistError]
+    $ fmap _ghcupDownloads
-    $ fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)
+    $ 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
+  runLogger . flip runReaderT settings $ do
-    . flip runReaderT settings
+    case r of
-    $ do
+      Right dls -> do
-      case r of
+        lV <- listVersions dls Nothing Nothing pfreq'
-        Right dls -> do
+        pure $ Right $ (AppData (reverse lV) dls pfreq')
-          lV <- listVersions dls Nothing Nothing pfreq'
+      Left e -> pure $ Left [i|#{e}|]
-          pure $ Right $ (AppData (list "Tool versions"
+
-                (V.fromList . filter (filterVisible (showAll defaultAppSettings)) $ lV) 1) dls pfreq')
-        Left  e -> pure $ Left [i|#{e}|]