Table.hs

module Cabal.Matrix.Tui.Table
  ( TableMeta(..)
  , TableHeaders(..)
  , TableContents(..)
  , tableLayout
  , TableLayout
  , TableState(..)
  , ActiveSelection(..)
  , initTableState
  , tableWidget
  , tableHandleEvent
  , tableKeybinds
  ) where

import Cabal.Matrix.Tui.Common
import Cabal.Matrix.Tui.Flavor
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.List
import Data.List.NonEmpty (NonEmpty(..))
import Data.List.NonEmpty qualified as NonEmpty
import Data.Maybe
import Data.Primitive.Array
import Data.Text (Text)
import Data.Text qualified as Text
import Graphics.Vty


data TableMeta = TableMeta
  { frozenRows :: Int
  , normalRows :: Int
  , frozenColumns :: Int
  , normalColumns :: Int
  }

data TableHeaders = TableHeaders
  { frozenRowHeader :: Int -> Text
  , frozenRowCell :: Int -> Int -> Maybe Text
  , frozenColumnHeader :: Int -> Text
  , frozenColumnCell :: Int -> Int -> Maybe Text
  }

newtype TableContents = TableContents
  { normalCell :: Int -> Int -> Maybe FlavorState
  }

data ActiveSelection
  = SelectionLeft
  | SelectionTop
  | SelectionNormal
  | SelectionNone
  deriving stock (Eq)

data TableState = TableState
  { frozenScrollX :: Int
  , frozenScrollY :: Int
  , normalScrollX :: Int
  , normalScrollY :: Int
  , frozenSelectionCol :: Int
  , frozenSelectionRow :: Int
  , normalSelectionCol :: Int
  , normalSelectionRow :: Int
  , activeSelection :: ActiveSelection
  }

initTableState :: TableState
initTableState = TableState
  { frozenScrollX = 0
  , frozenScrollY = 0
  , normalScrollX = 0
  , normalScrollY = 0
  , frozenSelectionCol = 0
  , frozenSelectionRow = 0
  , normalSelectionCol = 0
  , normalSelectionRow = 0
  , activeSelection = SelectionNone
  }

data TopHeaderLayout = TopHeaderLayout
  { rowIndex :: !Int
  , rowHeader :: !Image
  , columns :: !(Array (NonEmpty Text))
  , height :: !Int
  }

data LeftHeaderLayout = LeftHeaderLayout
  { columnIndex :: !Int
  , columnHeader :: !Image
  , rows :: !(Array Text)
  , width :: !Int
  }

data TableLayout = TableLayout
  { rowHeaderWidth :: !Int
  , top :: !(Map Int TopHeaderLayout)
  , topHeight :: !Int
  , left :: !(Map Int LeftHeaderLayout)
  , leftWidth :: !Int
  }

