More

app/ghcup/AnsiMain.hs

@@ -141,20 +141,34 @@ ghcupGame bs = Game 13
 
 drawFun :: BrickState -> GEnv -> Plane
 drawFun (BrickState {..}) GEnv{..} =
-  blankPlane mw mh
+  let focus pl = maybe pl
-    & (1, 1)   % box 1        1        '┌'
+                   (\ix -> V.update pl (V.singleton (ix + 1, fmap invert $ pl V.! (ix + 1))))
-    & (2, 1)   % box 1        (mh - 3) '│'
+                   mix
-    & (1, 2)   % box (mw - 2) 1        '─'
+      rows = V.fromList [header, [box (mw - 2) 1 '=']] V.++ renderItems
-    & (2, mw)  % box 1        (mh - 3) '│'
+      cols = V.foldr (\xs ys -> zipWith (:) xs ys) (repeat []) $ V.filter ((==5) . length) rows
-    & (1, mw)  % box 1        1        '┐'
+      padded  = focus $ V.map (\xs -> zipWith padTo xs lengths) rows
-    & (mh-1, 2)  % box (mw - 2) 1        '─'
+      lengths :: [Int]
-    & (mh-1, 1)  % box 1        1        '└'
+      lengths = fmap (maximum . fmap (fst . planeSize)) cols
-    & (mh-1, mw) % box 1        1        '┘'
+  in blankPlane mw mh
-    & (2, 2)   % box (mw - 2) (mh - 3) ' '
+    & (1, 1)   % box 1        1        'X' -- '┌'
-    & (2, 2)   % (header === box (mw - 2) 1 '─' === renderItems)
+    & (2, 1)   % box 1        (mh - 3) '|' -- '│'
+    & (1, 2)   % box (mw - 2) 1        '=' -- '─'
+    & (2, mw)  % box 1        (mh - 3) '|' -- '│'
+    & (1, mw)  % box 1        1        'X' -- '┐'
+    & (mh-1, 2)  % box (mw - 2) 1      '=' -- '─'
+    & (mh-1, 1)  % box 1        1      'X' -- '└'
+    & (mh-1, mw) % box 1        1      'X' -- '┘'
+    & (2, 2)   % box (mw - 2) (mh - 3) ' ' -- ' '
+    & (2, 2)   % vcat (hcat <$> V.toList padded)
     & (mh, 1)  % footer
     & (1, mw `div` 2 - 2) % stringPlane "GHCup"
  where
+
+  padTo :: Plane -> Int -> Plane
+  padTo plane x =
+    let lstr = fst $ planeSize plane
+        add' = x - lstr + 1
+    in  if add' < 0 then plane else plane ||| stringPlane (replicate add' ' ')
   mh :: Height
   mw :: Width
   (mh, mw) = T.swap eTermDims
@@ -162,16 +176,13 @@ drawFun (BrickState {..}) GEnv{..} =
          . intersperse (stringPlane "  ")
          . fmap stringPlane
          $ ["q:Quit", "i:Install", "u:Uninstall", "s:Set", "c:Changelog", "a:all versions", "↑:Up", "↓:Down"]
-  header = hcat
+  header = fmap stringPlane ["Tool", "Version", "Tags", "Notes"]
-         . intersperse space
+  (renderItems, mix) = drawListElements renderItem appState
-         . fmap stringPlane
-         $ ["Tool", "Version", "Tags", "Notes"]
-  renderItems = drawListElements renderItem True appState
   renderItem _ b listResult@ListResult{..} =
     let marks = if
-          | lSet       -> color Green Vivid (stringPlane "✔✔")
+          | lSet       -> color Green Vivid $ stringPlane "IS"
-          | lInstalled -> color Green Dull (stringPlane "✓ ")
+          | lInstalled -> color Green Vivid $ stringPlane "I "
-          | otherwise  -> color Red Vivid (stringPlane "✗ ")
+          | otherwise  -> color Red Vivid $ stringPlane "X "
         ver = case lCross of
           Nothing -> stringPlane . Tx.unpack . prettyVer $ lVer
           Just c  -> stringPlane . Tx.unpack $ (c <> "-" <> prettyVer lVer)
@@ -183,7 +194,7 @@ drawFun (BrickState {..}) GEnv{..} =
                       then blankPlane 1 1
                       else foldr1 (\x y -> x ||| stringPlane "," ||| y) n
 
