├── test ├── README.lhs └── Spec.hs ├── Setup.hs ├── .gitignore ├── CHANGELOG.md ├── LICENSE ├── stack.yaml ├── pptable.cabal ├── README.md └── src └── Text └── PrettyPrint └── Tabulate.hs /test/README.lhs: -------------------------------------------------------------------------------- 1 | ../README.md -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.2.0.0 2 | ------- 3 | 4 | * This release contains *breaking* changes 5 | * Name of Tabilize class changed to Tabulate 6 | * printList, printMap and printVector all replaced with polymorphic method ppTable 7 | * New class Boxable with default instances for List, Vector and Map 8 | * Use prinf library to print basic types 9 | * New class CellValueFormatter with default instances for basic type 10 | * Boxable instance to extend to other Traversable instances 11 | * CellValueFormatter class to extend formatting 12 | 13 | 0.1.0.1 14 | ------- 15 | 16 | * Intial version 17 | * Can print List, Map or Vector in tabular format 18 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2016 Guru Devanla 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 6 | 7 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 8 | 9 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 10 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # For more information, see: https://github.com/commercialhaskell/stack/blob/release/doc/yaml_configuration.md 2 | 3 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 4 | resolver: lts-7.2 5 | 6 | # Local packages, usually specified by relative directory name 7 | packages: 8 | - '.' 9 | 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 0.1.10.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | -------------------------------------------------------------------------------- /pptable.cabal: -------------------------------------------------------------------------------- 1 | name: pptable 2 | version: 0.3.0.0 3 | synopsis: Pretty Print containers in a tabular format 4 | description: Please see README.md 5 | homepage: https://github.com/gdevanla/pptable#readme 6 | license: MIT 7 | license-file: LICENSE 8 | author: Guru Devanla 9 | maintainer: grdvnl@gmail.com 10 | copyright: 2016 Guru Devanla 11 | category: Text 12 | build-type: Simple 13 | extra-source-files: README.md, CHANGELOG.md 14 | cabal-version: >=1.10 15 | 16 | library 17 | hs-source-dirs: src 18 | exposed-modules: Text.PrettyPrint.Tabulate 19 | build-depends: base >= 4.7 && < 5 20 | , syb 21 | , containers 22 | , pretty 23 | , boxes 24 | , vector 25 | , generic-deriving 26 | default-language: Haskell2010 27 | 28 | test-suite pptable-test 29 | type: exitcode-stdio-1.0 30 | hs-source-dirs: test 31 | main-is: Spec.hs 32 | build-depends: base 33 | , pptable 34 | , tasty 35 | , HUnit 36 | , QuickCheck 37 | , tasty-hunit 38 | , tasty-quickcheck 39 | , containers 40 | , vector 41 | , boxes 42 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 43 | default-language: Haskell2010 44 | 45 | test-suite readme 46 | type: exitcode-stdio-1.0 47 | hs-source-dirs: test 48 | main-is: README.lhs 49 | build-depends: base 50 | , pptable 51 | , tasty 52 | , HUnit 53 | , QuickCheck 54 | , tasty-hunit 55 | , tasty-quickcheck 56 | , containers 57 | , vector 58 | , boxes 59 | , markdown-unlit 60 | ghc-options: -threaded -rtsopts -with-rtsopts=-N -pgmL markdown-unlit 61 | default-language: Haskell2010 62 | 63 | source-repository head 64 | type: git 65 | location: https://github.com/gdevanla/pptable 66 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -fno-warn-missing-signatures #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE ConstrainedClassMethods #-} 5 | {-# LANGUAGE MultiParamTypeClasses#-} 6 | 7 | import Data.Map as M 8 | import Data.List as L 9 | import Data.Vector as V 10 | import qualified Text.PrettyPrint.Tabulate as T 11 | import GHC.Generics as G 12 | import Data.Data 13 | import Text.PrettyPrint.Boxes as B 14 | 15 | import Test.Tasty 16 | import Test.Tasty.QuickCheck as QC 17 | import Test.Tasty.HUnit 18 | 19 | -- R0 has to derive from Data, since 20 | -- it will be nested 21 | data R01 = R01 {test_string::String, 22 | test_integer::Integer, 23 | test_float::Float, 24 | test_double::Double} 25 | deriving (Data, Show, G.Generic) 26 | instance T.CellValueFormatter R01 27 | 28 | data R02 = R02 {r2_id::Int, nested_r::R01} 29 | deriving (Show, G.Generic, Data) 30 | instance T.CellValueFormatter R02 31 | 32 | data R03 = R03 {r3_id::Int, nested_r02:: R02} 33 | deriving (Show, G.Generic, Data) 34 | 35 | instance T.Tabulate R01 T.ExpandWhenNested 36 | instance T.Tabulate R02 T.ExpandWhenNested 37 | instance T.Tabulate R03 T.ExpandWhenNested 38 | 39 | getR01 = R01 {test_string="Jack-Jack" 40 | , test_integer=10 41 | , test_double=10.101 42 | , test_float=0.101021} 43 | 44 | getR02 = R02 {r2_id=10, nested_r=getR01} 45 | 46 | getR03 = R03 {r3_id=20, nested_r02=getR02} 47 | 48 | testList = testCase "testList" 49 | ( 50 | do 51 | let records = Prelude.replicate 2 $ getR03 52 | rows = B.rows $ T.renderTable records 53 | cols = B.cols $ T.renderTable records 54 | assertEqual "row count" rows 5 55 | assertEqual "col count" cols 91 56 | ) 57 | 58 | 59 | testMap = testCase "testMap" 60 | ( 61 | do 62 | let records = M.fromList [("key1", getR03), ("key2", getR03)] 63 | rows = B.rows $ T.renderTable records 64 | cols = B.cols $ T.renderTable records 65 | assertEqual "row count" rows 5 66 | assertEqual "col count" cols 100 67 | ) 68 | 69 | testVector = testCase "testVector" 70 | ( 71 | do 72 | let records = V.fromList [getR03, getR03] 73 | rows = B.rows $ T.renderTable records 74 | cols = B.cols $ T.renderTable records 75 | assertEqual "row count" rows 5 76 | assertEqual "col count" cols 91 77 | ) 78 | 79 | tests :: TestTree 80 | tests = testGroup "Tests" [ 81 | testList, 82 | testMap, 83 | testVector 84 | ] 85 | 86 | main = defaultMain tests 87 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # README # 2 | 3 | Textme.PrettyPrint.Tabulate : Print any list, vector or map of records as a well-formatted readable table. Nested record structures are printed with hierarchically arranged headers, thus clearly showing the nested structures. 4 | 5 | ### Text.PrettyPrint.Tabulate ### 6 | 7 | * This module provides simple functions used to print values in tabular format 8 | * Version 0.3.0.0 9 | * Contributions and Bug Reports welcome. Please use the Github issue tracker. 10 | 11 | ### Release Notes 0.3.0.0 (*This release has breaking changes*) 12 | 13 | * This release has some breaking changes which was required to extend 14 | functionality. The extended functionality improves on previous 15 | release by printing nested records with hierarchical column headers 16 | 17 | * All Records types need to update their `Tabulate` instances to provide a flag, namely `ExpandWhenNested` or `DoNotExpandWhenNested`. 18 | 19 | * `ppTable` function has been renamed to `printTable` to make the function name more descriptive. 20 | 21 | * New function called printTableWithFlds has been added. 22 | 23 | ### Example ### 24 | 25 | ``` haskell 26 | 27 | {-# LANGUAGE MultiParamTypeClasses#-} 28 | {-# LANGUAGE DeriveGeneric #-} 29 | {-# LANGUAGE DeriveDataTypeable #-} 30 | 31 | import Text.PrettyPrint.Tabulate 32 | import qualified GHC.Generics as G 33 | import Data.Data 34 | 35 | import qualified Text.PrettyPrint.Tabulate as T 36 | 37 | import qualified Data.Map as Map 38 | import qualified Data.List as List 39 | import qualified Data.Vector as Vector 40 | 41 | ``` 42 | 43 | #### Instance Declaration Requirements #### 44 | 45 | 1. All records definitions should `derive` from `Data` and `Generic` 46 | 2. All field types that are record attributes should have an instance of `CellValueFormatter`. Default instances for standard types are already provided. 47 | 3. All records that need to be printed as a table need to be an instance of `Tabulate`. 48 | 4. Depending on if the nested record's fields have to be expanded, the 49 | Tabulate instance could either be 50 | 51 | `instance Tabulate Price ExpandWhenNested` or 52 | `instance Tabulate Price DoNotExpandWhenNested`. 53 | 54 | ``` haskell 55 | 56 | data FxCode = USD | EUR | JPY deriving (Show, Data, G.Generic) 57 | instance T.CellValueFormatter FxCode 58 | 59 | -- This record type will be nested inside `Stock` 60 | data Price = Price {price::Double, fx_code::FxCode} deriving (Data, G.Generic, Show) 61 | 62 | -- if we do not want the `Price` records to be expanded into their own fields 63 | -- then choose `T.DoNotExpandWhenNested` 64 | instance T.Tabulate Price T.ExpandWhenNested 65 | instance T.CellValueFormatter Price 66 | 67 | data Stock = Stock {ticker::String, local_price::Price, marketCap::Double} deriving ( 68 | Data, G.Generic, Show) 69 | instance T.Tabulate Stock T.ExpandWhenNested 70 | 71 | ``` 72 | Once we have the records and required instances created, we can see how 73 | the created records can be viewed in the tabular format. 74 | 75 | ``` haskell 76 | 77 | yahoo = Stock {ticker="YHOO", local_price=Price 42.29101010 USD, marketCap=40e9} 78 | google = Stock {ticker="GOOG", local_price=Price 774.210101 EUR, marketCap=532.09e9} 79 | amazon = Stock {ticker="AMZN", local_price=Price 799.161717 JPY, marketCap=378.86e9} 80 | 81 | tickers = [yahoo, google, amazon] 82 | tickers_vector = Vector.fromList tickers 83 | tickers_map:: Map.Map Integer Stock 84 | tickers_map = Map.fromList [(10, yahoo), (100, google), (1000, amazon)] 85 | 86 | printExamples:: IO () 87 | printExamples = do 88 | putStrLn "Printing records in a list\n" 89 | T.printTable tickers 90 | 91 | putStrLn "\nPrinting records in a map with the index.\nNote the `key(s)` are printed as first columns" 92 | T.printTable tickers_map 93 | 94 | putStrLn "\nPrinting records in a vector\n" 95 | T.printTable tickers_vector 96 | 97 | -- Sometimes records may have too many fields. In those case, specific fields can 98 | -- be chosen to be printed. Currently, support for this functionality is 99 | -- minimal. The 'headers` are not printed. In the future, a function that 100 | -- can take header labels as a list will be provided. 101 | 102 | putStrLn "\nPrinting specific fields. Note, currently field names are not printed" 103 | T.printTableWithFlds [T.DFld (price . local_price), T.DFld ticker] tickers_map 104 | 105 | putStrLn "\nPrint nested record in a map, individually" 106 | T.printTable $ fmap local_price tickers_map 107 | 108 | ``` 109 | 110 | ### Print the examples ### 111 | 112 | ``` haskell 113 | 114 | main:: IO () 115 | main = do 116 | printExamples 117 | ``` 118 | 119 | ### Output ### 120 | 121 | ``` haskell ignore 122 | Printing records in a list 123 | 124 | ticker local_price local_price marketCap 125 | - price fx_code - 126 | YHOO 42.2910101 USD 4.0000000e10 127 | GOOG 774.2101010 EUR 5.3209000e11 128 | AMZN 799.1617170 JPY 3.7886000e11 129 | 130 | Printing records in a map with the index (Note the `key` is printed as the first column) 131 | 132 | - ticker local_price local_price marketCap 133 | - - price fx_code - 134 | 10 YHOO 42.2910101 USD 4.0000000e10 135 | 100 GOOG 774.2101010 EUR 5.3209000e11 136 | 1000 AMZN 799.1617170 JPY 3.7886000e11 137 | 138 | Printing records in a vector 139 | 140 | ticker local_price local_price marketCap 141 | - price fx_code - 142 | YHOO 42.2910101 USD 4.0000000e10 143 | GOOG 774.2101010 EUR 5.3209000e11 144 | AMZN 799.1617170 JPY 3.7886000e11 145 | 146 | Printing specific fields. Note, currently field names are not printed 147 | 10 42.2910101 YHOO 148 | 100 774.2101010 GOOG 149 | 1000 799.1617170 AMZN 150 | 151 | ``` 152 | -------------------------------------------------------------------------------- /src/Text/PrettyPrint/Tabulate.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE StandaloneDeriving #-} 2 | {-# LANGUAGE DeriveGeneric #-} -- Remove this 3 | {-# LANGUAGE DeriveDataTypeable #-} -- Remove this 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE GADTs #-} 6 | {-# LANGUAGE FunctionalDependencies #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FlexibleContexts #-} 9 | {-# LANGUAGE Rank2Types #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE DefaultSignatures #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | {-# LANGUAGE ConstrainedClassMethods #-} 14 | {-# LANGUAGE MultiParamTypeClasses #-} 15 | {-#LANGUAGE ScopedTypeVariables #-} 16 | 17 | 18 | -- | Module implements the default methods for Tabulate 19 | -- All examples listed in the document need the following language pragmas 20 | -- and following modules imported 21 | -- 22 | -- @ 23 | -- {#- LANGUAGE MultiParamTypeClasses} 24 | -- {#- LANGUAGE DeriveGeneric} 25 | -- {#- LANGUAGE DeriveDataTypeable} 26 | -- 27 | -- import qualified GHC.Generics as G 28 | -- import Data.Data 29 | -- @ 30 | -- 31 | 32 | module Text.PrettyPrint.Tabulate 33 | ( 34 | Tabulate(..) 35 | , Boxable(..) 36 | , CellValueFormatter 37 | , ExpandWhenNested 38 | , DoNotExpandWhenNested 39 | , DisplayFld(..) 40 | ) 41 | where 42 | 43 | import Data.Maybe 44 | import Data.Data 45 | import Data.Tree 46 | import Data.Typeable 47 | import Data.Generics.Aliases 48 | import GHC.Generics as G 49 | import GHC.Show 50 | import qualified Data.Map as Map 51 | import qualified Text.PrettyPrint.Boxes as B 52 | import qualified Data.List as List 53 | import qualified Data.List as L 54 | import Text.Printf 55 | import qualified Data.Vector as V 56 | 57 | -- | Future change to support providing custom formatting functions 58 | data TablizeValueFormat = T {floatValueFormat::Maybe (Float -> String), 59 | stringValueFormat::Maybe (String -> String), 60 | integerValueFormat::Maybe (Integer -> String), 61 | intValueFormat::Maybe (Int -> String), 62 | doubleValueFormat::Maybe (Double -> String)} 63 | 64 | -- | Default TabulateValueFormat 65 | getDefaultTabulateValueFormat = T {floatValueFormat=Nothing, 66 | stringValueFormat=Nothing, 67 | integerValueFormat=Nothing, 68 | intValueFormat=Nothing, 69 | doubleValueFormat=Nothing} 70 | 71 | data Tag = Constr | Fields | Values deriving (Show) 72 | 73 | class GRecordMeta f where 74 | toTree:: f a -> [Tree String] 75 | 76 | instance GRecordMeta U1 where 77 | toTree U1 = [] 78 | 79 | instance (GRecordMeta (a), GRecordMeta (b)) => GRecordMeta (a :*: b) where 80 | toTree (x :*: y) = (toTree x) ++ (toTree y) 81 | 82 | instance (GRecordMeta (a), GRecordMeta (b)) => GRecordMeta (a :+: b) where 83 | toTree x = toTree x 84 | 85 | instance (GRecordMeta a, Selector s) => GRecordMeta (M1 S s a) where 86 | toTree a = [Node (selName a) $ toTree (unM1 a)] where 87 | 88 | instance (GRecordMeta a, Constructor c) => GRecordMeta (M1 C c a) where 89 | -- we don't want to build node for constructor 90 | --toTree a = [Node (conName a) $ toTree (unM1 a)] 91 | toTree a = toTree (unM1 a) 92 | 93 | instance (GRecordMeta a) => GRecordMeta (M1 D c a) where 94 | toTree (M1 x) = toTree x 95 | 96 | instance (CellValueFormatter a, Data a, RecordMeta a) => GRecordMeta (K1 i a) where 97 | --toTree x = [Node (show (unK1 x)) (toTree' $ unK1 x)] 98 | toTree x = toTree' $ unK1 x 99 | 100 | -- | Use this flag to expand a Record Type as a table when 101 | -- nested inside another record. 102 | data ExpandWhenNested 103 | 104 | -- | Use this flag to not expand a Record type as a table when 105 | -- nested inside another record. The 'Show' instance of the nested record 106 | -- is used by default without expanding. This means that the fields of the 107 | -- nested record are not displayed as separate headers. 108 | data DoNotExpandWhenNested 109 | 110 | -- | Class instance that needs to be instantiated for each 111 | -- record that needs to be printed using printTable 112 | -- 113 | -- @ 114 | -- 115 | -- data Stock = Stock {price:: Double, name:: String} derive (Show, G.Generic, Data) 116 | -- instance Tabulate S 'ExpandWhenNested' 117 | -- @ 118 | -- 119 | -- If 'S' is embedded inside another `Record` type and should be 120 | -- displayed in regular Record Syntax, then 121 | -- 122 | -- @ 123 | -- 124 | -- instance Tabulate S 'DoNotExpandWhenNested' 125 | -- @ 126 | -- 127 | class Tabulate a flag | a->flag where {} 128 | 129 | --instance TypeCast flag HFalse => Tabulate a flag 130 | instance {-# OVERLAPPABLE #-} (flag ~ DoNotExpandWhenNested) => Tabulate a flag 131 | 132 | class RecordMeta a where 133 | toTree':: a -> [Tree String] 134 | 135 | instance (Tabulate a flag, RecordMeta' flag a) => RecordMeta a where 136 | toTree' = toTree'' (undefined::proxy flag) 137 | 138 | class RecordMeta' flag a where 139 | toTree'':: proxy flag -> a -> [Tree String] 140 | 141 | instance (G.Generic a, GRecordMeta (Rep a)) => RecordMeta' ExpandWhenNested a where 142 | toTree'' _ a = toTree (G.from a) 143 | 144 | instance (CellValueFormatter a) => RecordMeta' DoNotExpandWhenNested a where 145 | toTree'' _ a = [Node (ppFormatter a) []] 146 | 147 | 148 | -- | Class that implements formatting using printf. 149 | -- Default instances for String, Char, Int, Integer, Double and Float 150 | -- are provided. For types that are not an instance of this class 151 | -- `show` is used. 152 | class CellValueFormatter a where 153 | 154 | -- Function that can be implemented by each instance 155 | ppFormatter :: a -> String 156 | 157 | -- Future support for this signature will be added 158 | ppFormatterWithStyle :: TablizeValueFormat -> a -> String 159 | 160 | -- Default instance of function for types that do 161 | -- do not have their own instance 162 | default ppFormatter :: (Show a) => a -> String 163 | ppFormatter x = show x 164 | 165 | -- Future support. 166 | default ppFormatterWithStyle :: (Show a) => TablizeValueFormat -> a -> String 167 | ppFormatterWithStyle _ x = "default_" ++ show x 168 | 169 | 170 | instance CellValueFormatter Integer where 171 | ppFormatter x = printf "%d" x 172 | 173 | ppFormatterWithStyle style x = case integerValueFormat style of 174 | Just f -> f x 175 | Nothing -> ppFormatter x 176 | 177 | instance CellValueFormatter Int where 178 | ppFormatter x = printf "%d" x 179 | 180 | ppFormatterWithStyle style x = case intValueFormat style of 181 | Just f -> f x 182 | Nothing -> ppFormatter x 183 | 184 | 185 | instance CellValueFormatter Float where 186 | ppFormatter x = printf "%14.7g" x 187 | 188 | ppFormatterWithStyle style x = case floatValueFormat style of 189 | Just f -> f x 190 | Nothing -> ppFormatter x 191 | 192 | instance CellValueFormatter String where 193 | ppFormatter x = printf "%s" x 194 | 195 | ppFormatterWithStyle style x = case stringValueFormat style of 196 | Just f -> f x 197 | Nothing -> ppFormatter x 198 | 199 | 200 | instance CellValueFormatter Double where 201 | ppFormatter x = printf "%14.7g" x 202 | 203 | ppFormatterWithStyle style x = case doubleValueFormat style of 204 | Just f -> f x 205 | Nothing -> ppFormatter x 206 | 207 | instance CellValueFormatter Bool 208 | 209 | instance (Show a, CellValueFormatter a) => CellValueFormatter (Maybe a) 210 | 211 | 212 | gen_renderTableWithFlds :: [DisplayFld t] -> [t] -> B.Box 213 | gen_renderTableWithFlds flds recs = results where 214 | col_wise_values = fmap (\(DFld f) -> fmap (ppFormatter .f) recs) flds 215 | vertical_boxes = fmap (B.vsep 0 B.top) $ fmap (fmap B.text) col_wise_values 216 | results = B.hsep 5 B.top vertical_boxes 217 | 218 | 219 | class Boxable b where 220 | -- toBox :: (Data a, G.Generic a, GRecordMeta(Rep a)) => b a -> [[B.Box]] 221 | -- toBoxWithStyle :: (Data a, G.Generic a, GTabulate(Rep a)) => TablizeValueFormat -> b a -> [[B.Box]] 222 | 223 | -- | Used to print a container of Records in a tabular format. 224 | -- 225 | -- @ 226 | -- 227 | -- data Stock = Stock {price:: Double, ticker:: String} deriving (Show, Data, G.Generic) 228 | -- instance Tabulate Stock DoNotExpandWhenNested 229 | -- -- this can be a Vector or Map 230 | -- let s = [Stock 10.0 "yahoo", Stock 12.0 "goog", Stock 10.0 "amz"] 231 | -- T.printTable s 232 | -- @ 233 | -- 234 | -- Nested records can also be printed in tabular format 235 | -- 236 | -- @ 237 | -- 238 | -- data FxCode = USD | EUR deriving (Show, Data, G.Generic) 239 | -- instance 'CellValueFormatter' FxCode 240 | -- 241 | -- data Price = Price {px:: Double, fxCode:: FxCode} deriving (Show, Data, G.Generic) 242 | -- instance 'Tabulate' Price 'ExpandWhenNested' 243 | -- -- since Price will be nested, it also needs an instance of 244 | -- -- CellValueFormatter 245 | -- instance CellValueFormatter Price 246 | -- 247 | -- data Stock = Stock {ticker:: String, price:: Price} deriving (Show, Data, G.Generic) 248 | -- instance Tabulate Stock DoNotExpandWhenNested 249 | -- 250 | -- -- this can be a Vector or Map 251 | -- let s = [Stock "yahoo" (Price 10.0 USD), Stock "ikea" (Price 11.0 EUR)] 252 | -- printTable s 253 | -- @ 254 | -- 255 | printTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> IO () 256 | --printTableWithStyle :: (Data a, G.Generic a, GTabulate(Rep a)) => TablizeValueFormat -> b a -> IO () 257 | 258 | -- | Similar to 'printTable' but rather than return IO (), returns a 259 | -- 'Box' object that can be printed later on, using 'printBox' 260 | renderTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> B.Box 261 | 262 | -- | Used for printing selected fields from Record types 263 | -- This is useful when Records have a large number of fields 264 | -- and only few fields need to be introspected at any time. 265 | -- 266 | -- Using the example provided under 'printTables', 267 | -- 268 | -- @ 269 | -- 'printTableWithFlds' [DFld (px . price), DFld ticker] s 270 | -- 271 | -- @ 272 | printTableWithFlds :: [DisplayFld t] -> b t -> IO () 273 | 274 | -- | Same as printTableWithFlds but returns a `Box` object, rather than 275 | -- returning an `IO ()`. 276 | renderTableWithFlds :: [DisplayFld t] -> b t -> B.Box 277 | 278 | -- | Instance methods to render or print a list of records in a tabular format. 279 | instance Boxable [] where 280 | -- | Used to print a list of Records in a tabular format. 281 | -- @ 282 | -- 283 | -- data Stock = Stock {price:: Double, ticker:: String} 284 | -- instance Tabulate S DoNotExpandWhenNested 285 | -- let s = [Stock 10.0 "yahoo", Stock 12.0 "goog", Stock 10.0 "amz"] 286 | -- T.printTable s 287 | -- 288 | -- @ 289 | printTable m = B.printBox $ ppRecords m 290 | 291 | renderTable m = ppRecords m 292 | 293 | -- | Print a "List" of records as a table with just the given fields. 294 | -- Called by "printTableWithFlds". 295 | printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs 296 | renderTableWithFlds = gen_renderTableWithFlds 297 | 298 | 299 | instance Boxable V.Vector where 300 | -- | Prints a "Vector" as a table. Called by "printTable". 301 | -- | Need not be called directly 302 | printTable m = B.printBox $ renderTable m --TODO: switch this to Vector 303 | renderTable m = ppRecords $ V.toList m 304 | 305 | -- | Print a "Vector" of records as a table with the selected fields. 306 | -- Called by "printTableWithFlds". 307 | printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds $ V.toList recs 308 | renderTableWithFlds flds recs = gen_renderTableWithFlds flds $ V.toList recs 309 | 310 | 311 | instance (CellValueFormatter k) => Boxable (Map.Map k) where 312 | 313 | -- | Prints a "Map" as a table. Called by "ppTable" 314 | -- | Need not be called directly 315 | printTable m = B.printBox $ renderTable m 316 | renderTable m = ppRecordsWithIndex m 317 | 318 | -- | Prints a "Map" as a table with the selected fields. Called by "printTable" 319 | -- | Need not be called directly 320 | printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs 321 | 322 | renderTableWithFlds flds recs = results where 323 | data_cols = renderTableWithFlds flds $ Map.elems recs 324 | index_cols = B.vsep 0 B.top $ fmap (B.text . ppFormatter) $ Map.keys recs 325 | vertical_cols = B.hsep 5 B.top [index_cols, data_cols] 326 | results = vertical_cols 327 | 328 | -- Pretty Print the reords as a table. Handles both records inside 329 | -- Lists and Vectors 330 | ppRecords :: (GRecordMeta (Rep a), G.Generic a) => [a] -> B.Box 331 | ppRecords recs = result where 332 | result = B.hsep 5 B.top $ createHeaderDataBoxes recs 333 | 334 | -- Pretty Print the records as a table. Handles records contained in a Map. 335 | -- Functions also prints the keys as the index of the table. 336 | ppRecordsWithIndex :: (CellValueFormatter k, GRecordMeta (Rep a), G.Generic a) => (Map.Map k a) -> B.Box 337 | ppRecordsWithIndex recs = result where 338 | data_boxes = createHeaderDataBoxes $ Map.elems recs 339 | index_box = createIndexBoxes recs 340 | result = B.hsep 5 B.top $ index_box:data_boxes 341 | 342 | 343 | -- What follows are helper functions to build the B.Box structure to print as table. 344 | 345 | -- Internal helper functions for building the Tree. 346 | 347 | -- Build the list of paths from the root to every leaf. 348 | constructPath :: Tree a -> [[a]] 349 | constructPath (Node r []) = [[r]] 350 | constructPath (Node r f) = [r:x | x <- (L.concatMap constructPath f)] 351 | 352 | -- Fill paths with a "-" so that all paths have the 353 | -- same length. 354 | fillPath paths = stripped_paths where 355 | depth = L.maximum $ L.map L.length paths 356 | diff = L.map (\p -> depth - (L.length p)) paths 357 | new_paths = L.map (\(p,d) -> p ++ L.replicate d "-") $ L.zip paths diff 358 | stripped_paths = [xs | x:xs <- new_paths] 359 | 360 | -- Count the number of fields in the passed structure. 361 | -- The no of leaves is the sum of all fields across all nested 362 | -- records in the passed structure. 363 | countLeaves :: Tree a -> Tree (Int, a) 364 | countLeaves (Node r f) = case f of 365 | [] -> Node (1, r) [] 366 | x -> countLeaves' x where 367 | countLeaves' x = let 368 | count_leaves = fmap countLeaves x 369 | level_count = Prelude.foldr (\(Node (c, a) _) b -> c + b) 0 count_leaves 370 | in 371 | Node (level_count, r) count_leaves 372 | 373 | -- Trims a the tree of records and return just the 374 | -- leaves of the record 375 | trimTree (Node r f) = trimLeaves r f 376 | 377 | -- Helper function called by trimTree. 378 | trimLeaves r f = Node r (trimLeaves' f) where 379 | trimLeaves' f = 380 | let result = fmap trimLeaves'' f where 381 | trimLeaves'' (Node r' f') = let 382 | result' = case f' of 383 | [] -> Nothing 384 | _ -> Just $ trimLeaves r' f' 385 | in 386 | result' 387 | in 388 | catMaybes result 389 | 390 | -- Get all the leaves from the record. Returns all leaves 391 | -- across the record structure. 392 | getLeaves :: (CellValueFormatter a) => Tree a -> [String] 393 | getLeaves (Node r f) = case f of 394 | [] -> [(ppFormatter r)] 395 | _ -> foldMap getLeaves f 396 | 397 | recsToTrees recs = fmap (\a -> Node "root" $ (toTree . G.from $ a)) $ recs 398 | 399 | getHeaderDepth rec_trees = header_depth where 400 | header_depth = L.length . L.head . fillPath . constructPath . trimTree . L.head $ rec_trees 401 | 402 | createBoxedHeaders :: [[String]] -> [B.Box] 403 | createBoxedHeaders paths = boxes where 404 | boxes = L.map wrapWithBox paths 405 | wrapWithBox p = B.vsep 0 B.top $ L.map B.text p 406 | 407 | --createHeaderCols :: [Tree String] -> [B.Box] 408 | createHeaderCols rec_trees = header_boxes where 409 | header_boxes = createBoxedHeaders . fillPath . constructPath . trimTree . L.head $ rec_trees 410 | 411 | --createDataBoxes :: [Tree a] -> [B.Box] 412 | createDataBoxes rec_trees = vertical_boxes where 413 | horizontal_boxes = fmap (fmap B.text) $ fmap getLeaves rec_trees 414 | vertical_boxes = fmap (B.vsep 0 B.top) $ L.transpose horizontal_boxes 415 | 416 | --createIndexBoxes :: Map.Map a a -> B.Box 417 | createIndexBoxes recs = index_box where 418 | rec_trees = recsToTrees $ Map.elems recs 419 | header_depth = getHeaderDepth rec_trees 420 | index_col = (L.replicate header_depth "-" ) ++ (L.map ppFormatter $ Map.keys recs) 421 | index_box = B.vsep 0 B.top $ L.map B.text index_col 422 | 423 | createHeaderDataBoxes recs = vertical_boxes where 424 | rec_trees = recsToTrees recs 425 | header_boxes = createHeaderCols rec_trees 426 | data_boxes = createDataBoxes rec_trees 427 | vertical_boxes = fmap (\(a, b) -> B.vsep 0 B.top $ [a, b]) $ L.zip header_boxes data_boxes 428 | 429 | 430 | -- testing 431 | 432 | data T = C1 { aInt::Double, aString::String} deriving (Data, Typeable, Show,G.Generic) 433 | data T1 = C2 { t1:: T, bInt::Double, bString::String} deriving (Data, Typeable, Show, G.Generic) 434 | 435 | c1 = C1 1000 "record_c1fdsafaf" 436 | c2 = C2 c1 100.12121 "record_c2" 437 | c3 = C2 c1 1001.12111 "record_c2fdsafdsafsafdsafasfa" 438 | c4 = C2 c1 22222.12121 "r" 439 | 440 | instance Tabulate T ExpandWhenNested 441 | instance Tabulate T1 ExpandWhenNested 442 | instance CellValueFormatter T 443 | 444 | data R2 = R2 {a::Maybe Integer} deriving (G.Generic, Show) 445 | data R3 = R3 {r31::Maybe Integer, r32::String} deriving (G.Generic, Show) 446 | tr = Node "root" (toTree . G.from $ c2) 447 | r2 = Node "root" (toTree . G.from $ (R2 (Just 10))) 448 | r3 = Node "root" (toTree . G.from $ (R3 (Just 10) "r3_string")) 449 | 450 | -- | Used with 'printTableWithFlds' 451 | data DisplayFld a = forall s. CellValueFormatter s => DFld (a->s) 452 | 453 | -- printTableWithFlds2 :: [DisplayFld t] -> V.Vector t -> IO () 454 | -- printTableWithFlds2 flds recs = B.printBox $ printTableWithFlds flds $ V.toList recs 455 | 456 | -- printTableWithFlds3 :: (CellValueFormatter k) => [DisplayFld t] -> Map.Map k t -> IO () 457 | -- printTableWithFlds3 flds recs = results where 458 | -- data_cols = printTableWithFlds flds $ Map.elems recs 459 | -- index_cols = B.vsep 0 B.top $ fmap (B.text . ppFormatter) $ Map.keys recs 460 | -- vertical_cols = B.hsep 5 B.top [index_cols, data_cols] 461 | -- results = B.printBox vertical_cols 462 | --------------------------------------------------------------------------------