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 (Functor, fmap, (<$>))
  41 import Data.Int (Int)
  42 import Data.List ((++))
  43 import Data.List qualified as List
  44 import Data.Map qualified as Map
  45 import Data.Maybe
  46 import Data.String (IsString (..), String)
  47 import Data.Tree
  48 import Data.Typeable
  49 import GHC.Err (undefined)
  50 import GHC.Float (Float)
  51 import GHC.Generics as G
  52 import GHC.Num (Integer, (+), (-))
  53 import GHC.Show
  54 import Literate.Box (Alignment (AlignTopLeft))
  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
  77 --toTree a = toTree (unM1 a)
  78 instance (GRecordMeta a) => GRecordMeta (M1 D c a) where
  79   toTree (M1 x) = toTree x
  80 instance (CellValueFormatter a, Data a, RecordMeta a) => GRecordMeta (K1 i a) where
  81   --toTree x = [Node (show (unK1 x)) (toTree' $ unK1 x)]
  82   toTree x = toTree' $ unK1 x
  83
  84 {- | Use this flag to expand a Record Type as a table when
  85  nested inside another record.
  86 -}
  87 data ExpandWhenNested
  88
  89 {- | Use this flag to not expand a Record type as a table when
  90  nested inside another record. The 'Show' instance of the nested record
  91  is used by default without expanding. This means that the fields of the
  92  nested record are not displayed as separate headers.
  93 -}
  94 data DoNotExpandWhenNested
  95
  96 {- | Class instance that needs to be instantiated for each
  97  record that needs to be printed using printTable
  98
  99  @
 100
 101  data Stock = Stock {price:: Double, name:: String} derive (Show, G.Generic, Data)
 102  instance Tabulate S 'ExpandWhenNested'
 103  @
 104
 105  If 'S' is embedded inside another `Record` type and should be
 106  displayed in regular Record Syntax, then
 107
 108  @
 109
 110  instance Tabulate S 'DoNotExpandWhenNested'
 111  @
 112 -}
 113 class Tabulate a flag | a -> flag
 114
 115 --instance TypeCast flag HFalse => Tabulate a flag
 116 instance {-# OVERLAPPABLE #-} (flag ~ DoNotExpandWhenNested) => Tabulate a flag
 117
 118 class RecordMeta a where
 119   toTree' :: a -> [Tree String]
 120 instance (Tabulate a flag, RecordMeta' flag a) => RecordMeta a where
 121   toTree' = toTree'' (undefined :: proxy flag)
 122
 123 class RecordMeta' flag a where
 124   toTree'' :: proxy flag -> a -> [Tree String]
 125 instance (G.Generic a, GRecordMeta (Rep a)) => RecordMeta' ExpandWhenNested a where
 126   toTree'' _ a = toTree (G.from a)
 127 instance (CellValueFormatter a) => RecordMeta' DoNotExpandWhenNested a where
 128   toTree'' _ a = [Node (ppFormatter a) []]
 129
 130 {- |  Class that implements formatting using printf.
 131     Default instances for String, Char, Int, Integer, Double and Float
 132     are provided. For types that are not an instance of this class
 133     `show` is used.
 134 -}
 135 class CellValueFormatter a where
 136   -- Function that can be implemented by each instance
 137   ppFormatter :: a -> String
 138   -- Future support for this signature will be added
 139   --ppFormatterWithStyle :: TablizeValueFormat -> a -> String
 140
 141   -- Default instance of function for types that do
 142   -- do not have their own instance
 143   default ppFormatter :: (Show a) => a -> String
 144   ppFormatter x = show x
 145
 146 instance CellValueFormatter Integer where
 147   ppFormatter x = printf "%d" x
 148 instance CellValueFormatter Int where
 149   ppFormatter x = printf "%d" x
 150 instance CellValueFormatter Float where
 151   ppFormatter x = printf "%g" x
 152 instance CellValueFormatter String where
 153   ppFormatter x = printf "%s" x
 154 instance CellValueFormatter Double where
 155   ppFormatter x = printf "%g" x
 156 instance CellValueFormatter Bool
 157 instance (Show a, CellValueFormatter a) => CellValueFormatter (Maybe a)
 158
 159 gen_renderTableWithFlds :: [DisplayFld t] -> [t] -> B.Box
 160 gen_renderTableWithFlds flds recs = results
 161   where
 162     col_wise_values = fmap (\(DFld f) -> fmap (ppFormatter . f) recs) flds
 163     vertical_boxes = fmap (B.vsep 0 B.AlignTopLeft) $ fmap (fmap fromString) col_wise_values
 164     results = B.hsep 5 B.AlignTopLeft vertical_boxes
 165
 166 class Boxable b where
 167   printTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> IO ()
 168
 169   --printTableWithStyle :: (Data a, G.Generic a, GTabulate(Rep a)) => TablizeValueFormat -> b a -> IO ()
 170
 171   renderTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> B.Box
 172   printTableWithFlds :: [DisplayFld t] -> b t -> IO ()
 173   renderTableWithFlds :: [DisplayFld t] -> b t -> B.Box
 174
 175 -- | Instance methods to render or print a list of records in a tabular format.
 176 instance Boxable [] where
 177   printTable m = B.printBox $ ppRecords m
 178
 179   renderTable m = ppRecords m
 180   printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs
 181   renderTableWithFlds = gen_renderTableWithFlds
 182
 183 {-
 184 instance Boxable V.Vector where
 185   -- | Prints a "Vector" as a table. Called by "printTable".
 186   -- | Need not be called directly
 187   printTable m = B.printBox $ renderTable m  --TODO: switch this to Vector
 188   renderTable m = ppRecords $ V.toList m
 189
 190   -- | Print a "Vector" of records as a table with the selected fields.
 191   -- Called by "printTableWithFlds".
 192   printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds $ V.toList recs
 193   renderTableWithFlds flds recs = gen_renderTableWithFlds flds $ V.toList recs
 194 -}
 195
 196 instance (CellValueFormatter k) => Boxable (Map.Map k) where
 197   printTable m = B.printBox $ renderTable m
 198   renderTable m = ppRecordsWithIndex m
 199   printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs
 200
 201   renderTableWithFlds flds recs = results
 202     where
 203       data_cols = renderTableWithFlds flds $ Map.elems recs
 204       index_cols = B.vsep 0 B.AlignTopLeft $ fmap (fromString . ppFormatter) $ Map.keys recs
 205       vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols]
 206       results = vertical_cols
 207
 208 -- Pretty Print the records as a table. Handles both records inside
 209 -- Lists and Vectors
 210 ppRecords :: (GRecordMeta (Rep a), G.Generic a) => [a] -> B.Box
 211 ppRecords recs = B.punctuateH AlignTopLeft "|" $ createHeaderDataBoxes recs
 212
 213 -- Pretty Print the records as a table. Handles records contained in a Map.
 214 -- Functions also prints the keys as the index of the table.
 215 ppRecordsWithIndex :: (CellValueFormatter k, GRecordMeta (Rep a), G.Generic a) => Map.Map k a -> B.Box
 216 ppRecordsWithIndex recs = B.punctuateH AlignTopLeft "|" $ index_box : data_boxes
 217   where
 218     data_boxes = createHeaderDataBoxes $ Map.elems recs
 219     index_box = createIndexBoxes recs
 220
 221 -- What follows are helper functions to build the B.Box structure to print as table.
 222
 223 -- Internal helper functions for building the Tree.
 224
 225 -- Build the list of paths from the root to every leaf.
 226 -- >>> constructPath $ Node "" $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])kk
 227 -- [["","root","R00","r00Int","42"],["","root","R00","r00String","foo"]]
 228 constructPath :: Tree a -> [[a]]
 229 constructPath (Node r []) = [[r]]
 230 constructPath (Node r f) = [r : x | x <- List.concatMap constructPath f]
 231
 232 -- Fill paths with a "-" so that all paths have the
 233 -- same length.
 234 -- >>> fillPath ([["1", "2", "3", "4"], ["5"]]::[[String]])
 235 -- [["2","3","4"],["-","-","-"]]
 236 fillPath :: IsString a => [[a]] -> [[a]]
 237 fillPath paths = [xs | x : xs <- new_paths]
 238   where
 239     depth = List.maximum $ List.length <$> paths
 240     diff = (\p -> depth - List.length p) <$> paths
 241     new_paths = (\(p, d) -> p ++ List.replicate d "-") <$> List.zip paths diff
 242
 243 -- Count the number of fields in the passed structure.
 244 -- The no of leaves is the sum of all fields across all nested
 245 -- records in the passed structure.
 246 countLeaves :: Tree a -> Tree (Int, a)
 247 countLeaves (Node r f) = case f of
 248   [] -> Node (1, r) []
 249   x -> countLeaves' x
 250     where
 251       countLeaves' x =
 252         let count_leaves = fmap countLeaves x
 253             level_count = List.foldr (\(Node (c, a) _) b -> c + b) 0 count_leaves
 254          in Node (level_count, r) count_leaves
 255
 256 -- Trims the tree of records and return just the
 257 -- leaves of the record
 258 -- >>> error $ drawTree $ trimTree $ Node "" $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])
 259
 260 {- |
 261  `- root
 262     |
 263     `- R00
 264        |
 265        +- r00Int
 266        |
 267        `- r00String
 268 -}
 269 trimTree :: Tree t -> Tree t
 270 trimTree (Node r f) = trimLeaves r f
 271
 272 -- Helper function called by trimTree.
 273 trimLeaves :: t -> [Tree t] -> Tree t
 274 trimLeaves r f = Node r (go f)
 275   where
 276     go f =
 277       let result = goo <$> f
 278             where
 279               goo (Node r' f') =
 280                 case f' of
 281                   [] -> Nothing
 282                   _ -> Just $ trimLeaves r' f'
 283        in catMaybes result
 284
 285 -- Get all the leaves from the record.
 286 -- Returns all leaves across the record structure.
 287 getLeaves :: (CellValueFormatter a) => Tree a -> [String]
 288 getLeaves (Node r f) = case f of
 289   [] -> [ppFormatter r]
 290   _ -> foldMap getLeaves f
 291
 292 {- | >>> y recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])
 293  root
 294  NOW |
 295  NOW `- R00
 296  NOW    |
 297  NOW    +- r00Int
 298  NOW    |  |
 299  NOW    |  `- 42
 300  NOW    |
 301  NOW    `- r00String
 302  NOW       |
 303  NOW       `- foo
 304  |
 305  +- r00Int
 306  |  |
 307  |  `- 42
 308  |
 309  `- r00String
 310     |
 311     `- foo
 312 -}
 313 recsToTrees :: (Functor f, GRecordMeta (Rep a), Generic a) => f a -> f (Tree String)
 314 recsToTrees = fmap (\a -> Node "root" $ toTree $ G.from a)
 315
 316 getHeaderDepth :: IsString a => [Tree a] -> Int
 317 getHeaderDepth = List.length . List.head . fillPath . constructPath . trimTree . List.head
 318
 319 --createIndexBoxes :: Map.Map a a -> B.Box
 320 createIndexBoxes :: (GRecordMeta (Rep a), Generic a, CellValueFormatter k) => Map.Map k a -> B.Box
 321 createIndexBoxes recs = index_box
 322   where
 323     rec_trees = recsToTrees $ Map.elems recs
 324     header_depth = getHeaderDepth rec_trees
 325     index_col = List.replicate header_depth "-" ++ List.map ppFormatter (Map.keys recs)
 326     index_box = B.vsep 0 B.AlignTopLeft $ List.map fromString index_col
 327
 328 createHeaderDataBoxes :: (GRecordMeta (Rep a), Generic a) => [a] -> [B.Box]
 329 createHeaderDataBoxes recs = vertical_boxes
 330   where
 331     rec_trees = recsToTrees recs
 332     header_boxes = createHeaderCols rec_trees
 333     data_boxes = createDataBoxes rec_trees
 334     vertical_boxes = (\(a, b) -> B.vsep 0 B.AlignTopLeft [a, b]) <$> List.zip header_boxes data_boxes
 335
 336 -- >>> error $ B.render $ B.hcat AlignTopLeft $ createHeaderCols $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])
 337 -- R00   R00
 338 -- r00Intr00String
 339 createHeaderCols :: [Tree String] -> [B.Box]
 340 createHeaderCols rec_trees =
 341   createBoxedHeaders $
 342     fillPath $
 343       constructPath $
 344         trimTree $
 345           List.head rec_trees
 346
 347 createBoxedHeaders :: [[String]] -> [B.Box]
 348 createBoxedHeaders paths = B.vsep 0 B.AlignTopLeft . (fromString <$>) <$> paths
 349
 350 -- >>> error $ B.render $ B.hcat AlignTopLeft $ createDataBoxes $ recsToTrees ([R00{r00Int = 42, r00String = "foo"}]::[R00])
 351 -- 42foo
 352 -- >>> error $ B.render $ B.hcat AlignTopLeft $ createDataBoxes $ recsToTrees ([getR01]::[R01])
 353 -- Jack-Jack100.101021Just 10.101
 354 createDataBoxes :: CellValueFormatter a => [Tree a] -> [B.Box]
 355 createDataBoxes rec_trees = vertical_boxes
 356   where
 357     horizontal_boxes = (fromString <$>) <$> (getLeaves <$> rec_trees)
 358     vertical_boxes = B.vsep 0 B.AlignTopLeft <$> List.transpose horizontal_boxes
 359
 360 -- testing
 361
 362 data T = C1 {aInt :: Double, aString :: String} deriving (Data, Typeable, Show, G.Generic)
 363 data T1 = C2 {t1 :: T, bInt :: Double, bString :: String} deriving (Data, Typeable, Show, G.Generic)
 364
 365 c1 = C1 1000 "record_c1fdsafaf"
 366 c2 = C2 c1 100.12121 "record_c2"
 367 c3 = C2 c1 1001.12111 "record_c2fdsafdsafsafdsafasfa"
 368 c4 = C2 c1 22222.12121 "r"
 369
 370 instance Tabulate T ExpandWhenNested
 371 instance Tabulate T1 ExpandWhenNested
 372 instance CellValueFormatter T
 373
 374 data R2 = R2 {a :: Maybe Integer} deriving (G.Generic, Show)
 375 data R3 = R3 {r31 :: Maybe Integer, r32 :: String} deriving (G.Generic, Show)
 376 tr = Node "root" (toTree . G.from $ c2)
 377 r2 = Node "root" (toTree . G.from $ (R2 (Just 10)))
 378 r3 = Node "root" (toTree . G.from $ (R3 (Just 10) "r3_string"))
 379
 380 -- | Used with 'printTableWithFlds'
 381 data DisplayFld a = forall s. CellValueFormatter s => DFld (a -> s)
 382
 383 -- printTableWithFlds2 :: [DisplayFld t] -> V.Vector t -> IO ()
 384 -- printTableWithFlds2 flds recs = B.printBox $ printTableWithFlds flds $ V.toList recs
 385
 386 -- printTableWithFlds3 :: (CellValueFormatter k) => [DisplayFld t] -> Map.Map k t -> String
 387 -- printTableWithFlds3 flds recs = results
 388 --  where
 389 --   data_cols = renderTableWithFlds flds $ Map.elems recs
 390 --   index_cols = B.vsep 0 B.AlignTopLeft $ fmap (fromString . ppFormatter) $ Map.keys recs
 391 --   vertical_cols = B.hsep 5 B.AlignTopLeft [index_cols, data_cols]
 392 --   results = B.render vertical_cols
 393
 394 data R00
 395   = R00
 396       { r00Int :: Int
 397       , r00String :: String
 398       }
 399   | R00_
 400       { r00_Int :: Int
 401       , r00_String :: String
 402       }
 403   deriving (Show, Generic, Data)
 404 instance CellValueFormatter R00
 405
 406 -- R0 has to derive from Data, since
 407 -- it will be nested
 408 data R01 = R01
 409   { test_string :: String
 410   , test_integer :: Integer
 411   , test_float :: Float
 412   , test_DOUBLE :: Maybe Double
 413   }
 414   deriving (Data, Show, G.Generic)
 415 instance CellValueFormatter R01
 416
 417 data R02 = R02 {r2_r00 :: R00, r2_r01 :: R01}
 418   deriving (Show, G.Generic, Data)
 419 instance CellValueFormatter R02
 420
 421 data R03 = R03 {r3_id :: Int, r3_r02 :: R02}
 422   deriving (Show, G.Generic, Data)
 423
 424 instance Tabulate R01 ExpandWhenNested
 425 instance Tabulate R02 ExpandWhenNested
 426 instance Tabulate R03 ExpandWhenNested
 427
 428 getR01 =
 429   R01
 430     { test_string = "Jack-Jack"
 431     , test_integer = 10
 432     , test_DOUBLE = Just 10.101
 433     , test_float = 0.101021
 434     }
 435
 436 getR02 = R02{r2_r00 = R00_ 100 "foo", r2_r01 = getR01}
 437
 438 getR03 = R03{r3_id = 200, r3_r02 = getR02}
 439
 440 recordsList = List.replicate 2 $ getR03
 441
 442 -- >>> recordsList
 443 -- [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}}}
 444 -- ,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}}}]
 445 --
 446 -- >>> B.rows $ renderTable recordsList
 447 -- 5
 448 --
 449 -- >>> B.cols $ renderTable recordsList
 450 -- 91
 451
 452 -- >>> error $ B.render $ ppRecords recordsList
 453 -- R03  |R03                                     |R03        |R03         |R03       |R03
 454 -- r3_id r3_r02                                   r3_r02      r3_r02       r3_r02     r3_r02
 455 -- -     R02                                      R02         R02          R02        R02
 456 -- -     r2_r00                                   r2_r01      r2_r01       r2_r01     r2_r01
 457 -- -     -                                        R01         R01          R01        R01
 458 -- -     -                                        test_string test_integer test_float test_DOUBLE
 459 -- 200   R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack   10           0.101021   Just 10.101
 460 -- 200   R00_ {r00_Int = 100, r00_String = "foo"} Jack-Jack   10           0.101021   Just 10.101
 461
 462 recordsMap =
 463   Map.fromList
 464     [ ("key1", getR03)
 465     , ("key2", getR03)
 466     , ("key3", getR03{r3_id = 32})
 467     ]
 468
 469 -- >>> B.rows $ renderTable recordsMap
 470 -- 5
 471
 472 -- >>> B.cols $ renderTable recordsMap
 473 -- 100
 474
 475 -- >>> error $ B.render $ ppRecordsWithIndex recordsMap
 476 -- -        R03       R03                                          R03             R03              R03            R03
 477 -- -        r3_id     r3_r02                                       r3_r02          r3_r02           r3_r02         r3_r02
 478 -- -        -         R02                                          R02             R02              R02            R02
 479 -- -        -         r2_r00                                       r2_r01          r2_r01           r2_r01         r2_r01
 480 -- -        -         -                                            R01             R01              R01            R01
 481 -- -        -         -                                            test_string     test_integer     test_float     test_DOUBLE
 482 -- key1     200       R00_ {r00_Int = 100, r00_String = "foo"}     Jack-Jack       10               0.101021       Just 10.101
 483 -- key2     200       R00_ {r00_Int = 100, r00_String = "foo"}     Jack-Jack       10               0.101021       Just 10.101
 484 -- key3     32        R00_ {r00_Int = 100, r00_String = "foo"}     Jack-Jack       10               0.101021       Just 10.101