]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Lib/Leijen/Table.hs
Suppression : Lib.Foldable : Composition déjà dans Data.Functor.Compose.
[comptalang.git] / cli / Hcompta / CLI / Lib / Leijen / Table.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 module Hcompta.CLI.Lib.Leijen.Table where
5
6 import qualified Data.List
7 import Data.Maybe (fromMaybe)
8 import qualified Data.Text.Lazy as TL
9 import Data.Text (Text)
10 import qualified Data.Text as Text
11
12 import qualified Hcompta.Lib.Leijen as W
13 import Hcompta.Lib.Leijen ((<>), toDoc, ToDoc(..))
14
15 -- * The 'Table' type
16
17 type Table = [Column]
18
19 -- * The 'Column' type
20
21 data Column
22 = Column
23 { column_title :: Text
24 , column_width :: Int
25 , column_align :: Align
26 , column_rows :: [Cell]
27 }
28 instance ToDoc m [Column] where
29 toDoc _m cols = do
30 let rows = Data.List.transpose $ map column_rows cols
31 let has_title = any (not . Text.null . column_title) cols
32 let titles =
33 W.intercalate (W.bold $ W.dullblack $ W.char '|')
34 (\col@Column{column_title} -> do
35 let cell_width = Text.length column_title
36 let under = W.bold $ W.dullblack $ W.char '_'
37 let cell_content = W.enclose under under $
38 W.hcat $ map
39 (\c -> case c of { ' ' -> under; _ -> W.char c })
40 (Text.unpack column_title)
41 let pad len = W.bold $ W.dullblack $
42 W.text $ TL.pack $ replicate len '_'
43 align (Just pad) col
44 Cell{cell_width, cell_content, cell_align=Just Align_Center}
45 ) cols
46 W.vsep (
47 (if has_title then (:) titles else id) $
48 map
49 ( W.intercalate (W.space <> do W.bold $ W.dullblack $ W.char '|') id
50 . map (W.space <>)
51 . zipWith toDoc cols
52 ) rows
53 ) <> do
54 (if null cols then W.empty else W.line)
55 column :: Text -> Align -> [Cell] -> Column
56 column column_title column_align column_rows =
57 Column
58 { column_title
59 , column_width = max (Text.length column_title) $
60 foldr (max . cell_width) 0 column_rows
61 , column_align
62 , column_rows
63 }
64
65 -- ** The 'Align' type
66
67 data Align
68 = Align_Left
69 | Align_Center
70 | Align_Right
71 align :: Maybe (Int -> W.Doc) -> Column -> Cell -> W.Doc
72 align filling
73 Column{column_width, column_align}
74 Cell{cell_width, cell_content, cell_align} =
75 let pad = column_width - cell_width in
76 let fill =
77 case filling of
78 Nothing -> \l -> W.fill l W.empty
79 Just f -> f in
80 case fromMaybe column_align cell_align of
81 Align_Left -> cell_content <> fill pad
82 Align_Center ->
83 let half = fromInteger $ quot (toInteger pad) 2 in
84 fill half <> cell_content <> fill (pad - half)
85 Align_Right -> fill pad <> cell_content
86 align _filling
87 Column{column_width}
88 (Cell_Line {cell_pad}) =
89 W.bold $ W.dullblack $ W.text $
90 TL.replicate (fromIntegral column_width) $
91 TL.singleton cell_pad
92
93 -- * The 'Cell' type
94
95 data Cell
96 = Cell
97 { cell_align :: Maybe Align
98 , cell_width :: Int
99 , cell_content :: W.Doc
100 }
101 | Cell_Line
102 { cell_pad :: Char
103 , cell_width :: Int
104 }
105 cell :: Cell
106 cell =
107 Cell
108 { cell_width = 0
109 , cell_content = W.empty
110 , cell_align = Nothing
111 }
112 instance ToDoc Column Cell where
113 toDoc = align Nothing