Tabulate.hs

{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE DeriveGeneric #-} -- Remove this
{-# LANGUAGE DeriveDataTypeable #-} -- Remove this
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-#LANGUAGE ScopedTypeVariables #-}


-- | Module implements the default methods for Tabulate
-- All examples listed in the document need the following language pragmas
-- and following modules imported
--
-- @
-- {#- LANGUAGE MultiParamTypeClasses}
-- {#- LANGUAGE DeriveGeneric}
-- {#- LANGUAGE DeriveDataTypeable}
--
-- import qualified GHC.Generics as G
-- import Data.Data
-- @
--

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

-- | Future change to support providing custom formatting functions
data TablizeValueFormat = T {floatValueFormat::Maybe (Float -> String),
                             stringValueFormat::Maybe (String -> String),
                             integerValueFormat::Maybe (Integer -> String),
                             intValueFormat::Maybe (Int -> String),
                             doubleValueFormat::Maybe (Double -> String)}

-- | Default TabulateValueFormat
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
  -- we don't want to build node for constructor
  --toTree a = [Node (conName a) $ toTree (unM1 a)]
  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 = [Node (show (unK1 x)) (toTree' $ unK1 x)]
  toTree x = toTree' $ unK1 x

-- | Use this flag to expand a Record Type as a table when
-- nested inside another record.
data ExpandWhenNested

-- | Use this flag to not expand a Record type as a table when
-- nested inside another record. The 'Show' instance of the nested record
-- is used by default without expanding. This means that the fields of the
-- nested record are not displayed as separate headers.
data DoNotExpandWhenNested

-- | Class instance that needs to be instantiated for each
-- record that needs to be printed using printTable
--
-- @
--
-- data Stock = Stock {price:: Double, name:: String} derive (Show, G.Generic, Data)
-- instance Tabulate S 'ExpandWhenNested'
-- @
--
-- If 'S' is embedded inside another `Record` type and should be
-- displayed in regular Record Syntax, then
--
-- @
--
-- instance Tabulate S 'DoNotExpandWhenNested'
-- @
--
class Tabulate a flag | a->flag where {}

--instance TypeCast flag HFalse => Tabulate a flag
instance {-# OVERLAPPABLE #-} (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 that implements formatting using printf.
--    Default instances for String, Char, Int, Integer, Double and Float
--    are provided. For types that are not an instance of this class
--    `show` is used.
class CellValueFormatter a where

  -- Function that can be implemented by each instance
  ppFormatter :: a -> String

  -- Future support for this signature will be added
  ppFormatterWithStyle :: TablizeValueFormat -> a -> String

  -- Default instance of function for types that do
  -- do not have their own instance
  default ppFormatter :: (Show a) => a -> String
  ppFormatter x =  show x

  -- Future support.
  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
  -- toBox :: (Data a, G.Generic a, GRecordMeta(Rep a)) => b a ->  [[B.Box]]
  -- toBoxWithStyle :: (Data a, G.Generic a, GTabulate(Rep a)) => TablizeValueFormat -> b a ->  [[B.Box]]

  -- | Used to print a container of Records in a tabular format.
  --
  -- @
  --
  -- data Stock = Stock {price:: Double, ticker:: String} deriving (Show, Data, G.Generic)
  -- instance Tabulate Stock DoNotExpandWhenNested
  -- -- this can be a Vector or Map
  -- let s =  [Stock 10.0 "yahoo", Stock 12.0 "goog", Stock 10.0 "amz"]
  -- T.printTable s
  -- @
  --
  -- Nested records can also be printed in tabular format
  --
  -- @
  --
  -- data FxCode = USD | EUR deriving (Show, Data, G.Generic)
  -- instance 'CellValueFormatter' FxCode
  --
  -- data Price = Price {px:: Double, fxCode:: FxCode} deriving (Show, Data, G.Generic)
  -- instance 'Tabulate' Price 'ExpandWhenNested'
  -- -- since Price will be nested, it also needs an instance of
  -- -- CellValueFormatter
  -- instance CellValueFormatter Price
  --
  -- data Stock = Stock {ticker:: String, price:: Price} deriving (Show, Data, G.Generic)
  -- instance Tabulate Stock DoNotExpandWhenNested
  --
  -- -- this can be a Vector or Map
  -- let s =  [Stock "yahoo" (Price 10.0 USD), Stock "ikea" (Price 11.0 EUR)]
  -- printTable s
  -- @
  --
  printTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> IO ()
  --printTableWithStyle :: (Data a, G.Generic a, GTabulate(Rep a)) => TablizeValueFormat -> b a -> IO ()

  -- | Similar to 'printTable' but rather than return IO (), returns a
  -- 'Box' object that can be printed later on, using 'printBox'
  renderTable :: (G.Generic a, GRecordMeta (Rep a)) => b a -> B.Box

  -- | Used for printing selected fields from Record types
  -- This is useful when Records have a large number of fields
  -- and only few fields need to be introspected at any time.
  --
  -- Using the example provided under 'printTables',
  --
  -- @
  -- 'printTableWithFlds' [DFld (px . price), DFld ticker] s
  --
  -- @
  printTableWithFlds :: [DisplayFld t] -> b t -> IO ()

  -- | Same as printTableWithFlds but returns a `Box` object, rather than
  -- returning an `IO ()`.
  renderTableWithFlds :: [DisplayFld t] -> b t -> B.Box

-- | Instance methods to render or print a list of records in a tabular format.
instance Boxable [] where
  -- | Used to print a list of Records in a tabular format.
  -- @
  --
  -- data Stock = Stock {price:: Double, ticker:: String}
  -- instance Tabulate S DoNotExpandWhenNested
  -- let s =  [Stock 10.0 "yahoo", Stock 12.0 "goog", Stock 10.0 "amz"]
  -- T.printTable s
  --
  -- @
  printTable m = B.printBox $ ppRecords m

  renderTable m = ppRecords m

  -- | Print a "List" of records as a table with just the given fields.
  -- Called by "printTableWithFlds".
  printTableWithFlds flds recs = B.printBox $ renderTableWithFlds flds recs
  renderTableWithFlds = gen_renderTableWithFlds


instance Boxable V.Vector where
  -- | Prints a "Vector" as a table. Called by "printTable".
  -- | Need not be called directly
  printTable m = B.printBox $ renderTable m  --TODO: switch this to Vector
  renderTable m = ppRecords $ V.toList m

  -- | Print a "Vector" of records as a table with the selected fields.
  -- Called by "printTableWithFlds".
  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

  -- | Prints a "Map" as a table. Called by "ppTable"
  -- | Need not be called directly
  printTable m = B.printBox $ renderTable m
  renderTable m = ppRecordsWithIndex m

  -- | Prints a "Map" as a table with the selected fields. Called by "printTable"
  -- | Need not be called directly
  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

-- Pretty Print the reords as a table. Handles both records inside
-- Lists and Vectors
ppRecords :: (GRecordMeta (Rep a), G.Generic a) => [a] -> B.Box
ppRecords recs = result where
  result = B.hsep 5 B.top $ createHeaderDataBoxes recs

-- Pretty Print the records as a table. Handles records contained in a Map.
-- Functions also prints the keys as the index of the table.
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


-- What follows are helper functions to build the B.Box structure to print as table.

-- Internal helper functions for building the Tree.

-- Build the list of paths from the root to every leaf.
constructPath :: Tree a -> [[a]]
constructPath (Node r []) = [[r]]
constructPath (Node r f) = [r:x | x <- (L.concatMap constructPath f)]

-- Fill paths with a "-" so that all paths have the
-- same length.
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]

-- Count the number of fields in the passed structure.
-- The no of leaves is the sum of all fields across all nested
-- records in the passed structure.
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

-- Trims a the tree of records and return just the
-- leaves of the record
trimTree (Node r f) = trimLeaves r f

-- Helper function called by trimTree.
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

-- Get  all the leaves from the record. Returns all leaves
-- across the record structure.
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 :: [Tree String] -> [B.Box]
createHeaderCols rec_trees = header_boxes where
  header_boxes =  createBoxedHeaders . fillPath . constructPath . trimTree . L.head $ rec_trees

--createDataBoxes :: [Tree a] -> [B.Box]
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 :: Map.Map a a -> B.Box
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


-- testing

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"))

-- | Used with 'printTableWithFlds'
data DisplayFld a = forall s. CellValueFormatter s => DFld (a->s)

-- printTableWithFlds2 :: [DisplayFld t] -> V.Vector t -> IO ()
-- printTableWithFlds2 flds recs = B.printBox $ printTableWithFlds flds $ V.toList recs

-- printTableWithFlds3 :: (CellValueFormatter k) => [DisplayFld t] -> Map.Map k t -> IO ()
-- printTableWithFlds3 flds recs = results where
--   data_cols = printTableWithFlds 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 = B.printBox vertical_cols