-    in hcat [marks, space, space, tool, space, ver, space, tag, space, notes]
+    in [marks ||| space, tool, ver, tag, notes]
 
   printTag Recommended    = Just $ color Green Dull $ stringPlane "recommended"
   printTag Latest         = Just $ color Yellow Dull $ stringPlane "latest"
@@ -213,40 +224,40 @@ drawFun (BrickState {..}) GEnv{..} =
   -- 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 -> Plane)
+  drawListElements :: (Int -> Bool -> ListResult -> [Plane])
-                   -> Bool
                    -> BrickInternalState
-                   -> Plane
+                   -> (V.Vector [Plane], Maybe Int)
-  drawListElements drawElem foc is@(BrickInternalState clr _) =
+  drawListElements drawElem is@(BrickInternalState clr _) =
       let es = clr
           listSelected        = fmap fst $ listSelectedElement' is
 
           (drawnElements, selIx) = runST $ do
             ref <- newSTRef (Nothing :: Maybe Int)
+            vec <- newSTRef (mempty :: V.Vector [Plane])
             elem' <- newSTRef 0
-            arr <- fmap join $ flip V.imapM es $ \i' e -> do
+            void $ flip V.imapM es $ \i' e -> do
               let isSelected  = Just i' == listSelected
                   elemWidget  = drawElem i' isSelected e
