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