lib: Expand Tabular.AsciiWide to allow multiline cells, either top or bottom aligned.

hledger-lib/Hledger/Reports/BudgetReport.hs

@@ -26,6 +26,7 @@ module Hledger.Reports.BudgetReport (
 where
 
 import Data.Decimal
+import Data.Default (def)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HM
 import Data.List
@@ -214,7 +215,8 @@ combineBudgetAndActual ropts j
 budgetReportAsText :: ReportOpts -> BudgetReport -> String
 budgetReportAsText ropts@ReportOpts{..} budgetr =
     title ++ "\n\n" ++
-    renderTable False pretty_tables_ leftCell rightCell (uncurry showcell) displayTableWithWidths
+    renderTable def{tableBorders=False,prettyTable=pretty_tables_}
+        (alignCell TopLeft) (alignCell TopRight) (uncurry showcell) displayTableWithWidths
   where
     multiperiod = interval_ /= NoInterval
     title = printf "Budget performance in %s%s:"
@@ -252,11 +254,9 @@ budgetReportAsText ropts@ReportOpts{..} budgetr =
     cols = transpose displaycells
 
     -- XXX lay out actual, percentage and/or goal in the single table cell for now, should probably use separate cells
-    showcell :: (Int, Int, Int) -> BudgetDisplayCell -> CellSpec
+    showcell :: (Int, Int, Int) -> BudgetDisplayCell -> Cell
     showcell (actualwidth, budgetwidth, percentwidth) ((actual,wa), mbudget) =
-        CellSpec (replicate (actualwidth - wa) ' ' ++ actual ++ budgetstr)
-                 AlignRight
-                 (actualwidth + totalbudgetwidth)
+        Cell TopRight [(replicate (actualwidth - wa) ' ' ++ actual ++ budgetstr, actualwidth + totalbudgetwidth)]
       where
         totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5
         totalbudgetwidth  = if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3

hledger-lib/Text/Tabular/AsciiWide.hs

@@ -3,30 +3,66 @@
 
 module Text.Tabular.AsciiWide where
 
+import Data.Maybe (fromMaybe)
+import Data.Default (Default(..))
 import Data.List (intersperse, transpose)
+import Safe (maximumMay)
 import Text.Tabular
-import Hledger.Utils.String
+import Text.WideString (strWidth)
+
+
+-- | The options to use for rendering a table.
+data TableOpts = TableOpts
+  { prettyTable  :: Bool  -- ^ Pretty tables
+  , tableBorders :: Bool  -- ^ Whether to display the outer borders
+  , borderSpaces :: Bool  -- ^ Whether to display spaces around bars
+  } deriving (Show)
+
+instance Default TableOpts where
+  def = TableOpts { prettyTable  = False
+                  , tableBorders = True
+                  , borderSpaces = True
+                  }
+
+-- | Cell contents along an alignment
+data Cell = Cell Align [(String, Int)]
+    deriving (Show)
+
+-- | How to align text in a cell
+data Align = TopRight | BottomRight | BottomLeft | TopLeft
+  deriving (Show)
+
+emptyCell :: Cell
+emptyCell = Cell TopRight []
+
+-- | Create a single-line cell from the given contents with its natural width.
+alignCell :: Align -> String -> Cell
+alignCell a x = Cell a [(x, strWidth x)]
+
+-- | Return the width of a Cell.
+cellWidth :: Cell -> Int
+cellWidth (Cell _ xs) = fromMaybe 0 . maximumMay $ map snd xs
 
 
 -- | Render a table according to common options, for backwards compatibility
 render :: Bool -> (rh -> String) -> (ch -> String) -> (a -> String) -> Table rh ch a -> String
-render pretty fr fc f = renderTable True pretty (rightCell . fr) (rightCell . fc) (rightCell . f)
+render pretty fr fc f = renderTable def{prettyTable=pretty} (cell . fr) (cell . fc) (cell . f)
+  where cell = alignCell TopRight
 
 -- | Render a table according to various cell specifications
-renderTable :: Bool              -- ^ Whether to display the outer borders
-            -> Bool              -- ^ Pretty tables
-            -> (rh -> CellSpec)  -- ^ Rendering function for row headers
-            -> (ch -> CellSpec)  -- ^ Rendering function for column headers
-            -> (a -> CellSpec)   -- ^ Function determining the string and width of a cell
+renderTable :: TableOpts         -- ^ Options controlling Table rendering
+            -> (rh -> Cell)  -- ^ Rendering function for row headers
+            -> (ch -> Cell)  -- ^ Rendering function for column headers
+            -> (a -> Cell)   -- ^ Function determining the string and width of a cell
             -> Table rh ch a
             -> String
-renderTable borders pretty fr fc f (Table rh ch cells) =
+renderTable topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (Table rh ch cells) =
   unlines . addBorders $
-    renderColumns borders pretty sizes ch2
+    renderColumns topts sizes ch2
     : bar VM DoubleLine   -- +======================================+
     : renderRs (fmap renderR $ zipHeader [] cellContents rowHeaders)
  where
-  renderR (cs,h) = renderColumns borders pretty sizes $ Group DoubleLine
+  renderR (cs,h) = renderColumns topts sizes $ Group DoubleLine
                      [ Header h
                      , fmap fst $ zipHeader emptyCell cs colHeaders
                      ]
@@ -40,7 +76,7 @@ renderTable borders pretty fr fc f (Table rh ch cells) =
   cells2 = headerContents ch2 : zipWith (:) (headerContents rowHeaders) cellContents
 
   -- maximum width for each column
-  sizes   = map (maximum . map csWidth) $ transpose cells2
+  sizes = map (fromMaybe 0 . maximumMay . map cellWidth) $ transpose cells2
   renderRs (Header s)   = [s]
   renderRs (Group p hs) = concat . intersperse sep $ map renderRs hs
     where sep = renderHLine VM borders pretty sizes ch2 p
@@ -49,59 +85,64 @@ renderTable borders pretty fr fc f (Table rh ch cells) =
   addBorders xs = if borders then bar VT SingleLine : xs ++ [bar VB SingleLine] else xs
   bar vpos prop = concat $ renderHLine vpos borders pretty sizes ch2 prop
 
-
-data CellSpec = CellSpec
-    { csString :: String
-    , csAlign  :: Align
-    , csWidth  :: Int
-    } deriving (Show)
-
-emptyCell :: CellSpec
-emptyCell = CellSpec "" AlignRight 0
-
-rightCell :: String -> CellSpec
-rightCell x = CellSpec x AlignRight (strWidth x)
-
-leftCell :: String -> CellSpec
-leftCell x = CellSpec x AlignLeft (strWidth x)
-
-data Align = AlignLeft | AlignRight
-  deriving (Show)
+-- | Render a single row according to cell specifications.
+renderRow :: TableOpts -> Header Cell -> String
+renderRow topts h = renderColumns topts is h
+  where is = map (\(Cell _ xs) -> fromMaybe 0 . maximumMay $ map snd xs) $ headerContents h
 
 
 verticalBar :: Bool -> Char
 verticalBar pretty = if pretty then '│' else '|'
 
-leftBar :: Bool -> String
-leftBar pretty = verticalBar pretty : " "
+leftBar :: Bool -> Bool -> String
+leftBar pretty True  = verticalBar pretty : " "
+leftBar pretty False = [verticalBar pretty]
 
-rightBar :: Bool -> String
-rightBar pretty = " " ++ [verticalBar pretty]
+rightBar :: Bool -> Bool -> String
+rightBar pretty True  = ' ' : [verticalBar pretty]
+rightBar pretty False = [verticalBar pretty]
 
-midBar :: Bool -> String
-midBar pretty = " " ++ verticalBar pretty : " "
+midBar :: Bool -> Bool -> String
+midBar pretty True  = ' ' : verticalBar pretty : " "
+midBar pretty False = [verticalBar pretty]
 
-doubleMidBar :: Bool -> String
-doubleMidBar pretty = if pretty then " ║ " else " || "
+doubleMidBar :: Bool -> Bool -> String
+doubleMidBar pretty True  = if pretty then " ║ " else " || "
+doubleMidBar pretty False = if pretty then "║" else "||"
 
 -- | We stop rendering on the shortest list!
-renderColumns :: Bool   -- ^ show outer borders
-              -> Bool   -- ^ pretty
-              -> [Int]  -- ^ max width for each column
-              -> Header CellSpec
+renderColumns :: TableOpts  -- ^ rendering options for the table
+              -> [Int]      -- ^ max width for each column
+              -> Header Cell
               -> String
-renderColumns borders pretty is h = addBorders coreLine
- where
-  addBorders xs = if borders then leftBar pretty ++ xs ++ rightBar pretty else ' ' : xs ++ " "
-  coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h
-  helper = either hsep (\(w, cs) -> case csAlign cs of
-                            AlignLeft  -> csString cs ++ replicate (w - csWidth cs) ' '
-                            AlignRight -> replicate (w - csWidth cs) ' ' ++ csString cs
-                        )
-  hsep :: Properties -> String
-  hsep NoLine     = "  "
-  hsep SingleLine = midBar pretty
-  hsep DoubleLine = doubleMidBar pretty
+renderColumns TableOpts{prettyTable=pretty, tableBorders=borders, borderSpaces=spaces} is h =
+    concat . intersperse "\n"                    -- Put each line on its own line
+    . map (addBorders . concat) . transpose      -- Change to a list of lines and add borders
+    . map (either hsep padCell) . flattenHeader  -- We now have a matrix of strings
+    . zipHeader 0 is $ padRow <$> h  -- Pad cell height and add width marker
+  where
+    -- Pad each cell to have the appropriate width
+    padCell (w, Cell TopLeft     ls) = map (\(x,xw) -> x ++ replicate (w - xw) ' ') ls
+    padCell (w, Cell BottomLeft  ls) = map (\(x,xw) -> x ++ replicate (w - xw) ' ') ls
+    padCell (w, Cell TopRight    ls) = map (\(x,xw) -> replicate (w - xw) ' ' ++ x) ls
+    padCell (w, Cell BottomRight ls) = map (\(x,xw) -> replicate (w - xw) ' ' ++ x) ls
+
+    -- Pad each cell to have the same number of lines
+    padRow (Cell TopLeft     ls) = Cell TopLeft     $ ls ++ replicate (nLines - length ls) ("",0)
+    padRow (Cell TopRight    ls) = Cell TopRight    $ ls ++ replicate (nLines - length ls) ("",0)
+    padRow (Cell BottomLeft  ls) = Cell BottomLeft  $ replicate (nLines - length ls) ("",0) ++ ls
+    padRow (Cell BottomRight ls) = Cell BottomRight $ replicate (nLines - length ls) ("",0) ++ ls
+
+    hsep :: Properties -> [String]
+    hsep NoLine     = replicate nLines $ if spaces then "  " else ""
+    hsep SingleLine = replicate nLines $ midBar pretty spaces
+    hsep DoubleLine = replicate nLines $ doubleMidBar pretty spaces
+
+    addBorders xs | borders   = leftBar pretty spaces ++ xs ++ rightBar pretty spaces
+                  | spaces    =  ' ' : xs ++ " "
+                  | otherwise = xs
+
+    nLines = fromMaybe 0 . maximumMay . map (\(Cell _ ls) -> length ls) $ headerContents h
 
 renderHLine :: VPos
             -> Bool  -- ^ show outer borders

hledger-lib/Text/WideString.hs

@@ -0,0 +1,71 @@
+-- | Calculate the width of String and Text, being aware of wide characters.
+
+module Text.WideString (
+  -- * wide-character-aware layout
+  strWidth,
+  textWidth,
+  charWidth
+  ) where
+
+import Data.Text (Text)
+import qualified Data.Text as T
+
+
+-- | Calculate the render width of a string, considering
+-- wide characters (counted as double width)
+strWidth :: String -> Int
+strWidth = foldr (\a b -> charWidth a + b) 0
+
+-- | Calculate the render width of a string, considering
+-- wide characters (counted as double width)
+textWidth :: Text -> Int
+textWidth = T.foldr (\a b -> charWidth a + b) 0
+
+-- from Pandoc (copyright John MacFarlane, GPL)
+-- see also http://unicode.org/reports/tr11/#Description
+
+-- | Get the designated render width of a character: 0 for a combining
+-- character, 1 for a regular character, 2 for a wide character.
+-- (Wide characters are rendered as exactly double width in apps and
+-- fonts that support it.) (From Pandoc.)
+charWidth :: Char -> Int
+charWidth c
+    | c <  '\x0300'                    = 1
+    | c >= '\x0300' && c <= '\x036F'   = 0  -- combining
+    | c >= '\x0370' && c <= '\x10FC'   = 1
+    | c >= '\x1100' && c <= '\x115F'   = 2
+    | c >= '\x1160' && c <= '\x11A2'   = 1
+    | c >= '\x11A3' && c <= '\x11A7'   = 2
+    | c >= '\x11A8' && c <= '\x11F9'   = 1
+    | c >= '\x11FA' && c <= '\x11FF'   = 2
+    | c >= '\x1200' && c <= '\x2328'   = 1
+    | c >= '\x2329' && c <= '\x232A'   = 2
+    | c >= '\x232B' && c <= '\x2E31'   = 1
+    | c >= '\x2E80' && c <= '\x303E'   = 2
+    | c == '\x303F'                    = 1
+    | c >= '\x3041' && c <= '\x3247'   = 2
+    | c >= '\x3248' && c <= '\x324F'   = 1 -- ambiguous
+    | c >= '\x3250' && c <= '\x4DBF'   = 2
+    | c >= '\x4DC0' && c <= '\x4DFF'   = 1
+    | c >= '\x4E00' && c <= '\xA4C6'   = 2
+    | c >= '\xA4D0' && c <= '\xA95F'   = 1
+    | c >= '\xA960' && c <= '\xA97C'   = 2
+    | c >= '\xA980' && c <= '\xABF9'   = 1
+    | c >= '\xAC00' && c <= '\xD7FB'   = 2
+    | c >= '\xD800' && c <= '\xDFFF'   = 1
+    | c >= '\xE000' && c <= '\xF8FF'   = 1 -- ambiguous
+    | c >= '\xF900' && c <= '\xFAFF'   = 2
+    | c >= '\xFB00' && c <= '\xFDFD'   = 1
+    | c >= '\xFE00' && c <= '\xFE0F'   = 1 -- ambiguous
+    | c >= '\xFE10' && c <= '\xFE19'   = 2
+    | c >= '\xFE20' && c <= '\xFE26'   = 1
+    | c >= '\xFE30' && c <= '\xFE6B'   = 2
+    | c >= '\xFE70' && c <= '\xFEFF'   = 1
+    | c >= '\xFF01' && c <= '\xFF60'   = 2
+    | c >= '\xFF61' && c <= '\x16A38'  = 1
+    | c >= '\x1B000' && c <= '\x1B001' = 2
+    | c >= '\x1D000' && c <= '\x1F1FF' = 1
+    | c >= '\x1F200' && c <= '\x1F251' = 2
+    | c >= '\x1F300' && c <= '\x1F773' = 1
+    | c >= '\x20000' && c <= '\x3FFFD' = 2
+    | otherwise                        = 1

hledger-lib/hledger-lib.cabal

@@ -1,10 +1,10 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.33.0.
+-- This file has been generated from package.yaml by hpack version 0.34.2.
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: a604ce23a128bb6cf15351a33b24e7d1095f46624e7e066a5e07473c681da8da
+-- hash: 24b8acde4649dda5e31d86c9f4f95744af97bae68f0e978144a55baf621d0bc8
 
 name:           hledger-lib
 version:        1.19.99
@@ -103,6 +103,7 @@ library
       Text.Tabular.AsciiWide
   other-modules:
       Text.Megaparsec.Custom
+      Text.WideString
       Paths_hledger_lib
   hs-source-dirs:
       ./.

hledger/Hledger/Cli/Commands/Balance.hs

@@ -253,8 +253,9 @@ module Hledger.Cli.Commands.Balance (
  ,tests_Balance
 ) where
 
-import Data.List
-import Data.Maybe
+import Data.Default (def)
+import Data.List (intercalate, transpose)
+import Data.Maybe (fromMaybe, maybeToList)
 --import qualified Data.Map as Map
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
@@ -608,10 +609,10 @@ balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_}
 -- unless --no-elide is used.
 balanceReportTableAsText :: ReportOpts -> Table String String MixedAmount -> String
 balanceReportTableAsText ReportOpts{..} =
-    T.renderTable False pretty_tables_ T.leftCell T.rightCell showamt
+    T.renderTable def{tableBorders=False, prettyTable=pretty_tables_}
+        (T.alignCell TopLeft) (T.alignCell TopRight) showamt
   where
-    showamt a = CellSpec str AlignRight w
-      where (str, w) = showMixedOneLine showAmountWithoutPrice Nothing mmax color_ a
+    showamt = Cell TopRight . pure . showMixedOneLine showAmountWithoutPrice Nothing mmax color_
     mmax = if no_elide_ then Nothing else Just 32