cli:Render pretty line-art tables with smooth borders

hledger-lib/Text/Tabular/AsciiWide.hs

@@ -16,14 +16,14 @@ render :: Bool -- ^ pretty tables
        -> Table rh ch a
        -> String
 render pretty fr fc f (Table rh ch cells) =
-  unlines $ [ bar SingleLine   -- +--------------------------------------+
+  unlines $ [ bar VT SingleLine   -- +--------------------------------------+
             , renderColumns pretty sizes ch2
-            , bar DoubleLine   -- +======================================+
+            , bar VM DoubleLine   -- +======================================+
             ] ++
             (renderRs $ fmap renderR $ zipHeader [] cells $ fmap fr rh) ++
-            [ bar SingleLine ] -- +--------------------------------------+
+            [ bar VB SingleLine ] -- +--------------------------------------+
  where
-  bar = concat . renderHLine pretty sizes ch2
+  bar vpos prop = concat (renderHLine vpos pretty sizes ch2 prop)
   -- ch2 and cell2 include the row and column labels
   ch2 = Group DoubleLine [Header "", fmap fc ch]
   cells2 = headerContents ch2
@@ -37,7 +37,7 @@ render pretty fr fc f (Table rh ch cells) =
   sizes   = map (maximum . map strWidth) . transpose $ cells2
   renderRs (Header s)   = [s]
   renderRs (Group p hs) = concat . intersperse sep . map renderRs $ hs
-    where sep = renderHLine pretty sizes ch2 p
+    where sep = renderHLine VM pretty sizes ch2 p
 
 verticalBar :: Bool -> Char
 verticalBar pretty = if pretty then '│' else '|'
@@ -54,12 +54,6 @@ midBar pretty = " " ++ verticalBar pretty : " "
 doubleMidBar :: Bool -> String
 doubleMidBar pretty = if pretty then " ║ " else " || "
 
-horizontalBar :: Bool -> Char
-horizontalBar pretty = if pretty then '─' else '-'
-
-doubleHorizontalBar :: Bool -> Char
-doubleHorizontalBar pretty = if pretty then '═' else '='
-
 -- | We stop rendering on the shortest list!
 renderColumns :: Bool -- ^ pretty
               -> [Int] -- ^ max width for each column
@@ -74,27 +68,102 @@ renderColumns pretty is h = leftBar pretty ++ coreLine ++ rightBar pretty
   hsep SingleLine = midBar pretty
   hsep DoubleLine = doubleMidBar pretty
 
-renderHLine :: Bool -- ^ pretty
+renderHLine :: VPos
+            -> Bool -- ^ pretty
             -> [Int] -- ^ width specifications
             -> Header String
             -> Properties
             -> [String]
-renderHLine _ _ _ NoLine = []
+renderHLine _ _ _ _ NoLine = []
-renderHLine pretty w h SingleLine = [renderHLine' pretty SingleLine w (horizontalBar pretty) h]
+renderHLine vpos pretty w h prop = [renderHLine' vpos pretty prop w h]
-renderHLine pretty w h DoubleLine = [renderHLine' pretty DoubleLine w (doubleHorizontalBar pretty) h]
 
-renderHLine' :: Bool -> Properties -> [Int] -> Char -> Header String -> String
+renderHLine' :: VPos -> Bool -> Properties -> [Int] -> Header String -> String
-renderHLine' pretty prop is sep h = edge ++ sep : coreLine ++ sep : edge
+renderHLine' vpos pretty prop is h = edge HL ++ sep ++ coreLine ++ sep ++ edge HR
  where
-  edge            = cross SingleLine prop
+  edge hpos       = boxchar vpos hpos SingleLine prop pretty
   coreLine        = concatMap helper $ flattenHeader $ zipHeader 0 is h
   helper          = either vsep dashes
-  dashes (i,_)    = replicate i sep
+  dashes (i,_)    = concat (replicate i sep)
-  vsep v          = sep : cross v prop ++ [sep]
+  sep             = boxchar vpos HM NoLine prop pretty
+  vsep v          = sep ++ cross v prop ++ sep
+  cross v h       = boxchar vpos HM v h pretty
 
-  --    vertical   horizontal
+data VPos = VT | VM | VB -- top middle bottom
-  cross SingleLine SingleLine = if pretty then "┼" else "+"
+data HPos = HL | HM | HR -- left middle right
-  cross SingleLine DoubleLine = if pretty then "╪" else "+"
+
-  cross DoubleLine SingleLine = if pretty then "╫" else "++"
+boxchar :: VPos -> HPos -> Properties -> Properties -> Bool -> String
-  cross DoubleLine DoubleLine = if pretty then "╬" else "++"
+boxchar vpos hpos vert horiz = lineart u d l r
-  cross _          _          = ""
+  where
+    u =
+      case vpos of
+        VT -> NoLine
+        _  -> vert
+    d =
+      case vpos of
+        VB -> NoLine
+        _  -> vert
+    l =
+      case hpos of
+        HL -> NoLine
+        _  -> horiz
+    r =
+      case hpos of
+        HR -> NoLine
+        _  -> horiz
+
+pick :: String -> String -> Bool -> String
+pick x _ True  = x
+pick _ x False = x
+
+lineart :: Properties -> Properties -> Properties -> Properties -> Bool -> String
+--      up         down       left      right
+lineart SingleLine SingleLine SingleLine SingleLine = pick "┼" "+"
+lineart SingleLine SingleLine SingleLine NoLine     = pick "┤" "+"
+lineart SingleLine SingleLine NoLine     SingleLine = pick "├" "+"
+lineart SingleLine NoLine     SingleLine SingleLine = pick "┴" "+"
+lineart NoLine     SingleLine SingleLine SingleLine = pick "┬" "+"
+lineart SingleLine NoLine     NoLine     SingleLine = pick "└" "+"
+lineart SingleLine NoLine     SingleLine NoLine     = pick "┘" "+"
+lineart NoLine     SingleLine SingleLine NoLine     = pick "┐" "+"
+lineart NoLine     SingleLine NoLine     SingleLine = pick "┌" "+"
+lineart SingleLine SingleLine NoLine     NoLine     = pick "│" "|"
+lineart NoLine     NoLine     SingleLine SingleLine = pick "─" "-"
+
+lineart DoubleLine DoubleLine DoubleLine DoubleLine = pick "╬" "++"
+lineart DoubleLine DoubleLine DoubleLine NoLine     = pick "╣" "++"
+lineart DoubleLine DoubleLine NoLine     DoubleLine = pick "╠" "++"
+lineart DoubleLine NoLine     DoubleLine DoubleLine = pick "╩" "++"
+lineart NoLine     DoubleLine DoubleLine DoubleLine = pick "╦" "++"
+lineart DoubleLine NoLine     NoLine     DoubleLine = pick "╚" "++"
+lineart DoubleLine NoLine     DoubleLine NoLine     = pick "╝" "++"
+lineart NoLine     DoubleLine DoubleLine NoLine     = pick "╗" "++"
+lineart NoLine     DoubleLine NoLine     DoubleLine = pick "╔" "++"
+lineart DoubleLine DoubleLine NoLine     NoLine     = pick "║" "||"
+lineart NoLine     NoLine     DoubleLine DoubleLine = pick "═" "="
+
+lineart DoubleLine NoLine     NoLine     SingleLine = pick "╙" "++"
+lineart DoubleLine NoLine     SingleLine NoLine     = pick "╜" "++"
+lineart NoLine     DoubleLine SingleLine NoLine     = pick "╖" "++"
+lineart NoLine     DoubleLine NoLine     SingleLine = pick "╓" "++"
+
+lineart SingleLine NoLine     NoLine     DoubleLine = pick "╘" "+"
+lineart SingleLine NoLine     DoubleLine NoLine     = pick "╛" "+"
+lineart NoLine     SingleLine DoubleLine NoLine     = pick "╕" "+"
+lineart NoLine     SingleLine NoLine     DoubleLine = pick "╒" "+"
+
+lineart DoubleLine DoubleLine SingleLine NoLine     = pick "╢" "++"
+lineart DoubleLine DoubleLine NoLine     SingleLine = pick "╟" "++"
+lineart DoubleLine NoLine     SingleLine SingleLine = pick "╨" "++"
+lineart NoLine     DoubleLine SingleLine SingleLine = pick "╥" "++"
+
+lineart SingleLine SingleLine DoubleLine NoLine     = pick "╡" "+"
+lineart SingleLine SingleLine NoLine     DoubleLine = pick "╞" "+"
+lineart SingleLine NoLine     DoubleLine DoubleLine = pick "╧" "+"
+lineart NoLine     SingleLine DoubleLine DoubleLine = pick "╤" "+"
+
+lineart SingleLine SingleLine DoubleLine DoubleLine = pick "╪" "+"
+lineart DoubleLine DoubleLine SingleLine SingleLine = pick "╫" "++"
+
+lineart _          _          _          _          = const ""
+
+--