]> Git — Sourcephile - comptalang.git/blob - lcc/Hcompta/LCC/Write/Table.hs
Commit old WIP.
[comptalang.git] / lcc / Hcompta / LCC / Write / Table.hs
1 module Hcompta.LCC.Write.Table where
2
3 import Data.Bool
4 import Data.Char (Char)
5 import Data.Eq (Eq(..))
6 import Data.Foldable (any, foldr)
7 import Data.Functor ((<$>))
8 import Data.Maybe (Maybe(..), fromMaybe)
9 import Data.Ord (Ord(..))
10 import Data.Semigroup (Semigroup(..))
11 import Data.Text (Text)
12 import Data.Tuple (curry)
13 import Prelude (($), (.), Int, Integral(..), Num(..), fromIntegral, id, zipWith, toInteger)
14 import Text.Show (Show)
15 import qualified Data.List as L
16 import qualified Data.Text as T
17 import qualified Data.Text.Lazy as TL
18
19 import Hcompta.LCC.Write.Compta
20 import qualified Language.Symantic.Document as D
21 import qualified Language.Symantic.Document.Term.Dimension as Dim
22
23 -- * Type 'Table'
24 type Table d = [Column d]
25
26 instance (D.Textable d, D.Colorable d, D.Indentable d) => Writeable d (Table d) where
27 write cols' =
28 let cols = refreshWidthCol <$> cols' in
29 let rows = L.transpose $ column_rows <$> cols in
30 let has_title = any (not . T.null . column_title) cols in
31 let titles :: d = D.catH $ L.intersperse (d_sep '|') $ d_title <$> cols in
32 D.catV (
33 (if has_title then (:) titles else id) $
34 (<$> rows) $ \row ->
35 D.catH $
36 L.intersperse (D.space <> d_sep '|') $
37 ((D.space <>) <$>) $
38 zipWith (curry $ alignCell Nothing) cols row
39 ) <>
40 (case cols of { [] -> D.empty; _ -> D.newline })
41 where
42 refreshWidthCol col@Column{column_width=w} =
43 if w == 0
44 then col{column_width = widthCol col}
45 else col
46 where
47 widthCol :: Column d -> Int
48 widthCol Column
49 { column_title
50 , column_rows } =
51 max (T.length column_title) $
52 foldr (max . cell_width) 0 column_rows
53 d_title :: Column d -> d
54 d_title col@Column{column_title} = do
55 let pad len = D.blacker $ D.text $ T.pack $ L.replicate len '_'
56 alignCell (Just pad) (col, Cell
57 { cell_width = T.length column_title
58 , cell_content = d_under <> d_underline column_title <> d_under
59 , cell_align = Just AlignC
60 })
61 d_sep = D.blacker . D.charH
62 d_under = d_sep '_'
63 d_underline t =
64 D.catH $ (<$> T.unpack t) $ \case
65 ' ' -> d_under
66 c -> D.charH c
67
68 alignCell ::
69 D.Textable d =>
70 D.Colorable d => D.Indentable d =>
71 Maybe (Int -> d) ->
72 (Column d, Cell d) -> d
73 alignCell may_padding
74 ( Column{column_align, column_width}
75 , Cell{cell_width, cell_content, cell_align} ) =
76 let pad = column_width - cell_width in
77 case column_align `fromMaybe` cell_align of
78 AlignL -> cell_content <> padding pad
79 AlignC -> padding half <> cell_content <> padding (pad - half)
80 where half = fromInteger $ quot (toInteger pad) 2
81 AlignR -> padding pad <> cell_content
82 where padding = (D.spaces . D.Nat . toInteger) `fromMaybe` may_padding
83 alignCell _filling
84 ( Column{column_width}
85 , Cell_Line{cell_pad} ) =
86 D.blacker $ D.ltextH $
87 TL.replicate (fromIntegral column_width) $
88 TL.singleton cell_pad
89
90 -- ** Class 'TableOf'
91 class TableOf a d where
92 tableOf :: a -> Table d
93
94 -- * Type 'Column'
95 data Column d
96 = Column
97 { column_title :: Text
98 , column_align :: Align
99 , column_width :: Int
100 , column_rows :: [Cell d]
101 } deriving (Eq, Show)
102
103 column :: Text -> Align -> [Cell d] -> Column d
104 column t a r =
105 Column
106 { column_title = t
107 , column_align = a
108 , column_width = 0
109 , column_rows = r
110 }
111
112 -- ** Type 'Align'
113 data Align
114 = AlignL
115 | AlignC
116 | AlignR
117 deriving (Eq, Show)
118
119 -- ** Class 'columnOf'
120 class ColumnOf a d where
121 columnOf :: a -> Column d
122
123 -- * Type 'Cell'
124 data Cell d
125 = Cell { cell_align :: Maybe Align
126 , cell_width :: Int
127 , cell_content :: d
128 }
129 | Cell_Line { cell_pad :: Char
130 , cell_width :: Int
131 }
132 deriving (Eq, Show)
133
134 -- ** Class 'CellOf'
135 class CellOf a d where
136 cellOf :: a -> Cell d
137 default cellOf ::
138 Writeable Dim.Dimension a =>
139 Writeable d a =>
140 a -> Cell d
141 cellOf = cell
142
143 instance D.Textable d => CellOf () d where
144 cellOf () = Cell
145 { cell_width = 0
146 , cell_align = Nothing
147 , cell_content = D.empty
148 }
149
150 cell ::
151 Writeable Dim.Dimension a =>
152 Writeable d a =>
153 a -> Cell d
154 cell a =
155 Cell
156 { cell_width = fromIntegral $ D.unNat $ Dim.dim_width $ Dim.dim $ write a
157 , cell_align = Nothing
158 , cell_content = write a
159 }
160
161
162
163
164
165
166 {-
167 instance ToDoc Column Cell where
168 toDoc = alignCell Nothing
169
170 -- ** Class 'CellOf'
171 class CellOf context x where
172 cellOf :: context -> x -> Cell
173
174 instance CellOf context x => CellOf context (Maybe x) where
175 cellOf ctx = maybe cell (cellOf ctx)
176
177 -- ** Class 'Cell_of_forall_param'
178
179 -- | A class useful when using a context of kind '*' is not wanted
180 -- for example in a class instance constraint
181 -- to keep the instance decidable (i.e. avoid UndecidableInstances).
182 class Cell_of_forall_param f x where
183 cell_of_forall_param :: forall m. f m -> x -> Cell
184 -- instance Cell_of_forall_param f x => CellOf (f m) x where
185 -- cellOf = cell_of_forall_param
186 instance Cell_of_forall_param context x => Cell_of_forall_param context (Maybe x) where
187 cell_of_forall_param ctx = maybe cell (cell_of_forall_param ctx)
188 -}