kvitable-1.0.0.0: src/Data/KVITable/Render/ASCII.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-- | This module provides the 'KVITable' 'render' function for
-- rendering the table in a plain ASCII format.
module Data.KVITable.Render.ASCII
(
render
-- re-export Render definitions to save the caller an additional import
, RenderConfig(..)
, defaultRenderConfig
)
where
import qualified Data.List as L
import Data.Maybe ( fromMaybe, isNothing )
import Data.Text ( Text )
import qualified Data.Text as T
import Lens.Micro ( (^.) )
import qualified Prettyprinter as PP
import Data.KVITable
import Data.KVITable.Render
import Prelude hiding ( lookup )
-- | Renders the specified table in ASCII format, using the specified
-- 'RenderConfig' controls.
render :: PP.Pretty v => RenderConfig -> KVITable v -> Text
render cfg t =
let kseq = fst <$> t ^. keyVals
(fmt, hdr) = renderHdrs cfg t kseq
bdy = renderSeq cfg fmt kseq t
in T.unlines $ hdr <> bdy
----------------------------------------------------------------------
data FmtLine = FmtLine [Int] Sigils Sigils -- last is for sepline
data Sigils = Sigils { sep :: Text, pad :: Text, cap :: Text }
fmtLine :: [Int] -> FmtLine
fmtLine cols = FmtLine cols
Sigils { sep = "|", pad = " ", cap = "_" }
Sigils { sep = "+", pad = "-", cap = "_" }
fmtColCnt :: FmtLine -> Int
fmtColCnt (FmtLine cols _ _) = length cols
perColOvhd :: Int
perColOvhd = 2 -- pad chars on either side of each column's entry
-- | Formatted width of output, including pad on either side of each
-- column's value (but not the outer set), and a separator between columns.
--
-- Note that a column size of 0 indicates that hideBlankCols is active
-- and the column was found to be empty of values, so it should not be
-- counted.
fmtWidth :: FmtLine -> Int
fmtWidth (FmtLine cols _ _) =
let cols' = L.filter (/= 0) cols
in sum cols' + ((perColOvhd + 1) * (length cols' - 1))
fmtEmptyCols :: FmtLine -> Bool
fmtEmptyCols (FmtLine cols _ _) = sum cols == 0
fmtAddColLeft :: Int -> FmtLine -> FmtLine
fmtAddColLeft leftCol (FmtLine cols s s') = FmtLine (leftCol : cols) s s'
data FmtVal = Separator | TxtVal Text | CenterVal Text
fmtRender :: FmtLine -> [FmtVal] -> Text
fmtRender (FmtLine [] _sigils _sepsigils) [] = ""
fmtRender (FmtLine cols sigils sepsigils) vals =
if length cols == length vals
then let sig f o = case o of
Separator -> f sepsigils
TxtVal _ -> f sigils
CenterVal _ -> f sigils
l = sig sep $ head vals
in l <>
T.concat
[ sig pad fld <>
(case fld of
Separator -> T.pack (replicate sz '-')
TxtVal v -> T.pack (replicate (sz - T.length v) ' ') <> v
CenterVal t -> let (w,e) = (sz - T.length t - 2) `divMod` 2
m = cap sigils
ls = T.replicate (w + 0) m
rs = T.replicate (w + e) m
in if T.length t + 2 >= sz
then (T.replicate (sz - T.length t) " ") <> t
else ls <> " " <> t <> " " <> rs
) <>
sig pad fld <>
sig sep fld -- KWQ or if next fld is Nothing
| (sz,fld) <- zip cols vals, sz /= 0
]
else error ("Insufficient arguments (" <>
show (length vals) <> ")" <>
" for FmtLine " <> show (length cols))
----------------------------------------------------------------------
data HeaderLine = HdrLine FmtLine HdrVals Trailer
type HdrVals = [FmtVal]
type Trailer = Text
hdrFmt :: HeaderLine -> FmtLine
hdrFmt (HdrLine fmt _ _) = fmt
renderHdrs :: PP.Pretty v => RenderConfig -> KVITable v -> [Key] -> (FmtLine, [Text])
renderHdrs cfg t keys =
( lastFmt
, [ fmtRender fmt hdrvals
<> (if T.null trailer then "" else (" <- " <> trailer))
| (HdrLine fmt hdrvals trailer) <- hrows
] <>
[ fmtRender lastFmt (replicate (fmtColCnt lastFmt) Separator) ])
where
hrows = hdrstep cfg t keys
lastFmt = if null hrows then fmtLine [] else hdrFmt $ head $ reverse hrows
hdrstep :: PP.Pretty v => RenderConfig -> KVITable v -> [Key] -> [HeaderLine]
hdrstep _cfg t [] =
-- colStackAt wasn't recognized, so devolve into a non-colstack table
let valcoltxt = t ^. valueColName
valcoltsz = T.length valcoltxt
valsizes = length . show . PP.pretty . snd <$> toList t
valwidth = maximum $ valcoltsz : valsizes
in [ HdrLine (fmtLine [valwidth]) [TxtVal valcoltxt] "" ]
hdrstep cfg t (key:keys) =
if colStackAt cfg == Just key
then hdrvalstep cfg t [] (key:keys) -- switch to column-stacking mode
else
let keyw = maximum ( T.length key :
fmap T.length (fromMaybe [] $ L.lookup key $ t ^. keyVals) )
mkhdr (hs, v) (HdrLine fmt hdrvals trailer) =
( HdrLine (fmtAddColLeft keyw fmt) (TxtVal v : hdrvals) trailer : hs , "")
in reverse $ fst $ foldl mkhdr ([], key) $ hdrstep cfg t keys
-- first line shows hdrval for non-colstack'd columns, others are blank
hdrvalstep :: PP.Pretty v => RenderConfig -> KVITable v -> KeySpec -> [Key] -> [HeaderLine]
hdrvalstep _ _ _ [] = error "ASCII hdrvalstep with empty keys after matching colStackAt -- impossible"
hdrvalstep cfg t steppath (key:[]) =
let titles = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals
ordering = if sortKeyVals cfg then sortWithNums else id
cvalWidths kv = fmap (length . show . PP.pretty . snd) $
L.filter ((L.isSuffixOf (steppath <> [(key, kv)])) . fst) $
toList t
colWidth kv = let cvw = cvalWidths kv
in if and [ hideBlankCols cfg, sum cvw == 0 ]
then 0
else maximum $ T.length kv : cvw
cwidths = fmap colWidth titles
fmtcols = if equisizedCols cfg
then (replicate (length cwidths) (maximum cwidths))
else cwidths
in [ HdrLine (fmtLine $ fmtcols) (TxtVal <$> titles) key ]
hdrvalstep cfg t steppath (key:keys) =
let vals = ordering $ fromMaybe [] $ L.lookup key $ t ^. keyVals
ordering = if sortKeyVals cfg then sortWithNums else id
subhdrsV v = hdrvalstep cfg t (steppath <> [(key,v)]) keys
subTtlHdrs = let subAtVal v = (T.length v, subhdrsV v)
in fmap subAtVal vals
szexts = let subVW = fmtWidth . hdrFmt . head
subW (hl,sh) = let sv = subVW sh
in if and [ hideBlankCols cfg,
fmtEmptyCols $ hdrFmt $ head sh
]
then (0, 0)
else (hl, sv)
in fmap (uncurry max . subW) subTtlHdrs
rsz_extsubhdrs = fmap hdrJoin $
L.transpose $
fmap (uncurry rsz_hdrstack) $
zip szhdrs $ fmap snd subTtlHdrs
largest = maximum szexts
szhdrs = if equisizedCols cfg && not (hideBlankCols cfg)
then replicate (length vals) largest
else szexts
rsz_hdrstack s vhs = fmap (rsz_hdrs s) vhs
rsz_hdrs hw (HdrLine (FmtLine c s j) v r) =
let nzCols = L.filter (/= 0) c
pcw = sum nzCols + ((perColOvhd + 1) * (length nzCols - 1))
(ew,w0) = let l = length nzCols
in if l == 0 then (0,0)
else max 0 (hw - pcw) `divMod` length nzCols
c' = fst $ foldl (\(c'',n) w -> (c''<>[n+w],ew)) ([],ew+w0) c
in HdrLine (FmtLine c' s j) v r
hdrJoin hl = foldl hlJoin (HdrLine (fmtLine []) [] "") hl
hlJoin (HdrLine (FmtLine c s j) v _) (HdrLine (FmtLine c' _ _) v' r) =
HdrLine (FmtLine (c<>c') s j) (v<>v') r
tvals = fmap CenterVal vals
in HdrLine (fmtLine szhdrs) tvals key : rsz_extsubhdrs
renderSeq :: PP.Pretty v => RenderConfig -> FmtLine -> [Key] -> KVITable v -> [Text]
renderSeq cfg fmt keys kvitbl = fmtRender fmt . snd <$> asciiRows keys []
where
asciiRows :: [Key] -> KeySpec -> [ (Bool, [FmtVal]) ]
asciiRows [] path =
let v = lookup path kvitbl
skip = case v of
Nothing -> hideBlankRows cfg
Just _ -> False
in if skip then []
else [ (False, [ maybe (TxtVal "") TxtVal (T.pack . show . PP.pretty <$> v) ]) ]
asciiRows (key:kseq) path
| colStackAt cfg == Just key =
let filterOrDefaultBlankRows =
fmap (fmap defaultBlanks) .
if hideBlankRows cfg
then L.filter (not . all isNothing . snd)
else id
defaultBlanks = fmap (\v -> maybe (TxtVal "") TxtVal v)
in filterOrDefaultBlankRows $ [ (False, multivalRows (key:kseq) path) ]
| otherwise =
let subrows keyval = asciiRows kseq $ path <> [ (key, keyval) ]
grprow subs = if key `elem` rowGroup cfg && not (null subs)
then let subl = [ (True, replicate (length $ snd $ head subs) Separator) ]
in if fst (last subs)
then init subs <> subl
else subs <> subl
else subs
addSubrows ret keyval = ret <> (grprow $ fst $
foldl leftAdd ([],keyval) $ subrows keyval)
leftAdd (acc,kv) (b,subrow) = (acc <> [ (b, TxtVal kv : subrow) ],
if rowRepeat cfg then kv else "")
ordering = if sortKeyVals cfg then sortWithNums else id
in foldl addSubrows [] $ ordering $ fromMaybe [] $ L.lookup key $ kvitbl ^. keyVals
multivalRows :: [Key] -> KeySpec -> [ Maybe Text ]
multivalRows (key:[]) path =
let ordering = if sortKeyVals cfg then sortWithNums else id
keyvals = ordering $ fromMaybe [] $ L.lookup key $ kvitbl ^. keyVals
showEnt = T.pack . show . PP.pretty
in (\v -> (showEnt <$> (lookup (path <> [(key,v)]) kvitbl))) <$> keyvals
multivalRows (key:kseq) path =
let ordering = if sortKeyVals cfg then sortWithNums else id
keyvals = ordering $ fromMaybe [] $ L.lookup key $ kvitbl ^. keyVals
in concatMap (\v -> multivalRows kseq (path <> [(key,v)])) keyvals
multivalRows [] _ = error "multivalRows cannot be called with no keys!"