]> Git — Sourcephile - comptalang.git/blob - cli/Hcompta/CLI/Lib/Leijen/Table.hs
Adapte hcompta-cli.
[comptalang.git] / cli / Hcompta / CLI / Lib / Leijen / Table.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 {-# LANGUAGE NamedFieldPuns #-}
4 {-# LANGUAGE Rank2Types #-}
5 module Hcompta.CLI.Lib.Leijen.Table where
6
7 import Data.Bool
8 import Data.Char (Char)
9 import qualified Data.Foldable as Foldable
10 import qualified Data.List
11 import Data.List (map, replicate)
12 import Data.Maybe (Maybe(..), fromMaybe, maybe)
13 import Data.Monoid ((<>))
14 import Data.Ord (Ord(..))
15 import Data.Text (Text)
16 import qualified Data.Text as Text
17 import qualified Data.Text.Lazy as TL
18 import Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith)
19
20 import Text.WalderLeijen.ANSI.Text (ToDoc(..))
21 import qualified Text.WalderLeijen.ANSI.Text as W
22
23 -- * Type 'Table'
24
25 type Table = [Column]
26
27 -- ** Class 'Table_of'
28
29 class Table_of context x where
30 table_of :: context -> x -> Table
31
32 -- * Type 'Column'
33
34 data Column
35 = Column
36 { column_title :: Text
37 , column_width :: Int
38 , column_align :: Align
39 , column_rows :: [Cell]
40 }
41 instance ToDoc () [Column] where
42 toDoc _m cols =
43 let rows = Data.List.transpose $ map column_rows cols in
44 let has_title = Foldable.any (not . Text.null . column_title) cols in
45 let titles =
46 W.intercalate (W.bold $ W.dullblack $ W.char '|')
47 (\col@Column{column_title} -> do
48 let cell_width = Text.length column_title
49 let under = W.bold $ W.dullblack $ W.char '_'
50 let cell_content = W.enclose under under $
51 W.hcat $ map
52 (\c -> case c of { ' ' -> under; _ -> W.char c })
53 (Text.unpack column_title)
54 let pad len = W.bold $ W.dullblack $
55 W.text $ TL.pack $ replicate len '_'
56 align (Just pad) col
57 Cell{cell_width, cell_content, cell_align=Just Align_Center}
58 ) cols in
59 W.vsep (
60 (if has_title then (:) titles else id) $
61 map
62 ( W.intercalate (W.space <> W.bold (W.dullblack $ W.char '|')) id
63 . map (W.space <>)
64 . zipWith toDoc cols
65 ) rows
66 ) <>
67 (case cols of { [] -> W.empty; _ -> W.line })
68 column :: Text -> Align -> [Cell] -> Column
69 column column_title column_align column_rows =
70 Column
71 { column_title
72 , column_width = max (Text.length column_title) $
73 Foldable.foldr (max . cell_width) 0 column_rows
74 , column_align
75 , column_rows
76 }
77
78 -- ** Class 'Column_of'
79
80 class Column_of context x where
81 column_of :: context -> x -> Column
82
83 -- ** Type 'Align'
84
85 data Align
86 = Align_Left
87 | Align_Center
88 | Align_Right
89 align :: Maybe (Int -> W.Doc) -> Column -> Cell -> W.Doc
90 align filling
91 Column{column_width, column_align}
92 Cell{cell_width, cell_content, cell_align} =
93 let pad = column_width - cell_width in
94 let fill = fromMaybe (`W.fill` W.empty) filling in
95 case fromMaybe column_align cell_align of
96 Align_Left -> cell_content <> fill pad
97 Align_Center ->
98 let half = fromInteger $ quot (toInteger pad) 2 in
99 fill half <> cell_content <> fill (pad - half)
100 Align_Right -> fill pad <> cell_content
101 align _filling
102 Column{column_width}
103 (Cell_Line {cell_pad}) =
104 W.bold $ W.dullblack $ W.text $
105 TL.replicate (fromIntegral column_width) $
106 TL.singleton cell_pad
107
108 -- * Type 'Cell'
109
110 data Cell
111 = Cell
112 { cell_align :: Maybe Align
113 , cell_width :: Int
114 , cell_content :: W.Doc
115 }
116 | Cell_Line
117 { cell_pad :: Char
118 , cell_width :: Int
119 }
120 cell :: Cell
121 cell =
122 Cell
123 { cell_width = 0
124 , cell_content = W.empty
125 , cell_align = Nothing
126 }
127 instance ToDoc Column Cell where
128 toDoc = align Nothing
129
130 -- ** Class 'Cell_of'
131
132 class Cell_of context x where
133 cell_of :: context -> x -> Cell
134
135 instance Cell_of context x => Cell_of context (Maybe x) where
136 cell_of ctx = maybe cell (cell_of ctx)
137
138 -- ** Class 'Cell_of_forall_param'
139
140 -- | A class useful when using a context of kind '*' is not wanted
141 -- for example in a class instance constraint
142 -- to keep the instance decidable (i.e. avoid UndecidableInstances).
143 class Cell_of_forall_param f x where
144 cell_of_forall_param :: forall m. f m -> x -> Cell
145 -- instance Cell_of_forall_param f x => Cell_of (f m) x where
146 -- cell_of = cell_of_forall_param
147 instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
148 cell_of_forall_param ctx = maybe cell (cell_of_forall_param ctx)