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