content: {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses,
    TypeSynonymInstances, FlexibleInstances, DeriveDataTypeable #-}
  -- |This module provides a table layout widget capable of laying out
  -- columns of widgets with various padding and alignment properties.
  -- For complete details, please see the Vty-ui User's Manual.
  module Graphics.Vty.Widgets.Table
      ( Table
      , TableCell
      , ColumnSize(..)
      , BorderStyle(..)
      , BorderFlag(..)
      , RowLike(..)
      , TableError(..)
      , ColumnSpec(..)
      , (.|.)
      , newTable
      , setDefaultCellAlignment
      , setDefaultCellPadding
      , addRow
      , addHeadingRow
      , addHeadingRow_
      , column
      , customCell
      , emptyCell
      )
  where
  
  import Data.Monoid
  import qualified Data.Text as T
  import Data.Typeable
  import Data.List
  import Control.Applicative hiding ((<|>))
  import Control.Exception
  import Control.Monad
  import Graphics.Vty hiding (regionHeight, regionWidth)
  import Graphics.Vty.Widgets.Core
  import Graphics.Vty.Widgets.Text
  import Graphics.Vty.Widgets.Centering
  import Graphics.Vty.Widgets.Padding
  import Graphics.Vty.Widgets.Borders
  import Graphics.Vty.Widgets.Skins
  import Graphics.Vty.Widgets.Util
  import Graphics.Vty.Widgets.Fills
  import Graphics.Vty.Widgets.Box
  import Graphics.Vty.Widgets.Alignment
  
  data TableError = ColumnCountMismatch
                  -- ^A row added to the table did not have the same
                  -- number of widgets as the table has columns.
                  | CellImageTooBig
                  -- ^The image rendered by a cell widget exceeded the
                  -- size permitted by the cell.
                  | BadTableWidgetSizePolicy Int
                    -- ^A table cell contains a widget which grows
                    -- vertically, which is not permitted.
                    deriving (Show, Typeable)
  
  instance Exception TableError
  
  -- |The wrapper type for all table cells; stores the widgets
  -- themselves in addition to alignment and padding settings.
  -- Alignment and padding settings on a cell override the column- and
  -- table-wide defaults.
  data TableCell = forall a. (Show a) => TableCell (Widget a) (Maybe Alignment) (Maybe Padding)
                 | EmptyCell
  
  instance Show TableCell where
      show EmptyCell = "EmptyCell"
      show (TableCell _ mAl mPad) = concat [ "TableCell { "
                                           , "alignment = "
                                           , show mAl
                                           , ", padding = "
                                           , show mPad
                                           , ", ... "
                                           , "}"
                                           ]
  
  data TableRow = TableRow [TableCell]
  
  -- |The types of borders we can have in a table.
  data BorderFlag = Rows
                  -- ^Borders between rows.
                  | Columns
                  -- ^Borders between columns.
                  | Edges
                    -- ^Borders around the outside edges of the table.
                    deriving (Eq, Show)
  
  -- |The border configuration of a table.
  data BorderStyle = BorderPartial [BorderFlag]
                   -- |A partial set of border flags.
                   | BorderFull
                   -- |Draw borders everywhere we support them.
                   | BorderNone
                     -- ^Don't draw any borders anywhere.
                     deriving (Eq, Show)
  
  -- |The type of column size policies.
  data ColumnSize = ColFixed Int
                  -- ^The column has the specified fixed width in
                  -- columns.
                  | ColAuto
                    -- ^The column's width is a function of space
                    -- available to the table at rendering time.
                    deriving (Eq, Show)
  
  -- |The specification of a column's settings.  The alignment and
  -- padding of a column specification override the table-wide default.
  data ColumnSpec = ColumnSpec { columnSize :: ColumnSize
                               , columnAlignment :: Maybe Alignment
                               , columnPadding :: Maybe Padding
                               }
                    deriving (Show)
  
  instance Paddable ColumnSpec where
      pad c p = c { columnPadding = Just p }
  
  instance Alignable ColumnSpec where
      align c a = c { columnAlignment = Just a }
  
  instance Paddable TableCell where
      pad (TableCell w a _) p = TableCell w a (Just p)
      pad EmptyCell _ = EmptyCell
  
  instance Alignable TableCell where
      align (TableCell w _ p) a = TableCell w (Just a) p
      align EmptyCell _ = EmptyCell
  
  -- |The class of types whose values can be used to construct table
  -- rows.
  class RowLike a where
      mkRow :: a -> TableRow
  
  instance RowLike TableRow where
      mkRow = id
  
  instance RowLike TableCell where
      mkRow c = TableRow [c]
  
  instance (Show a) => RowLike (Widget a) where
      mkRow w = TableRow [TableCell w Nothing Nothing]
  
  instance (RowLike a) => RowLike [a] where
      mkRow rs = TableRow cs
          where
            cs = concat $ map (\(TableRow cells) -> cells) rs'
            rs' = map mkRow rs
  
  -- |Row constructor using 'RowLike' instances.
  (.|.) :: (RowLike a, RowLike b) => a -> b -> TableRow
  (.|.) a b = TableRow (cs ++ ds)
      where
        (TableRow cs) = mkRow a
        (TableRow ds) = mkRow b
  
  instance Semigroup TableRow where
      (<>) (TableRow as) (TableRow bs) = TableRow $ as ++ bs
  
  instance Monoid TableRow where
      mempty = TableRow []
      mappend = (<>)
  
  infixl 2 .|.
  
  data Table = Table { rows :: [TableRow]
                     , numColumns :: Int
                     , columnSpecs :: [ColumnSpec]
                     , borderStyle :: BorderStyle
                     , borderAttr :: Attr
                     , defaultCellAlignment :: Alignment
                     , defaultCellPadding :: Padding
                     }
  
  instance HasBorderAttr (Widget Table) where
      setBorderAttribute t a =
          updateWidgetState t $ \s -> s { borderAttr = mergeAttr a $ borderAttr s }
  
  instance Show Table where
      show t = concat [ "Table { "
                      , "rows = <", show $ length $ rows t, " rows>"
                      , ", numColumns = ", show $ numColumns t
                      , ", columnSpecs = ", show $ columnSpecs t
                      , ", borderStyle = ", show $ borderStyle t
                      , ", borderAttr = ", show $ borderAttr t
                      , ", defaultCellAlignment = ", show $ defaultCellAlignment t
                      , ", defaultCellPadding = ", show $ defaultCellPadding t
                      , " }"
                      ]
  
  -- |Create a custom 'TableCell' to set its alignment and/or padding
  -- settings.
  customCell :: (Show a) => Widget a -> TableCell
  customCell w = TableCell w Nothing Nothing
  
  -- |Create an empty table cell.
  emptyCell :: TableCell
  emptyCell = EmptyCell
  
  -- |Set the default table-wide cell alignment.
  setDefaultCellAlignment :: Widget Table -> Alignment -> IO ()
  setDefaultCellAlignment t a = updateWidgetState t $ \s -> s { defaultCellAlignment = a }
  
  -- |Set the default table-wide cell padding.
  setDefaultCellPadding :: Widget Table -> Padding -> IO ()
  setDefaultCellPadding t p = updateWidgetState t $ \s -> s { defaultCellPadding = p }
  
  -- |Create a column.
  column :: ColumnSize -> ColumnSpec
  column sz = ColumnSpec sz Nothing Nothing
  
  -- |Create a table widget using a list of column specifications and a
  -- border style.
  newTable :: [ColumnSpec]
           -> BorderStyle
           -> IO (Widget Table)
  newTable specs borderSty = do
    let initSt = Table { rows = []
                       , columnSpecs = specs
                       , borderStyle = borderSty
                       , numColumns = length specs
                       , borderAttr = defAttr
                       , defaultCellAlignment = AlignLeft
                       , defaultCellPadding = padNone
                       }
  
    t <- newWidget initSt $ \w ->
        w { growHorizontal_ = \st -> do
              return $ any (== ColAuto) (map columnSize $ columnSpecs st)
  
          , render_ =
              \this sz ctx -> do
                rs <- rows <~~ this
                let sk = skin ctx
  
                rowImgs <- mapM (\(TableRow r) -> renderRow this sz r ctx) rs
  
                rowBorder <- mkRowBorder this sz ctx $ skinIntersectionFull sk
                topBorder <- mkTopBottomBorder this sz ctx $ skinIntersectionT sk
                bottomBorder <- mkTopBottomBorder this sz ctx $ skinIntersectionB sk
                sideBorderL <- mkSideBorder this ctx True
                sideBorderR <- mkSideBorder this ctx False
  
                let body = vertCat $ intersperse rowBorder rowImgs
                    withTBBorders = vertCat [topBorder, body, bottomBorder]
                    withSideBorders = horizCat [sideBorderL, withTBBorders, sideBorderR]
  
                -- Ideally, we would only display rows that we have room
                -- to render, but this is a much easier cop-out. :)
                if ((regionWidth sz < imageWidth withSideBorders) ||
                    (regionHeight sz < imageHeight withSideBorders)) then
                    return emptyImage else
                    return withSideBorders
  
          , setCurrentPosition_ =
              \this pos -> do
                sz <- getCurrentSize this
                if regionWidth sz == 0 || regionHeight sz == 0 then
                    return () else
                    do
                      bs <- borderStyle <~~ this
                      rs <- rows <~~ this
  
                      let edgeOffset = if edgeBorders bs
                                       then 1 else 0
                          positionRows _ [] = return ()
                          positionRows height ((TableRow row):rest) =
                            do
                              -- Compute the position for this row based on
                              -- border settings
                              let rowPos = pos `plusWidth` edgeOffset
                                           `withHeight` height
  
                              -- Get the maximum cell height
                              cellPhysSizes <- forM row $ \cell ->
                                               case cell of
                                                 TableCell cw _ _ -> getCurrentSize cw
                                                 EmptyCell -> return (0, 1)
  
                              -- Include 1 as a possible height to
                              -- prevent zero-height images from
                              -- breaking position computations.  This
                              -- won't hurt in the case where other
                              -- cells are bigger, since their heights
                              -- will be chosen instead.
                              let maxSize = maximum $ 1 : map regionHeight cellPhysSizes
                                  borderOffset = if rowBorders bs
                                                 then 1 else 0
  
                              -- Position the individual row widgets
                              -- (again, based on border settings)
                              positionRow this bs rowPos row
                              positionRows (height + maxSize + borderOffset) rest
  
                      positionRows (regionHeight pos + edgeOffset) rs
          }
    return t
  
  getCellAlignment :: Widget Table -> Int -> TableCell -> IO Alignment
  getCellAlignment _ _ (TableCell _ (Just p) _) = return p
  getCellAlignment t columnNumber _ = do
    -- If the column for this cell has properties, use those; otherwise
    -- default to table-wide properties.
    specs <- columnSpecs <~~ t
    let spec = specs !! columnNumber
  
    case columnAlignment spec of
      Nothing -> defaultCellAlignment <~~ t
      Just p -> return p
  
  getCellPadding :: Widget Table -> Int -> TableCell -> IO Padding
  getCellPadding _ _ (TableCell _ _ (Just p)) = return p
  getCellPadding t columnNumber _ = do
    -- If the column for this cell has properties, use those; otherwise
    -- default to table-wide properties.
    specs <- columnSpecs <~~ t
    let spec = specs !! columnNumber
  
    case columnPadding spec of
      Nothing -> defaultCellPadding <~~ t
      Just p -> return p
  
  mkRowBorder :: Widget Table -> DisplayRegion -> RenderContext -> Char -> IO Image
  mkRowBorder t sz ctx intChar = do
    bs <- borderStyle <~~ t
  
    if not $ rowBorders bs then
        return emptyImage else
        mkRowBorder_ t sz ctx intChar
  
  -- Make a row border that matches the width of each row but does not
  -- include outermost edge characters.
  mkRowBorder_ :: Widget Table -> DisplayRegion -> RenderContext -> Char -> IO Image
  mkRowBorder_ t sz ctx intChar = do
    bs <- borderStyle <~~ t
    bAttr <- borderAttr <~~ t
    specs <- columnSpecs <~~ t
    aw <- autoWidth t sz
  
    let sk = skin ctx
        bAttr' = mergeAttrs [ overrideAttr ctx
                            , bAttr
                            , normalAttr ctx
                            ]
        szs = map columnSize specs
        intersection = string bAttr' [intChar]
        imgs = (flip map) szs $ \s ->
               case s of
                 ColFixed n -> charFill bAttr' (skinHorizontal sk) n 1
                 ColAuto -> charFill bAttr' (skinHorizontal sk) aw 1
        imgs' = if colBorders bs
                then intersperse intersection imgs
                else imgs
  
    return $ horizCat imgs'
  
  mkTopBottomBorder :: Widget Table -> DisplayRegion -> RenderContext -> Char -> IO Image
  mkTopBottomBorder t sz ctx intChar = do
    bs <- borderStyle <~~ t
  
    if edgeBorders bs then
        mkRowBorder_ t sz ctx intChar else
        return emptyImage
  
  -- Make vertical side borders for the table, including row border
  -- intersections if necessary.
  mkSideBorder :: Widget Table -> RenderContext -> Bool -> IO Image
  mkSideBorder t ctx isLeft = do
    bs <- borderStyle <~~ t
  
    if edgeBorders bs then
        mkSideBorder_ t ctx isLeft else
        return emptyImage
  
  mkSideBorder_ :: Widget Table -> RenderContext -> Bool -> IO Image
  mkSideBorder_ t ctx isLeft = do
    bs <- borderStyle <~~ t
    bAttr <- borderAttr <~~ t
    rs <- rows <~~ t
  
    let sk = skin ctx
        intersection = string bAttr' [ if isLeft
                                       then skinIntersectionL sk
                                       else skinIntersectionR sk
                                     ]
        topCorner = string bAttr' [ if isLeft
                                    then skinCornerTL sk
                                    else skinCornerTR sk
                                  ]
        bottomCorner = string bAttr' [ if isLeft
                                       then skinCornerBL sk
                                       else skinCornerBR sk
                                     ]
        bAttr' = mergeAttrs [ overrideAttr ctx
                            , bAttr
                            , normalAttr ctx
                            ]
  
    rowHeights <- forM rs $ \(TableRow row) -> do
                      hs <- forM row $ \cell ->
                            case cell of
                              TableCell cw _ _ -> regionHeight <$> getCurrentSize cw
                              EmptyCell -> return 1
                      return $ maximum hs
  
    let borderImgs = (flip map) rowHeights $ \h -> charFill bAttr' (skinVertical sk) 1 h
        withIntersections = if rowBorders bs
                            then intersperse intersection borderImgs
                            else borderImgs
  
    return $ vertCat $ topCorner : withIntersections ++ [bottomCorner]
  
  positionRow :: Widget Table -> BorderStyle -> DisplayRegion -> [TableCell] -> IO ()
  positionRow t bs pos cells = do
    -- Position each cell widget based on the base position of the row
    -- (which starts from the origin of the leftmost widget, NOT the
    -- leftmost cell border)
    oldSize <- getCurrentSize t
    aw <- autoWidth t oldSize
    specs <- columnSpecs <~~ t
  
    let szs = map columnSize specs
        offset = if colBorders bs
                 then 1
                 else 0
  
        cellWidth ColAuto = aw
        cellWidth (ColFixed n) = toEnum n
  
        doPositioning _ [] = return ()
        doPositioning width ((szPolicy, cell):ws) =
            do
              case cell of
                TableCell w _ _ -> setCurrentPosition w $ pos `plusWidth` width
                EmptyCell -> return ()
              doPositioning (width + cellWidth szPolicy + offset) ws
  
    doPositioning 0 $ zip szs cells
  
  autoWidth :: Widget Table -> DisplayRegion -> IO Int
  autoWidth t sz = do
    specs <- columnSpecs <~~ t
    bs <- borderStyle <~~ t
  
    let sizes = map columnSize specs
        numAuto = length $ filter (== ColAuto) sizes
        totalFixed = sum $ (flip map) sizes $ \s ->
                     case s of
                       ColAuto -> 0
                       ColFixed n -> n
        edgeWidth = if edgeBorders bs then 2 else 0
        colWidth = if colBorders bs then (toEnum $ length sizes - 1) else 0
  
    return $ toEnum ((max 0 ((fromEnum $ regionWidth sz) - totalFixed - edgeWidth - colWidth))
                     `div` numAuto)
  
  -- |Add a heading row to a table.  Adds a row using the specified
  -- |labels and attribute.  Returns the widgets it constructed as a
  -- |side-effect in case you want to do something with them.
  addHeadingRow :: Widget Table -> Attr -> [T.Text] -> IO [Widget FormattedText]
  addHeadingRow tbl attr labels = do
    ws <- mapM (\s -> plainText s >>= withNormalAttribute attr) labels
    addRow tbl ws
    return ws
  
  -- |Add a heading row to a table.  Adds a row using the specified
  -- |labels and attribute.
  addHeadingRow_ :: Widget Table -> Attr -> [T.Text] -> IO ()
  addHeadingRow_ tbl attr labels = addHeadingRow tbl attr labels >> return ()
  
  applyCellAlignment :: Alignment -> TableCell -> IO TableCell
  applyCellAlignment _ EmptyCell = return EmptyCell
  applyCellAlignment al (TableCell w a p) = do
    case al of
      AlignLeft -> return $ TableCell w a p
  
      AlignCenter -> do
        -- This check really belongs in the centering code...
        grow <- growHorizontal w
        case grow of
          False -> do
                    w' <- hCentered w
                    return $ TableCell w' a p
          True -> return $ TableCell w a p
  
      AlignRight -> do
        grow <- growHorizontal w
        case grow of
          False -> do
                    w' <- (hFill ' ' 1) <++> (return w)
                    return $ TableCell w' a p
          True -> return $ TableCell w a p
  
  applyCellPadding :: Padding -> TableCell -> IO TableCell
  applyCellPadding _ EmptyCell = return EmptyCell
  applyCellPadding padding (TableCell w a p) = do
    w' <- padded w padding
    return $ TableCell w' a p
  
  -- |Add a row to the table.  Use 'RowLike' instances to populate the
  -- row.  Throws 'BadTableWidgetSizePolicy' if any widgets in the row
  -- grow vertically; throws 'ColumnCountMismatch' if the row's number
  -- of columns does not match the table's column count.
  addRow :: (RowLike a) => Widget Table -> a -> IO ()
  addRow t row = do
    let (TableRow cells_) = mkRow row
  
    cells <- forM (zip [1..] cells_) $ \(i, c) -> do
                   case c of
                     EmptyCell -> return ()
                     TableCell w _ _ -> do
                            v <- growVertical w
                            when (v) $ throw $ BadTableWidgetSizePolicy i
  
                   -- Apply cell properties to the widget in this cell.
                   alignment <- getCellAlignment t (i - 1) c
                   padding <- getCellPadding t (i - 1) c
  
                   applyCellAlignment alignment c >>= applyCellPadding padding
  
    nc <- numColumns <~~ t
    when (length cells /= nc) $ throw ColumnCountMismatch
  
    updateWidgetState t $ \s ->
        s { rows = rows s ++ [TableRow cells] }
  
  renderCell :: DisplayRegion -> TableCell -> RenderContext -> IO Image
  renderCell region EmptyCell ctx = do
    w <- plainText T.empty
    render w region ctx
  renderCell region (TableCell w _ _) ctx =
      render w region ctx
  
  colBorders :: BorderStyle -> Bool
  colBorders (BorderPartial fs) = Columns `elem` fs
  colBorders BorderFull = True
  colBorders _ = False
  
  edgeBorders :: BorderStyle -> Bool
  edgeBorders (BorderPartial fs) = Edges `elem` fs
  edgeBorders BorderFull = True
  edgeBorders _ = False
  
  rowBorders :: BorderStyle -> Bool
  rowBorders (BorderPartial fs) = Rows `elem` fs
  rowBorders BorderFull = True
  rowBorders _ = False
  
  rowHeight :: [Image] -> Int
  rowHeight = maximum . map imageHeight
  
  renderRow :: Widget Table -> DisplayRegion -> [TableCell] -> RenderContext -> IO Image
  renderRow tbl sz cells ctx = do
    specs <- columnSpecs <~~ tbl
    borderSty <- borderStyle <~~ tbl
    bAttr <- borderAttr <~~ tbl
    aw <- autoWidth tbl sz
  
    let sk = skin ctx
        sizes = map columnSize specs
        att = mergeAttrs [ overrideAttr ctx
                         , normalAttr ctx
                         ]
        newDefault = normalAttr ctx
  
    cellImgs <-
        forM (zip cells sizes) $ \(cellW, sizeSpec) ->
            do
              let cellSz = (cellWidth, regionHeight sz)
                  cellWidth = case sizeSpec of
                                ColFixed n -> toEnum n
                                ColAuto -> aw
  
              img <- renderCell cellSz cellW $ ctx { normalAttr = newDefault }
              -- Right-pad the image if it isn't big enough to fill the
              -- cell.
              case compare (imageWidth img) (regionWidth cellSz) of
                EQ -> return img
                LT -> return $ img <|> charFill att ' '
                         (max 0 (regionWidth cellSz - imageWidth img))
                         (max (imageHeight img) 1)
                GT -> throw CellImageTooBig
  
    let maxHeight = rowHeight cellImgs
        cellImgsBottomPadded = (flip map) cellImgs $ \img ->
                               img <-> charFill att ' ' (imageWidth img) (maxHeight - imageHeight img)
  
    -- If we need to draw borders in between columns, do that.
    let bAttr' = mergeAttrs [ overrideAttr ctx
                            , bAttr
                            , normalAttr ctx
                            ]
        withBorders = case colBorders borderSty of
                        False -> cellImgsBottomPadded
                        True -> intersperse (charFill bAttr' (skinVertical sk) 1 maxHeight) cellImgsBottomPadded
  
    return $ horizCat withBorders
  