summaryrefslogtreecommitdiff
path: root/lib/Patat/Presentation/Display/Table.hs
blob: fee68c97b63ff35bf5747f2ea75071fe541e156b (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
--------------------------------------------------------------------------------
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}
module Patat.Presentation.Display.Table
    ( Table (..)
    , prettyTable

    , themed
    ) where


--------------------------------------------------------------------------------
import           Data.List         (intersperse, transpose)
import           Data.Monoid       (mconcat, mempty, (<>))
import           Patat.PrettyPrint ((<$$>))
import qualified Patat.PrettyPrint as PP
import           Patat.Theme       (Theme (..))
import qualified Patat.Theme       as Theme
import           Prelude


--------------------------------------------------------------------------------
data Table = Table
    { tCaption :: PP.Doc
    , tAligns  :: [PP.Alignment]
    , tHeaders :: [PP.Doc]
    , tRows    :: [[PP.Doc]]
    }


--------------------------------------------------------------------------------
prettyTable
    :: Theme -> Table -> PP.Doc
prettyTable theme@Theme {..} Table {..} =
    PP.indent (PP.Trimmable "  ") (PP.Trimmable "  ") $
        lineIf (not isHeaderLess) (hcat2 headerHeight
            [ themed themeTableHeader (PP.align w a (vpad headerHeight header))
            | (w, a, header) <- zip3 columnWidths tAligns tHeaders
            ]) <>
        dashedHeaderSeparator theme columnWidths <$$>
        joinRows
            [ hcat2 rowHeight
                [ PP.align w a (vpad rowHeight cell)
                | (w, a, cell) <- zip3 columnWidths tAligns row
                ]
            | (rowHeight, row) <- zip rowHeights tRows
            ] <$$>
        lineIf isHeaderLess (dashedHeaderSeparator theme columnWidths) <>
        lineIf
            (not $ PP.null tCaption) (PP.hardline <> "Table: " <> tCaption)
  where
    lineIf cond line = if cond then line <> PP.hardline else mempty

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

    isHeaderLess = all PP.null tHeaders

    headerDimensions = map PP.dimensions tHeaders :: [(Int, Int)]
    rowDimensions    = map (map PP.dimensions) tRows :: [[(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 :: Theme -> [Int] -> PP.Doc
dashedHeaderSeparator Theme {..} columnWidths =
    mconcat $ intersperse (PP.string "  ")
        [ themed themeTableSeparator (PP.string (replicate w '-'))
        | w <- columnWidths
        ]


--------------------------------------------------------------------------------
-- | This does not really belong in the module.
themed :: Maybe Theme.Style -> PP.Doc -> PP.Doc
themed Nothing                    = id
themed (Just (Theme.Style []))    = id
themed (Just (Theme.Style codes)) = PP.ansi codes