]> Git — Sourcephile - haskell/literate-accounting.git/blob - src/Literate/Table.hs
93c9c9320193ffac9e6eba9b81108112f41484a9
[haskell/literate-accounting.git] / src / Literate / Table.hs
1 {-# LANGUAGE ConstrainedClassMethods #-}
2 {-# LANGUAGE DefaultSignatures #-}
3 -- Remove this
4 {-# LANGUAGE DeriveDataTypeable #-}
5 -- Remove this
6 {-# LANGUAGE DeriveGeneric #-}
7 {-# LANGUAGE FlexibleContexts #-}
8 {-# LANGUAGE FlexibleInstances #-}
9 {-# LANGUAGE FunctionalDependencies #-}
10 {-# LANGUAGE GADTs #-}
11 {-# LANGUAGE MultiParamTypeClasses #-}
12 {-# LANGUAGE OverloadedStrings #-}
13 {-# LANGUAGE Rank2Types #-}
14 {-# LANGUAGE ScopedTypeVariables #-}
15 {-# LANGUAGE StandaloneDeriving #-}
16 {-# LANGUAGE TypeOperators #-}
17 {-# LANGUAGE UndecidableInstances #-}
18
19 {- | Module implements the default methods for Tabulate
20 All examples listed in the document need the following language pragmas
21 and following modules imported
22
23 @
24 {#- LANGUAGE MultiParamTypeClasses}
25 {#- LANGUAGE DeriveGeneric}
26 {#- LANGUAGE DeriveDataTypeable}
27
28 import qualified GHC.Generics as G
29 import Data.Data
30 @
31 -}
32 module Literate.Table where
33
34 --import Data.Generics.Aliases
35
36 import Data.Bool (Bool)
37 import Data.Data
38 import Data.Foldable (foldMap)
39 import Data.Function (($), (.))
40 import Data.Functor (fmap)
41 import Data.Int (Int)
42 import Data.List ((++))
43 import Data.List qualified as L
44 import Data.List qualified as List
45 import Data.Map qualified as Map
46 import Data.Maybe
47 import Data.String (String)
48 import Data.Tree
49 import Data.Typeable
50 import GHC.Err (undefined)
51 import GHC.Float (Float)
52 import GHC.Generics as G
53 import GHC.Num (Integer, (+), (-))
54 import GHC.Show
55 import Literate.Box qualified as B
56 import System.IO (IO)
57 import Text.Printf
58 import Prelude (Double, error)
59
60 -- | * Class 'GRecordMeta'
61 class GRecordMeta f where
62 toTree :: f a -> [Tree String]
63
64 instance GRecordMeta U1 where
65 toTree U1 = []
66 instance (GRecordMeta a, GRecordMeta b) => GRecordMeta (a :*: b) where
67 toTree (x :*: y) = toTree x ++ toTree y
68 instance (GRecordMeta a, GRecordMeta b) => GRecordMeta (a :+: b) where
69 toTree (G.L1 x) = toTree x
70 toTree (G.R1 x) = toTree x
71 instance (GRecordMeta a, Selector s) => GRecordMeta (M1 S s a) where
72 toTree a = [Node (selName a) $ toTree (unM1 a)]
73 instance (GRecordMeta a, Constructor c) => GRecordMeta (M1 C c a) where
74 -- we don't want to build node for constructor
75 --toTree a = [Node (conName a) $ toTree (unM1 a)]
76 toTree a = toTree (unM1 a)
77 instance (GRecordMeta a) => GRecordMeta (M1 D c a) where
78 toTree (M1 x) = toTree x
79 instance (CellValueFormatter a, Data a, RecordMeta a) => GRecordMeta (K1 i a) where
80 --toTree x = [Node (show (unK1 x)) (toTree' $ unK1 x)]
81 toTree x = toTree' $ unK1 x
82
83 {- | Use this flag to expand a Record Type as a table when
84 nested inside another record.
85 -}
86 data ExpandWhenNested
87
88 {- | Use this flag to not expand a Record type as a table when
89 nested inside another record. The 'Show' instance of the nested record
90 is used by default without expanding. This means that the fields of the
91 nested record are not displayed as separate headers.
92 -}
93 data DoNotExpandWhenNested
94
95 {- | Class instance that needs to be instantiated for each
96 record that needs to be printed using printTable
97
98 @
99
100 data Stock = Stock {price:: Double, name:: String} derive (Show, G.Generic, Data)
101 instance Tabulate S 'ExpandWhenNested'
102 @
103
104 If 'S' is embedded inside another `Record` type and should be
105 displayed in regular Record Syntax, then
106
107 @
108
109 instance Tabulate S 'DoNotExpandWhenNested'
110 @
111 -}
112 class Tabulate a flag | a -> flag
113
114 --instance TypeCast flag HFalse => Tabulate a flag
115 instance {-# OVERLAPPABLE #-} (flag ~ DoNotExpandWhenNested) => Tabulate a flag
116
117 class RecordMeta a where
118 toTree' :: a -> [Tree String]
119 instance (Tabulate a flag, RecordMeta' flag a) => RecordMeta a where
120 toTree' = toTree'' (undefined :: proxy flag)
121
122 class RecordMeta' flag a where
123 toTree'' :: proxy flag -> a -> [Tree String]
124 instance (G.Generic a, GRecordMeta (Rep a)) => RecordMeta' ExpandWhenNested a where
125 toTree'' _ a = toTree (G.from a)
126 instance (CellValueFormatter a) => RecordMeta' DoNotExpandWhenNested a where
127 toTree'' _ a = [Node (ppFormatter a) []]
128
129 {- | Class that implements formatting using printf.
130 Default instances for String, Char, Int, Integer, Double and Float
131 are provided. For types that are not an instance of this class
132 `show` is used.
133 -}
134 class CellValueFormatter a where
135 -- Function that can be implemented by each instance
136 ppFormatter :: a -> String
137 -- Future support for this signature will be added
138 --ppFormatterWithStyle :: TablizeValueFormat -> a -> String
139
140 -- Default instance of function for types that do
141 -- do not have their own instance
142 default ppFormatter :: (Show a) => a -> String
143 ppFormatter x = show x
144
145 instance CellValueFormatter Integer where
146 ppFormatter x = printf "%d" x
147 instance CellValueFormatter Int where
148 ppFormatter x = printf "%d" x
149 instance CellValueFormatter Float where
150 ppFormatter x = printf "%14.7g" x
151 instance CellValueFormatter String where
152 ppFormatter x = printf "%s" x
153 instance CellValueFormatter Double where
154 ppFormatter x = printf "%14.7g" x
155 instance CellValueFormatter Bool
156 instance (Show a, CellValueFormatter a) => CellValueFormatter (Maybe a)
157
158 gen_renderTableWithFlds :: [DisplayFld t] -> [t] -> B.Box
159 gen_renderTableWithFlds flds recs = results
160 where
161 col_wise_values = fmap (\(DFld f) -> fmap (ppFormatter . f) recs) flds
162 vertical_boxes = fmap (B.vsep 0 B.AlignTopLeft) $ fmap (fmap B.text) col_wise_values
163 results = B.hsep 5 B.AlignTopLeft vertical_boxes
164
165 class Boxable b where
166 printTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> IO ()
167
168 --printTableWithStyle :: (Data a, G.Generic a, GTabulate(Rep a)) => TablizeValueFormat -> b a -> IO ()
169
170 renderTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> B.Box
171 printTableWithFlds :: [DisplayFld t] -> b t -> IO ()
172 renderTableWithFlds :: [DisplayFld t] -> b t -> B.Box
173
174 -- | Instance methods to render or print a list of records in a tabular format.
175 instance Boxable [] where
176 printTable m = B.printBox $ ppRecords m
177
178 renderTable m = ppRecords m
179 printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs
180 renderTableWithFlds = gen_renderTableWithFlds
181
182 {-
183 instance Boxable V.Vector where
184 -- | Prints a "Vector" as a table. Called by "printTable".
185 -- | Need not be called directly
186 printTable m = B.printBox $ renderTable m --TODO: switch this to Vector
187 renderTable m = ppRecords $ V.toList m
188
189 -- | Print a "Vector" of records as a table with the selected fields.
190 -- Called by "printTableWithFlds".
191 printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds $ V.toList recs
192 renderTableWithFlds flds recs = gen_renderTableWithFlds flds $ V.toList recs
193 -}
194
195 instance (CellValueFormatter k) => Boxable (Map.Map k) where
196 printTable m = B.printBox $ renderTable m
197 renderTable m = ppRecordsWithIndex m
198 printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs
199
200 renderTableWithFlds flds recs = results
201 where
202 data_cols = renderTableWithFlds flds $ Map.elems recs
203 index_cols = B.vsep 0 B.AlignTopLeft $ fmap (B.text . ppFormatter) $ Map.keys recs
204 vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols]
205 results = vertical_cols
206
207 -- Pretty Print the reords as a table. Handles both records inside
208 -- Lists and Vectors
209 ppRecords :: (GRecordMeta (Rep a), G.Generic a) => [a] -> B.Box
210 ppRecords recs = result
211 where
212 result = B.hsep 5 B.AlignTopLeft $ createHeaderDataBoxes recs
213
214 -- Pretty Print the records as a table. Handles records contained in a Map.
215 -- Functions also prints the keys as the index of the table.
216 ppRecordsWithIndex :: (CellValueFormatter k, GRecordMeta (Rep a), G.Generic a) => (Map.Map k a) -> B.Box
217 ppRecordsWithIndex recs = result
218 where
219 data_boxes = createHeaderDataBoxes $ Map.elems recs
220 index_box = createIndexBoxes recs
221 result = B.hsep 5 B.AlignTopLeft $ index_box : data_boxes
222
223 -- What follows are helper functions to build the B.Box structure to print as table.
224
225 -- Internal helper functions for building the Tree.
226
227 -- Build the list of paths from the root to every leaf.
228 constructPath :: Tree a -> [[a]]
229 constructPath (Node r []) = [[r]]
230 constructPath (Node r f) = [r : x | x <- (L.concatMap constructPath f)]
231
232 -- Fill paths with a "-" so that all paths have the
233 -- same length.
234 fillPath paths = stripped_paths
235 where
236 depth = L.maximum $ L.map L.length paths
237 diff = L.map (\p -> depth - (L.length p)) paths
238 new_paths = L.map (\(p, d) -> p ++ L.replicate d "-") $ L.zip paths diff
239 stripped_paths = [xs | x : xs <- new_paths]
240
241 -- Count the number of fields in the passed structure.
242 -- The no of leaves is the sum of all fields across all nested
243 -- records in the passed structure.
244 countLeaves :: Tree a -> Tree (Int, a)
245 countLeaves (Node r f) = case f of
246 [] -> Node (1, r) []
247 x -> countLeaves' x
248 where
249 countLeaves' x =
250 let count_leaves = fmap countLeaves x
251 level_count = List.foldr (\(Node (c, a) _) b -> c + b) 0 count_leaves
252 in Node (level_count, r) count_leaves
253
254 -- Trims a the tree of records and return just the
255 -- leaves of the record
256 trimTree (Node r f) = trimLeaves r f
257
258 -- Helper function called by trimTree.
259 trimLeaves r f = Node r (trimLeaves' f)
260 where
261 trimLeaves' f =
262 let result = fmap trimLeaves'' f
263 where
264 trimLeaves'' (Node r' f') =
265 let result' = case f' of
266 [] -> Nothing
267 _ -> Just $ trimLeaves r' f'
268 in result'
269 in catMaybes result
270
271 -- Get all the leaves from the record. Returns all leaves
272 -- across the record structure.
273 getLeaves :: (CellValueFormatter a) => Tree a -> [String]
274 getLeaves (Node r f) = case f of
275 [] -> [(ppFormatter r)]
276 _ -> foldMap getLeaves f
277
278 recsToTrees recs = fmap (\a -> Node "root" $ (toTree . G.from $ a)) $ recs
279
280 getHeaderDepth rec_trees = header_depth
281 where
282 header_depth = L.length . L.head . fillPath . constructPath . trimTree . L.head $ rec_trees
283
284 createBoxedHeaders :: [[String]] -> [B.Box]
285 createBoxedHeaders paths = boxes
286 where
287 boxes = L.map wrapWithBox paths
288 wrapWithBox p = B.vsep 0 B.AlignTopLeft $ L.map B.text p
289
290 --createHeaderCols :: [Tree String] -> [B.Box]
291 createHeaderCols rec_trees = header_boxes
292 where
293 header_boxes = createBoxedHeaders . fillPath . constructPath . trimTree . L.head $ rec_trees
294
295 --createDataBoxes :: [Tree a] -> [B.Box]
296 createDataBoxes rec_trees = vertical_boxes
297 where
298 horizontal_boxes = fmap (fmap B.text) $ fmap getLeaves rec_trees
299 vertical_boxes = fmap (B.vsep 0 B.AlignTopLeft) $ L.transpose horizontal_boxes
300
301 --createIndexBoxes :: Map.Map a a -> B.Box
302 createIndexBoxes recs = index_box
303 where
304 rec_trees = recsToTrees $ Map.elems recs
305 header_depth = getHeaderDepth rec_trees
306 index_col = (L.replicate header_depth "-") ++ (L.map ppFormatter $ Map.keys recs)
307 index_box = B.vsep 0 B.AlignTopLeft $ L.map B.text index_col
308
309 createHeaderDataBoxes recs = vertical_boxes
310 where
311 rec_trees = recsToTrees recs
312 header_boxes = createHeaderCols rec_trees
313 data_boxes = createDataBoxes rec_trees
314 vertical_boxes = fmap (\(a, b) -> B.vsep 0 B.AlignTopLeft $ [a, b]) $ L.zip header_boxes data_boxes
315
316 -- testing
317
318 data T = C1 {aInt :: Double, aString :: String} deriving (Data, Typeable, Show, G.Generic)
319 data T1 = C2 {t1 :: T, bInt :: Double, bString :: String} deriving (Data, Typeable, Show, G.Generic)
320
321 c1 = C1 1000 "record_c1fdsafaf"
322 c2 = C2 c1 100.12121 "record_c2"
323 c3 = C2 c1 1001.12111 "record_c2fdsafdsafsafdsafasfa"
324 c4 = C2 c1 22222.12121 "r"
325
326 instance Tabulate T ExpandWhenNested
327 instance Tabulate T1 ExpandWhenNested
328 instance CellValueFormatter T
329
330 data R2 = R2 {a :: Maybe Integer} deriving (G.Generic, Show)
331 data R3 = R3 {r31 :: Maybe Integer, r32 :: String} deriving (G.Generic, Show)
332 tr = Node "root" (toTree . G.from $ c2)
333 r2 = Node "root" (toTree . G.from $ (R2 (Just 10)))
334 r3 = Node "root" (toTree . G.from $ (R3 (Just 10) "r3_string"))
335
336 -- | Used with 'printTableWithFlds'
337 data DisplayFld a = forall s. CellValueFormatter s => DFld (a -> s)
338
339 -- printTableWithFlds2 :: [DisplayFld t] -> V.Vector t -> IO ()
340 -- printTableWithFlds2 flds recs = B.printBox $ printTableWithFlds flds $ V.toList recs
341
342 -- printTableWithFlds3 :: (CellValueFormatter k) => [DisplayFld t] -> Map.Map k t -> String
343 -- printTableWithFlds3 flds recs = results
344 -- where
345 -- data_cols = renderTableWithFlds flds $ Map.elems recs
346 -- index_cols = B.vsep 0 B.AlignTopLeft $ fmap (B.text . ppFormatter) $ Map.keys recs
347 -- vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols]
348 -- results = B.render vertical_cols
349
350 data R00
351 = R00
352 { r00Int :: Int
353 , r00String :: String
354 }
355 | R00_
356 { r00_Int :: Int
357
358
359 -- R0 has to derive from Data, since
360 -- it will be nested
361 data R01 = R01
362 { test_string :: String
363 , test_integer :: Integer
364 , test_float :: Float
365 , test_DOUBLE :: Maybe Double
366 }
367 deriving (Data, Show, G.Generic)
368 instance CellValueFormatter R01
369
370 data R02 = R02 {r2_r00 :: R00, r2_r01 :: R01}
371 deriving (Show, G.Generic, Data)
372 instance CellValueFormatter R02
373
374 data R03 = R03 {r3_id :: Int, r3_r02 :: R02}
375 deriving (Show, G.Generic, Data)
376
377 instance Tabulate R01 ExpandWhenNested
378 instance Tabulate R02 ExpandWhenNested
379 instance Tabulate R03 ExpandWhenNested
380
381 getR01 =
382 R01
383 { test_string = "Jack-Jack"
384 , test_integer = 10
385 , test_DOUBLE = Just 10.101
386 , test_float = 0.101021
387 }
388
389 getR02 = R02{r2_r00 = R00_ 100 "foo", r2_r01 = getR01}
390
391 getR03 = R03{r3_id = 200, r3_r02 = getR02}
392
393 recordsList = List.replicate 2 $ getR03
394
395 -- >>> recordsList
396 -- [R03 {r3_id = 20, nested_r02 = R02 {r2_id = 10, nested_r = R01 {test_string = "Jack-Jack", test_integer = 10, test_float = 0.101021, test_double = 10.101}}}
397 -- ,R03 {r3_id = 20, nested_r02 = R02 {r2_id = 10, nested_r = R01 {test_string = "Jack-Jack", test_integer = 10, test_float = 0.101021, test_double = 10.101}}}]
398 --
399 -- >>> B.rows $ renderTable recordsList
400 -- 5
401 --
402 -- >>> B.cols $ renderTable recordsList
403 -- 91
404
405 -- >>> error $ B.render $ renderTable recordsList
406 -- r3_id r3_r02 r3_r02 r3_r02 r3_r02 r3_r02 r3_r02
407 -- - r2_r00 r2_r00 r2_r01 r2_r01 r2_r01 r2_r01
408 -- - r00Int r00String test_string test_integer test_float test_DOUBLE
409 -- 200 100 foo Jack-Jack 10 0.1010210 Just 10.101
410 -- 200 100 foo Jack-Jack 10 0.1010210 Just 10.101
411
412 recordsMap =
413 Map.fromList
414 [ ("key1", getR03)
415 , ("key2", getR03)
416 , ("key3", getR03{r3_id = 32})
417 ]
418
419 -- >>> B.rows $ renderTable recordsMap
420 -- 5
421
422 -- >>> B.cols $ renderTable recordsMap
423 -- 100
424
425 -- >>> error $ B.render $ renderTable recordsMap
426 -- - r3_id r3_r02 r3_r02 r3_r02 r3_r02 r3_r02 r3_r02
427 -- - - r2_r00 r2_r00 r2_r01 r2_r01 r2_r01 r2_r01
428 -- - - r00Int r00String test_string test_integer test_float test_DOUBLE
429 -- key1 200 100 foo Jack-Jack 10 0.1010210 Just 10.101
430 -- key2 200 100 foo Jack-Jack 10 0.1010210 Just 10.101
431 -- key3 32 100 foo Jack-Jack 10 0.1010210 Just 10.101