Table.hs

--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Patat.Presentation.Display.Table
    ( TableDisplay (..)
    , prettyTableDisplay

    , themed
    ) where


--------------------------------------------------------------------------------
import           Data.List                           (intersperse, transpose)
import           Patat.Presentation.Display.Internal
import           Patat.PrettyPrint                   ((<$$>))
import qualified Patat.PrettyPrint                   as PP
import           Patat.Theme                         (Theme (..))
import           Prelude


--------------------------------------------------------------------------------
data TableDisplay = TableDisplay
    { tdCaption :: PP.Doc
    , tdAligns  :: [PP.Alignment]
    , tdHeaders :: [PP.Doc]
    , tdRows    :: [[PP.Doc]]
    }


--------------------------------------------------------------------------------
prettyTableDisplay :: DisplaySettings -> TableDisplay -> PP.Doc
prettyTableDisplay ds TableDisplay {..} =
    PP.indent indentation indentation $
        lineIf (not isHeaderLess) (hcat2 headerHeight
            [ themed ds themeTableHeader $
                PP.align w a (vpad headerHeight header)
            | (w, a, header) <- zip3 columnWidths tdAligns tdHeaders
            ]) <>
        dashedHeaderSeparator ds columnWidths <$$>
        joinRows
            [ hcat2 rowHeight
                [ PP.align w a (vpad rowHeight cell)
                | (w, a, cell) <- zip3 columnWidths tdAligns row
                ]
            | (rowHeight, row) <- zip rowHeights tdRows
            ] <$$>
        lineIf isHeaderLess (dashedHeaderSeparator ds columnWidths) <>
        lineIf
            (not $ PP.null tdCaption) (PP.hardline <> "Table: " <> tdCaption)
  where
    indentation = PP.Indentation 2 mempty

    lineIf cond line = if cond then line <> PP.hardline else mempty

    joinRows
        | all (all isSimpleCell) tdRows = PP.vcat
        | otherwise                    = PP.vcat . intersperse ""

    isHeaderLess = all PP.null tdHeaders

    headerDimensions = map PP.dimensions tdHeaders :: [(Int, Int)]
    rowDimensions    = map (map PP.dimensions) tdRows :: [[(Int, Int)]]

    columnWidths :: [Int]
    columnWidths =
        [ safeMax (map snd col)
        | col <- transpose (headerDimensions : rowDimensions)
        ]

    rowHeights   = map (safeMax . map fst) rowDimensions :: [Int]
    headerHeight = safeMax (map fst headerDimensions)    :: Int

    vpad :: Int -> PP.Doc -> PP.Doc
    vpad height doc =
        let (actual, _) = PP.dimensions doc in
        doc <> mconcat (replicate (height - actual) PP.hardline)

    safeMax = foldr max 0

    hcat2 :: Int -> [PP.Doc] -> PP.Doc
    hcat2 rowHeight = PP.paste . intersperse (spaces2 rowHeight)

    spaces2 :: Int -> PP.Doc
    spaces2 rowHeight =
        mconcat $ intersperse PP.hardline $
        replicate rowHeight (PP.string "  ")


--------------------------------------------------------------------------------
isSimpleCell :: PP.Doc -> Bool
isSimpleCell = (<= 1) . fst . PP.dimensions


--------------------------------------------------------------------------------
dashedHeaderSeparator :: DisplaySettings -> [Int] -> PP.Doc
dashedHeaderSeparator ds columnWidths =
    mconcat $ intersperse (PP.string "  ")
        [ themed ds themeTableSeparator (PP.string (replicate w '-'))
        | w <- columnWidths
        ]