module Text.PrettyPrint.Tabulate
(
Tabulate(..)
, Boxable(..)
, CellValueFormatter
, ExpandWhenNested
, DoNotExpandWhenNested
, DisplayFld(..)
)
where
import Data.Maybe
import Data.Data
import Data.Tree
import Data.Typeable
import Data.Generics.Aliases
import GHC.Generics as G
import GHC.Show
import qualified Data.Map as Map
import qualified Text.PrettyPrint.Boxes as B
import qualified Data.List as List
import qualified Data.List as L
import Text.Printf
import qualified Data.Vector as V
data TablizeValueFormat = T {floatValueFormat::Maybe (Float -> String),
stringValueFormat::Maybe (String -> String),
integerValueFormat::Maybe (Integer -> String),
intValueFormat::Maybe (Int -> String),
doubleValueFormat::Maybe (Double -> String)}
getDefaultTabulateValueFormat = T {floatValueFormat=Nothing,
stringValueFormat=Nothing,
integerValueFormat=Nothing,
intValueFormat=Nothing,
doubleValueFormat=Nothing}
data Tag = Constr | Fields | Values deriving (Show)
class GRecordMeta f where
toTree:: f a -> [Tree String]
instance GRecordMeta U1 where
toTree U1 = []
instance (GRecordMeta (a), GRecordMeta (b)) => GRecordMeta (a :*: b) where
toTree (x :*: y) = (toTree x) ++ (toTree y)
instance (GRecordMeta (a), GRecordMeta (b)) => GRecordMeta (a :+: b) where
toTree x = toTree x
instance (GRecordMeta a, Selector s) => GRecordMeta (M1 S s a) where
toTree a = [Node (selName a) $ toTree (unM1 a)] where
instance (GRecordMeta a, Constructor c) => GRecordMeta (M1 C c a) where
toTree a = toTree (unM1 a)
instance (GRecordMeta a) => GRecordMeta (M1 D c a) where
toTree (M1 x) = toTree x
instance (CellValueFormatter a, Data a, RecordMeta a) => GRecordMeta (K1 i a) where
toTree x = toTree' $ unK1 x
data ExpandWhenNested
data DoNotExpandWhenNested
class Tabulate a flag | a->flag where {}
instance (flag ~ DoNotExpandWhenNested) => Tabulate a flag
class RecordMeta a where
toTree':: a -> [Tree String]
instance (Tabulate a flag, RecordMeta' flag a) => RecordMeta a where
toTree' = toTree'' (undefined::proxy flag)
class RecordMeta' flag a where
toTree'':: proxy flag -> a -> [Tree String]
instance (G.Generic a, GRecordMeta (Rep a)) => RecordMeta' ExpandWhenNested a where
toTree'' _ a = toTree (G.from a)
instance (CellValueFormatter a) => RecordMeta' DoNotExpandWhenNested a where
toTree'' _ a = [Node (ppFormatter a) []]
class CellValueFormatter a where
ppFormatter :: a -> String
ppFormatterWithStyle :: TablizeValueFormat -> a -> String
default ppFormatter :: (Show a) => a -> String
ppFormatter x = show x
default ppFormatterWithStyle :: (Show a) => TablizeValueFormat -> a -> String
ppFormatterWithStyle _ x = "default_" ++ show x
instance CellValueFormatter Integer where
ppFormatter x = printf "%d" x
ppFormatterWithStyle style x = case integerValueFormat style of
Just f -> f x
Nothing -> ppFormatter x
instance CellValueFormatter Int where
ppFormatter x = printf "%d" x
ppFormatterWithStyle style x = case intValueFormat style of
Just f -> f x
Nothing -> ppFormatter x
instance CellValueFormatter Float where
ppFormatter x = printf "%14.7g" x
ppFormatterWithStyle style x = case floatValueFormat style of
Just f -> f x
Nothing -> ppFormatter x
instance CellValueFormatter String where
ppFormatter x = printf "%s" x
ppFormatterWithStyle style x = case stringValueFormat style of
Just f -> f x
Nothing -> ppFormatter x
instance CellValueFormatter Double where
ppFormatter x = printf "%14.7g" x
ppFormatterWithStyle style x = case doubleValueFormat style of
Just f -> f x
Nothing -> ppFormatter x
instance CellValueFormatter Bool
instance (Show a, CellValueFormatter a) => CellValueFormatter (Maybe a)
gen_renderTableWithFlds :: [DisplayFld t] -> [t] -> B.Box
gen_renderTableWithFlds flds recs = results where
col_wise_values = fmap (\(DFld f) -> fmap (ppFormatter .f) recs) flds
vertical_boxes = fmap (B.vsep 0 B.top) $ fmap (fmap B.text) col_wise_values
results = B.hsep 5 B.top vertical_boxes
class Boxable b where
printTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> IO ()
renderTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> B.Box
printTableWithFlds :: [DisplayFld t] -> b t -> IO ()
renderTableWithFlds :: [DisplayFld t] -> b t -> B.Box
instance Boxable [] where
printTable m = B.printBox $ ppRecords m
renderTable m = ppRecords m
printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs
renderTableWithFlds = gen_renderTableWithFlds
instance Boxable V.Vector where
printTable m = B.printBox $ renderTable m
renderTable m = ppRecords $ V.toList m
printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds $ V.toList recs
renderTableWithFlds flds recs = gen_renderTableWithFlds flds $ V.toList recs
instance (CellValueFormatter k) => Boxable (Map.Map k) where
printTable m = B.printBox $ renderTable m
renderTable m = ppRecordsWithIndex m
printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs
renderTableWithFlds flds recs = results where
data_cols = renderTableWithFlds flds $ Map.elems recs
index_cols = B.vsep 0 B.top $ fmap (B.text . ppFormatter) $ Map.keys recs
vertical_cols = B.hsep 5 B.top [index_cols, data_cols]
results = vertical_cols
ppRecords :: (GRecordMeta (Rep a), G.Generic a) => [a] -> B.Box
ppRecords recs = result where
result = B.hsep 5 B.top $ createHeaderDataBoxes recs
ppRecordsWithIndex :: (CellValueFormatter k, GRecordMeta (Rep a), G.Generic a) => (Map.Map k a) -> B.Box
ppRecordsWithIndex recs = result where
data_boxes = createHeaderDataBoxes $ Map.elems recs
index_box = createIndexBoxes recs
result = B.hsep 5 B.top $ index_box:data_boxes
constructPath :: Tree a -> [[a]]
constructPath (Node r []) = [[r]]
constructPath (Node r f) = [r:x | x <- (L.concatMap constructPath f)]
fillPath paths = stripped_paths where
depth = L.maximum $ L.map L.length paths
diff = L.map (\p -> depth (L.length p)) paths
new_paths = L.map (\(p,d) -> p ++ L.replicate d "-") $ L.zip paths diff
stripped_paths = [xs | x:xs <- new_paths]
countLeaves :: Tree a -> Tree (Int, a)
countLeaves (Node r f) = case f of
[] -> Node (1, r) []
x -> countLeaves' x where
countLeaves' x = let
count_leaves = fmap countLeaves x
level_count = Prelude.foldr (\(Node (c, a) _) b -> c + b) 0 count_leaves
in
Node (level_count, r) count_leaves
trimTree (Node r f) = trimLeaves r f
trimLeaves r f = Node r (trimLeaves' f) where
trimLeaves' f =
let result = fmap trimLeaves'' f where
trimLeaves'' (Node r' f') = let
result' = case f' of
[] -> Nothing
_ -> Just $ trimLeaves r' f'
in
result'
in
catMaybes result
getLeaves :: (CellValueFormatter a) => Tree a -> [String]
getLeaves (Node r f) = case f of
[] -> [(ppFormatter r)]
_ -> foldMap getLeaves f
recsToTrees recs = fmap (\a -> Node "root" $ (toTree . G.from $ a)) $ recs
getHeaderDepth rec_trees = header_depth where
header_depth = L.length . L.head . fillPath . constructPath . trimTree . L.head $ rec_trees
createBoxedHeaders :: [[String]] -> [B.Box]
createBoxedHeaders paths = boxes where
boxes = L.map wrapWithBox paths
wrapWithBox p = B.vsep 0 B.top $ L.map B.text p
createHeaderCols rec_trees = header_boxes where
header_boxes = createBoxedHeaders . fillPath . constructPath . trimTree . L.head $ rec_trees
createDataBoxes rec_trees = vertical_boxes where
horizontal_boxes = fmap (fmap B.text) $ fmap getLeaves rec_trees
vertical_boxes = fmap (B.vsep 0 B.top) $ L.transpose horizontal_boxes
createIndexBoxes recs = index_box where
rec_trees = recsToTrees $ Map.elems recs
header_depth = getHeaderDepth rec_trees
index_col = (L.replicate header_depth "-" ) ++ (L.map ppFormatter $ Map.keys recs)
index_box = B.vsep 0 B.top $ L.map B.text index_col
createHeaderDataBoxes recs = vertical_boxes where
rec_trees = recsToTrees recs
header_boxes = createHeaderCols rec_trees
data_boxes = createDataBoxes rec_trees
vertical_boxes = fmap (\(a, b) -> B.vsep 0 B.top $ [a, b]) $ L.zip header_boxes data_boxes
data T = C1 { aInt::Double, aString::String} deriving (Data, Typeable, Show,G.Generic)
data T1 = C2 { t1:: T, bInt::Double, bString::String} deriving (Data, Typeable, Show, G.Generic)
c1 = C1 1000 "record_c1fdsafaf"
c2 = C2 c1 100.12121 "record_c2"
c3 = C2 c1 1001.12111 "record_c2fdsafdsafsafdsafasfa"
c4 = C2 c1 22222.12121 "r"
instance Tabulate T ExpandWhenNested
instance Tabulate T1 ExpandWhenNested
instance CellValueFormatter T
data R2 = R2 {a::Maybe Integer} deriving (G.Generic, Show)
data R3 = R3 {r31::Maybe Integer, r32::String} deriving (G.Generic, Show)
tr = Node "root" (toTree . G.from $ c2)
r2 = Node "root" (toTree . G.from $ (R2 (Just 10)))
r3 = Node "root" (toTree . G.from $ (R3 (Just 10) "r3_string"))
data DisplayFld a = forall s. CellValueFormatter s => DFld (a->s)