module Data.AsciiTable
( Table
, TableRow
, TableSlice
, makeTable
, makeTableWith
, prettyValue
, flattenObject
, Doc
, putDoc
, hPutDoc
, Pretty(..)
, SimpleDoc(..)
, renderPretty
, renderCompact
, renderSmart
, displayS
, displayIO
) where
import Control.Applicative (pure)
import Data.Aeson (Object, Value(..))
import Data.Foldable (foldl', foldMap)
import Data.Hashable (Hashable)
import Data.HashMap.Strict (HashMap)
import Data.List (transpose)
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>), mempty)
import Data.Set (Set)
import Data.Text (Text)
import Text.PrettyPrint.Free hiding ((<>))
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Vector as Vector
type TableRow a = [Maybe a]
type TableSlice a = [TableRow a]
data Table = Table
{ tableHeaders :: [Text]
, tableCellHeaders :: [[Text]]
, tableSlices :: [[[[Text]]]]
} deriving (Eq, Show)
instance Pretty Table where
pretty table =
let
widths = tableWidths table
in
vcat
[ tableSliceSep '-' widths
, ppTableHeaders widths (tableHeaders table)
, ppTableHeaders widths (map (const "") (tableHeaders table))
, ppTableRow widths (tableCellHeaders table)
, tableSliceSep '=' widths
, vsep (map (ppTableSlice widths) (tableSlices table))
]
where
ppTableSlice :: [[Int]] -> [[[Text]]] -> Doc e
ppTableSlice ns rs =
vsep (map (ppTableRow ns) rs)
`above`
tableSliceSep '-' ns
ppTableRow :: [[Int]] -> [[Text]] -> Doc e
ppTableRow nss rs = hsep (zipWith ppTableElem nss rs) <+> "|"
where
ppTableElem :: [Int] -> [Text] -> Doc e
ppTableElem ns es = "|" <+> hsep (zipWith ppTableCell ns es)
where
ppTableCell :: Int -> Text -> Doc e
ppTableCell n c = fill n (text (Text.unpack (escapeTabAndNewline c)))
ppTableHeaders :: [[Int]] -> [Text] -> Doc e
ppTableHeaders nss hs = hsep (zipWith ppTableHeader nss hs) <+> "|"
where
ppTableHeader :: [Int] -> Text -> Doc e
ppTableHeader ns h = "|" <+> fill (elemWidth ns) (text (Text.unpack (escapeTabAndNewline h)))
tableSliceSep :: Char -> [[Int]] -> Doc e
tableSliceSep c = (<> "+") . hcat . map elemSep
where
elemSep :: [Int] -> Doc e
elemSep ns = "+" <> text (replicate (2 + elemWidth ns) c)
tableWidths :: Table -> [[Int]]
tableWidths Table{..} =
let
ws0 :: [[Int]]
ws0 = unadjustedTableWidths (tableCellHeaders : concat tableSlices)
adjust :: Int -> [Int] -> [Int]
adjust n ns =
case unsnoc ns of
Nothing -> []
Just (ms, m) ->
let
len = foldl' (\x y -> x+y+1) (1) ns
in
if n > len
then ms ++ [m + n len]
else ns
in
zipWith adjust (map Text.length tableHeaders) ws0
where
unadjustedTableWidths :: [[[Text]]] -> [[Int]]
unadjustedTableWidths =
map (map (maximum . map Text.length) . transpose)
. transpose
unsnoc :: [a] -> Maybe ([a], a)
unsnoc [] = Nothing
unsnoc [x] = Just ([], x)
unsnoc (x:xs) = do
(ys,y) <- unsnoc xs
pure (x:ys,y)
elemWidth :: [Int] -> Int
elemWidth = foldr (\x y -> x+y+1) (1)
makeTable
:: [Text]
-> [TableSlice Object]
-> Table
makeTable headers slices =
makeTableWith id (\_ -> id) (\_ _ -> prettyValue) headers (flat slices)
where
flat :: [TableSlice Object] -> [TableSlice Object]
flat = (map . map . map . fmap) flattenObject
makeTableWith
:: forall h k v.
(Ord k, Hashable k)
=> (h -> Text)
-> (h -> k -> Text)
-> (h -> k -> v -> Text)
-> [h]
-> [TableSlice (HashMap k v)]
-> Table
makeTableWith showH showK showV headers slices =
Table headers' cell_headers' slices'
where
cell_headers :: [[k]]
cell_headers =
map (Set.toAscList . foldl' step mempty)
. transpose
. concat
$ slices
where
step :: Set k -> Maybe (HashMap k v) -> Set k
step acc Nothing = acc
step acc (Just x) = acc <> Set.fromList (HashMap.keys x)
headers':: [Text]
headers' = map showH headers
cell_headers' :: [[Text]]
cell_headers' = zipWith (map . showK) headers cell_headers
slices' :: [[[[Text]]]]
slices' =
(map . map) (zipWith3 go headers cell_headers) slices
where
go :: h -> [k] -> Maybe (HashMap k v) -> [Text]
go h ks (fromMaybe mempty -> m) =
map
(\k ->
case HashMap.lookup k m of
Nothing -> ""
Just v -> showV h k v)
ks
prettyValue :: Value -> Text
prettyValue = \case
Object o ->
"{"
<> Vector.ifoldr'
(\i (k,v) acc ->
"\""
<> k
<> "\":"
<> prettyValue v
<> if i == HashMap.size o 1
then acc
else ", " <> acc)
mempty
(Vector.fromList (HashMap.toList o))
<> "}"
Array a ->
"["
<> Vector.ifoldr'
(\i v acc ->
if i == Vector.length a 1
then prettyValue v <> acc
else prettyValue v <> ", " <> acc)
mempty
a
<> "]"
String s -> "\"" <> s <> "\""
Number n -> Text.pack (show n)
Bool b -> Text.pack (show b)
Null -> "null"
flattenObject :: Object -> Object
flattenObject = foldMap go . HashMap.toList
where
go :: (Text, Value) -> Object
go (k, v) =
case v of
Object o -> HashMap.fromList (map (prependKey k) (HashMap.toList (flattenObject o)))
_ -> HashMap.singleton k v
prependKey :: Text -> (Text, Value) -> (Text, Value)
prependKey k0 (k1, v) = (k0 <> "." <> k1, v)
escapeTabAndNewline :: Text -> Text
escapeTabAndNewline =
Text.replace (Text.singleton '\n') "\\n"
. Text.replace (Text.singleton '\t') "\\t"