-                  selItemAttr = if foc
-                    then listSelectedFocusedAttr
-                    else listSelectedAttr
-                  markSelected = if isSelected then selItemAttr else id
               case es V.!? (i' - 1) of
                     Just e' | lTool e' /= lTool e -> do
                       modifySTRef elem' (+2)
                       i <- readSTRef elem'
                       when isSelected $ writeSTRef ref (Just i)
-                      pure $ V.fromList [hBorder, markSelected elemWidget] -- add separator
+                      modifySTRef vec (`V.snoc` [hBorder])
+                      modifySTRef vec (`V.snoc` elemWidget)
+                      pure ()
                     _ -> do
                       modifySTRef elem' (+1)
                       i <- readSTRef elem'
                       when isSelected $ writeSTRef ref (Just i)
-                      pure $ V.fromList [markSelected elemWidget]
+                      modifySTRef vec (`V.snoc` elemWidget)
+                      pure ()
             i <- readSTRef ref
+            arr <- readSTRef vec
             pure (arr, i)
-        in vcat $ V.toList (makeVisible drawnElements (mh - 5) selIx)
+        in (makeVisible drawnElements (mh - 5) selIx, selIx)
    where
-    makeVisible :: V.Vector Plane -> Height -> Maybe Int -> V.Vector Plane
+    makeVisible :: V.Vector [Plane] -> Height -> Maybe Int -> V.Vector [Plane]
     makeVisible listElements drawableHeight (Just ix) =
       let listHeight = V.length listElements
       in if | listHeight <= 0 -> listElements
@@ -256,11 +267,7 @@ drawFun (BrickState {..}) GEnv{..} =
             | otherwise -> listElements
     makeVisible listElements _ Nothing = listElements
 
-    listSelectedFocusedAttr = invert
+    hBorder = box (mw - 2) 1 '='
-
-    listSelectedAttr = invert
-
-    hBorder = box (mw - 2) 1 '─'
 
 
 logicFun :: GEnv -> BrickState -> Event -> IO BrickState

app/ghcup/GHCup/OptParse/List.hs

@@ -12,6 +12,7 @@ module GHCup.OptParse.List where
 
 import           GHCup
 import           GHCup.Prelude
+import           GHCup.Prelude.Ansi
 import           GHCup.Types
 import           GHCup.OptParse.Common
 
@@ -155,89 +156,6 @@ printListResult no_color raw lr = do
         add' = x - lstr
     in  if add' < 0 then str' else str' ++ replicate add' ' '
 
-  -- | Calculate the render width of a string, considering
-  -- wide characters (counted as double width), ANSI escape codes
-  -- (not counted), and line breaks (in a multi-line string, the longest
-  -- line determines the width).
-  strWidth :: String -> Int
-  strWidth =
-    maximum
-      . (0 :)
-      . map (foldr (\a b -> charWidth a + b) 0)
-      . lines
-      . stripAnsi
-
-  -- | Strip ANSI escape sequences from a string.
-  --
-  -- >>> stripAnsi "\ESC[31m-1\ESC[m"
-  -- "-1"
-  stripAnsi :: String -> String
-  stripAnsi s' =
-    case
-        MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
-      of
-        Nothing -> error "Bad ansi escape"  -- PARTIAL: should not happen
-        Just xs -> concat xs
-   where
-      -- This parses lots of invalid ANSI escape codes, but that should be fine
-    ansi =
-      MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
-          Void
-          String
-          Char
-    digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
-    suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
-
-  -- | Get the designated render width of a character: 0 for a combining
-  -- character, 1 for a regular character, 2 for a wide character.
-  -- (Wide characters are rendered as exactly double width in apps and
-  -- fonts that support it.) (From Pandoc.)
-  charWidth :: Char -> Int
-  charWidth c = case c of
-    _ | c < '\x0300'                     -> 1
-      | c >= '\x0300' && c <= '\x036F'   -> 0
-      |  -- combining
-        c >= '\x0370' && c <= '\x10FC'   -> 1
-      | c >= '\x1100' && c <= '\x115F'   -> 2
-      | c >= '\x1160' && c <= '\x11A2'   -> 1
-      | c >= '\x11A3' && c <= '\x11A7'   -> 2
-      | c >= '\x11A8' && c <= '\x11F9'   -> 1
-      | c >= '\x11FA' && c <= '\x11FF'   -> 2
-      | c >= '\x1200' && c <= '\x2328'   -> 1
-      | c >= '\x2329' && c <= '\x232A'   -> 2
-      | c >= '\x232B' && c <= '\x2E31'   -> 1
-      | c >= '\x2E80' && c <= '\x303E'   -> 2
-      | c == '\x303F'                    -> 1
-      | c >= '\x3041' && c <= '\x3247'   -> 2
-      | c >= '\x3248' && c <= '\x324F'   -> 1
-      | -- ambiguous
-        c >= '\x3250' && c <= '\x4DBF'   -> 2
-      | c >= '\x4DC0' && c <= '\x4DFF'   -> 1
-      | c >= '\x4E00' && c <= '\xA4C6'   -> 2
-      | c >= '\xA4D0' && c <= '\xA95F'   -> 1
-      | c >= '\xA960' && c <= '\xA97C'   -> 2
-      | c >= '\xA980' && c <= '\xABF9'   -> 1
-      | c >= '\xAC00' && c <= '\xD7FB'   -> 2
-      | c >= '\xD800' && c <= '\xDFFF'   -> 1
-      | c >= '\xE000' && c <= '\xF8FF'   -> 1
-      | -- ambiguous
-        c >= '\xF900' && c <= '\xFAFF'   -> 2
-      | c >= '\xFB00' && c <= '\xFDFD'   -> 1
-      | c >= '\xFE00' && c <= '\xFE0F'   -> 1
-      | -- ambiguous
-        c >= '\xFE10' && c <= '\xFE19'   -> 2
-      | c >= '\xFE20' && c <= '\xFE26'   -> 1
-      | c >= '\xFE30' && c <= '\xFE6B'   -> 2
-      | c >= '\xFE70' && c <= '\xFEFF'   -> 1
-      | c >= '\xFF01' && c <= '\xFF60'   -> 2
-      | c >= '\xFF61' && c <= '\x16A38'  -> 1
-      | c >= '\x1B000' && c <= '\x1B001' -> 2
-      | c >= '\x1D000' && c <= '\x1F1FF' -> 1
-      | c >= '\x1F200' && c <= '\x1F251' -> 2
-      | c >= '\x1F300' && c <= '\x1F773' -> 1
-      | c >= '\x20000' && c <= '\x3FFFD' -> 2
-      | otherwise                        -> 1
-
 
 
 

ghcup.cabal

@@ -70,6 +70,7 @@ library
     GHCup.List
     GHCup.Platform
     GHCup.Prelude
+    GHCup.Prelude.Ansi
     GHCup.Prelude.File
     GHCup.Prelude.File.Search
     GHCup.Prelude.Internal

lib/GHCup/Prelude/Ansi.hs

@@ -0,0 +1,92 @@
+module GHCup.Prelude.Ansi where
+
+import           Control.Applicative
+import           Data.Char
+import           Data.Void
+
+import qualified Text.Megaparsec               as MP
+import qualified Text.Megaparsec.Char          as MPC
+
+
+-- | Calculate the render width of a string, considering
+-- wide characters (counted as double width), ANSI escape codes
+-- (not counted), and line breaks (in a multi-line string, the longest
+-- line determines the width).
+strWidth :: String -> Int
+strWidth =
+  maximum
+    . (0 :)
+    . map (foldr (\a b -> charWidth a + b) 0)
+    . lines
+    . stripAnsi
+
+-- | Strip ANSI escape sequences from a string.
+--
+-- >>> stripAnsi "\ESC[31m-1\ESC[m"
+-- "-1"
+stripAnsi :: String -> String
+stripAnsi s' =
+  case
+      MP.parseMaybe (many $ "" <$ MP.try ansi <|> pure <$> MP.anySingle) s'
+    of
+      Nothing -> error "Bad ansi escape"  -- PARTIAL: should not happen
+      Just xs -> concat xs
+ where
+    -- This parses lots of invalid ANSI escape codes, but that should be fine
+  ansi =
+    MPC.string "\ESC[" *> digitSemicolons *> suffix MP.<?> "ansi" :: MP.Parsec
+        Void
+        String
+        Char
+  digitSemicolons = MP.takeWhileP Nothing (\c -> isDigit c || c == ';')
+  suffix = MP.oneOf ['A', 'B', 'C', 'D', 'H', 'J', 'K', 'f', 'm', 's', 'u']
+
+-- | Get the designated render width of a character: 0 for a combining
+-- character, 1 for a regular character, 2 for a wide character.
+-- (Wide characters are rendered as exactly double width in apps and
+-- fonts that support it.) (From Pandoc.)
+charWidth :: Char -> Int
+charWidth c = case c of
+  _ | c < '\x0300'                     -> 1
+    | c >= '\x0300' && c <= '\x036F'   -> 0
+    |  -- combining
+      c >= '\x0370' && c <= '\x10FC'   -> 1
+    | c >= '\x1100' && c <= '\x115F'   -> 2
+    | c >= '\x1160' && c <= '\x11A2'   -> 1
+    | c >= '\x11A3' && c <= '\x11A7'   -> 2
+    | c >= '\x11A8' && c <= '\x11F9'   -> 1
+    | c >= '\x11FA' && c <= '\x11FF'   -> 2
+    | c >= '\x1200' && c <= '\x2328'   -> 1
+    | c >= '\x2329' && c <= '\x232A'   -> 2
+    | c >= '\x232B' && c <= '\x2E31'   -> 1
+    | c >= '\x2E80' && c <= '\x303E'   -> 2
+    | c == '\x303F'                    -> 1
+    | c >= '\x3041' && c <= '\x3247'   -> 2
+    | c >= '\x3248' && c <= '\x324F'   -> 1
+    | -- ambiguous
+      c >= '\x3250' && c <= '\x4DBF'   -> 2
+    | c >= '\x4DC0' && c <= '\x4DFF'   -> 1
+    | c >= '\x4E00' && c <= '\xA4C6'   -> 2
+    | c >= '\xA4D0' && c <= '\xA95F'   -> 1
+    | c >= '\xA960' && c <= '\xA97C'   -> 2
+    | c >= '\xA980' && c <= '\xABF9'   -> 1
+    | c >= '\xAC00' && c <= '\xD7FB'   -> 2
+    | c >= '\xD800' && c <= '\xDFFF'   -> 1
+    | c >= '\xE000' && c <= '\xF8FF'   -> 1
+    | -- ambiguous
+      c >= '\xF900' && c <= '\xFAFF'   -> 2
+    | c >= '\xFB00' && c <= '\xFDFD'   -> 1
+    | c >= '\xFE00' && c <= '\xFE0F'   -> 1
+    | -- ambiguous
+      c >= '\xFE10' && c <= '\xFE19'   -> 2
+    | c >= '\xFE20' && c <= '\xFE26'   -> 1
+    | c >= '\xFE30' && c <= '\xFE6B'   -> 2
+    | c >= '\xFE70' && c <= '\xFEFF'   -> 1
+    | c >= '\xFF01' && c <= '\xFF60'   -> 2
+    | c >= '\xFF61' && c <= '\x16A38'  -> 1
+    | c >= '\x1B000' && c <= '\x1B001' -> 2
+    | c >= '\x1D000' && c <= '\x1F1FF' -> 1
+    | c >= '\x1F200' && c <= '\x1F251' -> 2
+    | c >= '\x1F300' && c <= '\x1F773' -> 1
+    | c >= '\x20000' && c <= '\x3FFFD' -> 2
+    | otherwise                        -> 1