tableLayout :: TableMeta -> TableHeaders -> TableLayout
tableLayout meta headers = TableLayout
  { rowHeaderWidth
  , top
  , topHeight
  , left
  , leftWidth = max 0 (pred leftWidth')
    -- ^ Remove the width of the trailing separator if there were any columns,
    -- but don't underflow to negative if there weren't.
  }
  where
    (topHeight, Map.fromAscList -> top) = mapAccumL mkTop 0
      [ TopHeaderLayout
        { rowIndex = row
        , rowHeader = resizeHeight height rowHeader
        , columns = arrayFromListN meta.normalColumns
          [ fmap (padTextToWidth matrixCellWidth)
            $ fromMaybe (NonEmpty.singleton "") $ NonEmpty.nonEmpty
            $ column <> replicate (height - length columns) ""
          | column <- columns
          ]
        , height
        }
      | row <- [0 .. meta.frozenRows - 1]
      , let
          rowHeader = text' defAttr $ headers.frozenRowHeader row
          columns =
            [ foldMap (wrap matrixCellWidth) $ headers.frozenRowCell col row
            | col <- [0 .. meta.normalColumns - 1]
            ]
          !height = maximum (imageHeight rowHeader :| (length <$> columns))
      ]
    mkTop !startY !layout
      | !endY <- startY + layout.height = (endY, (endY, layout))

    rowHeaderWidth = maximum
      $ 0 :| (imageWidth . (.rowHeader) <$> Map.elems top)

    (leftWidth', Map.fromAscList -> left) = mapAccumL mkLeft 0
      [ LeftHeaderLayout
        { columnIndex = col
        , columnHeader = resizeWidth width columnHeader
        , rows = arrayFromListN meta.normalRows $ padTextToWidth width <$> rows
        , width
        }
      | col <- [0 .. meta.frozenColumns - 1]
      , let
          columnHeader = text' defAttr $ headers.frozenColumnHeader col
          rows =
            [ fromMaybe "" $ headers.frozenColumnCell col row
            | row <- [0 .. meta.normalRows - 1]
            ]
          !width = maximum (imageWidth columnHeader :| (wctwidth <$> rows))
      ]
    mkLeft !startX layout
      | !endX <- startX + layout.width
      , !nextStartX <- endX + 1 = (nextStartX, (endX, layout))

padTextToWidth :: Int -> Text -> Text
padTextToWidth !width !t = t <> Text.replicate (width - Text.length t) " "

tableWidget
  :: DisplayRegion
  -> TableMeta
  -> TableContents
  -> TableLayout
  -> TableState
  -> (TableState, Image)
tableWidget (outputWidth, outputHeight) meta table layout state =
  ( state { frozenScrollX, frozenScrollY, normalScrollX, normalScrollY }
  , image
  )
  where
    topLeftWidth = max layout.rowHeaderWidth layout.leftWidth

    frozenWidth = min topLeftWidth ((outputWidth - 1) `div` 2)
    normalWidth = outputWidth - 1 - frozenWidth
    frozenHeight = min layout.topHeight ((outputHeight - 3) `div` 2)
    normalHeight = outputHeight - 3 - frozenHeight

    frozenScrollX
      | state.frozenSelectionCol < Map.size layout.left
      , (endX, col) <- Map.elemAt state.frozenSelectionCol layout.left
      = clamp (endX - frozenWidth) (endX - col.width) state.frozenScrollX
      | otherwise = state.frozenScrollX
    frozenScrollY
      | state.frozenSelectionRow < Map.size layout.top
      , (endY, row) <- Map.elemAt state.frozenSelectionRow layout.top
      = clamp (endY - frozenHeight) (endY - row.height) state.frozenScrollY
      | otherwise = state.frozenScrollY
    normalScrollX = clamp
      ((state.normalSelectionCol + 1) * (matrixCellWidth + 1) - 1 - normalWidth)
      (state.normalSelectionCol * (matrixCellWidth + 1))
      state.normalScrollX
    normalScrollY = clamp
      ((state.normalSelectionRow + 1) * matrixCellHeight - normalHeight)
      (state.normalSelectionRow * matrixCellHeight)
      state.normalScrollY

    normalTransX = -(normalScrollX `mod` (matrixCellWidth + 1))
    normalStartCol = normalScrollX `div` (matrixCellWidth + 1)
    normalEndCol = min (meta.normalColumns - 1)
      $ -((-normalScrollX - normalWidth) `div` (matrixCellWidth + 1))
    normalTransY = -(normalScrollY `mod` matrixCellHeight)
    normalStartRow = normalScrollY `div` matrixCellHeight
    normalEndRow = min (meta.normalRows - 1)
      $ -((-normalScrollY - normalHeight) `div` matrixCellHeight)
    (frozenTransX, leftVisible) =
      case Map.dropWhileAntitone (<= frozenScrollX) layout.left of
        leftTail@(Map.lookupMin -> Just (firstEndX, firstCol)) ->
          ( firstEndX - firstCol.width - frozenScrollX
          , snd <$> takeWhile
            (\(endX, col) -> endX - col.width < frozenScrollX + frozenWidth)
            (Map.toList leftTail)
          )
        _ -> (0, [])
    (frozenTransY, topVisible) =
      case Map.dropWhileAntitone (<= frozenScrollY) layout.top of
        topTail@(Map.lookupMin -> Just (firstEndY, firstRow)) ->
          ( firstEndY - firstRow.height - frozenScrollY
          , snd <$> takeWhile
            (\(endY, row) -> endY - row.height < frozenScrollY + frozenHeight)
            (Map.toList topTail)
          )
        _ -> (0, [])

    topLeft = cropBottom frozenHeight
      $ translate (frozenWidth - layout.rowHeaderWidth) frozenTransY
      $ vertCat
      [row.rowHeader | row <- topVisible]
    top = crop normalWidth frozenHeight
      $ translate normalTransX frozenTransY
      $ vertCat
      [ horizCat $ intersperse (backgroundFill 1 1)
        [ vertCat $ text' attr <$> NonEmpty.toList (indexArray row.columns col)
        | col <- [normalStartCol..normalEndCol]
        , let
            attr = if state.normalSelectionCol == col
              && state.frozenSelectionRow == row.rowIndex
              && state.activeSelection == SelectionTop
              then defAttr `withBackColor` blue
              else defAttr
        ]
      | row <- topVisible
      ]
    leftTop = resizeWidth frozenWidth $ translateX frozenTransX
      $ horizCat $ intersperse (backgroundFill 1 1)
      [col.columnHeader | col <- leftVisible]
    left = resize frozenWidth normalHeight
      $ translate frozenTransX normalTransY
      $ horizCat $ intersperse (backgroundFill 1 1)
      [ vertCat
        [ text' attr $ indexArray col.rows row
        | row <- [normalStartRow..normalEndRow]
        , let
            attr = if state.frozenSelectionCol == col.columnIndex
              && state.normalSelectionRow == row
              && state.activeSelection == SelectionLeft
              then defAttr `withBackColor` blue
              else defAttr
        ]
      | col <- leftVisible
      ]
    normal = crop normalWidth normalHeight
      $ translate normalTransX normalTransY
      $ vertCat
      [ horizCat $ intersperse (backgroundFill 1 1)
        [ cellWidget
          (state.normalSelectionCol == col
            && state.normalSelectionRow == row
            && state.activeSelection == SelectionNormal)
          $ table.normalCell col row
        | col <- [normalStartCol..normalEndCol]
        ]
      | row <- [normalStartRow..normalEndRow]
      ]

    canFrozenScrollW = frozenScrollX > 0
    canFrozenScrollE = frozenScrollX < topLeftWidth - frozenWidth
    canFrozenScrollN = frozenScrollY > 0
    canFrozenScrollS = frozenScrollY < layout.topHeight - frozenHeight
    canNormalScrollW = normalScrollX > 0
    canNormalScrollE = normalScrollX <
      meta.normalColumns * (matrixCellWidth + 1) - 1 - normalWidth
    canNormalScrollN = normalScrollY > 0
    canNormalScrollS = normalScrollY <
      meta.normalRows * matrixCellHeight - normalHeight

    image = vertCat
      [ topLeft
        <|> scrollBorderY canFrozenScrollN canFrozenScrollS frozenHeight
        <|> top
      , scrollBorderX canFrozenScrollW canFrozenScrollE frozenWidth
        <|> char defAttr borderNESW
        <|> scrollBorderX canNormalScrollW canNormalScrollE normalWidth
      , leftTop
        <|> char defAttr borderNS
      , scrollBorderX canFrozenScrollW canFrozenScrollE frozenWidth
        <|> char defAttr borderNESW
        <|> scrollBorderX canNormalScrollW canNormalScrollE normalWidth
      , left
        <|> scrollBorderY canNormalScrollN canNormalScrollS normalHeight
        <|> normal
      ]

scrollBorderX :: Bool -> Bool -> Int -> Image
scrollBorderX left right width
  | width > 2 = horizCat
    [ char defAttr (if left then triangleW else borderEW)
    , charFill defAttr borderEW (width - 2) 1
    , char defAttr (if right then triangleE else borderEW)
    ]
  | otherwise = charFill defAttr borderEW width 1

scrollBorderY :: Bool -> Bool -> Int -> Image
scrollBorderY up down height
  | height > 2 = vertCat
    [ char defAttr (if up then triangleN else borderNS)
    , charFill defAttr borderNS 1 (height - 2)
    , char defAttr (if down then triangleS else borderNS)
    ]
  | otherwise = charFill defAttr borderNS 1 height

tableHandleEvent :: TableMeta -> Event -> TableState -> TableState
tableHandleEvent meta ev ts = case ev of
  EvKey (KChar '\t') _ -> ts
    { activeSelection = case ts.activeSelection of
      SelectionNone -> SelectionNormal
      SelectionNormal -> SelectionTop
      SelectionTop -> SelectionLeft
      SelectionLeft -> SelectionNone
    }
  EvKey KLeft _
    | ts.activeSelection `elem` [SelectionNormal, SelectionTop] -> ts
      { normalSelectionCol = clamp 0 (meta.normalColumns - 1)
        $ pred ts.normalSelectionCol
      }
    | ts.activeSelection == SelectionLeft -> ts
      { frozenSelectionCol = clamp 0 (meta.frozenColumns - 1)
        $ pred ts.frozenSelectionCol
      }
    | ts.activeSelection == SelectionNone
    -> ts { activeSelection = SelectionNormal }
  EvKey KRight _
    | ts.activeSelection `elem` [SelectionNormal, SelectionTop] -> ts
      { normalSelectionCol = clamp 0 (meta.normalColumns - 1)
        $ succ ts.normalSelectionCol
      }
    | ts.activeSelection == SelectionLeft -> ts
      { frozenSelectionCol = clamp 0 (meta.frozenColumns - 1)
        $ succ ts.frozenSelectionCol
      }
    | ts.activeSelection == SelectionNone
    -> ts { activeSelection = SelectionNormal }
  EvKey KUp _
    | ts.activeSelection `elem` [SelectionNormal, SelectionLeft] -> ts
      { normalSelectionRow = clamp 0 (meta.normalRows - 1)
        $ pred ts.normalSelectionRow
      }
    | ts.activeSelection == SelectionTop -> ts
      { frozenSelectionRow = clamp 0 (meta.frozenRows - 1)
        $ pred ts.frozenSelectionRow
      }
    | ts.activeSelection == SelectionNone
    -> ts { activeSelection = SelectionNormal }
  EvKey KDown _
    | ts.activeSelection `elem` [SelectionNormal, SelectionLeft] -> ts
      { normalSelectionRow = clamp 0 (meta.normalRows - 1)
        $ succ ts.normalSelectionRow
      }
    | ts.activeSelection == SelectionTop -> ts
      { frozenSelectionRow = clamp 0 (meta.frozenRows - 1)
        $ succ ts.frozenSelectionRow
      }
    | ts.activeSelection == SelectionNone
    -> ts { activeSelection = SelectionNormal }
  _ -> ts

tableKeybinds :: [(Text, Text)]
tableKeybinds =
  [ (Text.pack [triangleW, triangleN, triangleS, triangleE], "select cell")
  , ("<Tab>", "focus cells/cols/rows")
  ]