module Data.AsciiTable
( Table
, TableRow
, TableSlice
, TableElem(..)
, makeTable
, Doc
, putDoc
, hPutDoc
, Pretty(..)
, SimpleDoc(..)
, renderPretty
, renderCompact
, renderSmart
, displayS
, displayIO
) where
import Control.Applicative (pure)
import Data.Aeson (Object, Value(..))
import Data.DList (DList)
import Data.Foldable (foldl')
import Data.HashMap.Strict (HashMap)
import Data.List (transpose)
import Data.Monoid ((<>), mempty)
import Data.Set (Set)
import Data.Text (Text)
import Text.PrettyPrint.Free hiding ((<>))
import qualified Data.DList as DList
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set
import qualified Data.Text as Text
import qualified Data.Text.Lazy as LText
import qualified Data.Text.Lazy.Builder as LTBuilder
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 (map (uncurry ppTableElem) (zip nss rs)) <+> "|"
where
ppTableElem :: [Int] -> [Text] -> Doc e
ppTableElem ns es = "|" <+> hsep (map (uncurry ppTableCell) (zip 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 (map (uncurry ppTableHeader) (zip nss hs)) <+> "|"
where
ppTableHeader :: [Int] -> Text -> Doc e
ppTableHeader ns h = "|" <+> fill (elemWidth ns) (text (Text.unpack 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
map adjust (zip (map Text.length tableHeaders) ws0)
where
unadjustedTableWidths :: [[[Text]]] -> [[Int]]
unadjustedTableWidths =
map (map (maximum . map Text.length))
. map 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)
class TableElem a where
tableElemCells :: a -> HashMap Text Text
instance TableElem (HashMap Text Value) where
tableElemCells obj = HashMap.fromList (DList.toList (objectCells obj))
where
objectCells :: Object -> DList (Text, Text)
objectCells = foldl' step mempty . HashMap.toList
where
step :: DList (Text, Text) -> (Text, Value) -> DList (Text, Text)
step acc (k, v) = acc <>
case v of
Object o ->
fmap (\(k',v') ->
let k'' :: LTBuilder.Builder
k'' = LTBuilder.fromText k
<> LTBuilder.singleton '.'
<> LTBuilder.fromText k'
in (LText.toStrict (LTBuilder.toLazyText k''), v'))
(objectCells o)
_ -> pure (k, LText.toStrict (LTBuilder.toLazyText (showValue v)))
showValue :: Value -> LTBuilder.Builder
showValue (Object o) =
LTBuilder.singleton '{'
<> Vector.ifoldr' (\i (k,v) acc ->
LTBuilder.singleton '\"'
<> LTBuilder.fromText k
<> LTBuilder.singleton '\"'
<> ":"
<> showValue v
<> if i == HashMap.size o 1
then acc
else ", " <> acc
) mempty
(Vector.fromList $ HashMap.toList o)
<> LTBuilder.singleton '}'
showValue (Array a) =
LTBuilder.singleton '['
<> Vector.ifoldr' (\i v acc -> if i == Vector.length a 1
then showValue v <> acc
else showValue v <> ", " <> acc
) mempty a
<> LTBuilder.singleton ']'
showValue (String s) =
LTBuilder.singleton '"'
<> LTBuilder.fromText s
<> LTBuilder.singleton '"'
showValue (Number n) = LTBuilder.fromString (show n)
showValue (Bool b) = LTBuilder.fromString (show b)
showValue Null = "null"
makeTable :: forall a. TableElem a => [Text] -> [TableSlice a] -> Table
makeTable headers slices =
let
cell_headers :: [[Text]]
cell_headers =
let
step :: Set Text -> HashMap Text Text -> Set Text
step acc x = acc <> Set.fromList (HashMap.keys x)
in
map (map escapeTabAndNewline . Set.toAscList . foldl' step mempty)
. transpose
. concat
$ elems
elems :: [[[HashMap Text Text]]]
elems = map (map (map (maybe mempty tableElemCells))) slices
text_elems :: [[[[Text]]]]
text_elems =
map (map (map (uncurry go))) (map (map (flip zip cell_headers)) elems)
where
go :: HashMap Text Text -> [Text] -> [Text]
go m = map (\k -> HashMap.lookupDefault "" k m)
in
Table headers cell_headers text_elems
escapeTabAndNewline :: Text -> Text
escapeTabAndNewline =
Text.replace (Text.singleton '\n') "\\n"
. Text.replace (Text.singleton '\t') "\\t"