cli: Using Text Builder for posting reports.

hledger-lib/Hledger/Data/Json.hs

@@ -44,7 +44,7 @@ import           Data.Decimal
 import           Data.Maybe
 import qualified Data.Text.Lazy    as TL
 import qualified Data.Text.Lazy.IO as TL
-import           Data.Text.Lazy.Builder (toLazyText)
+import qualified Data.Text.Lazy.Builder as TB
 import           GHC.Generics (Generic)
 import           System.Time (ClockTime)
 
@@ -232,7 +232,7 @@ instance FromJSON (DecimalRaw Integer)
 
 -- | Show a JSON-convertible haskell value as pretty-printed JSON text.
 toJsonText :: ToJSON a => a -> TL.Text
-toJsonText = (<>"\n") . toLazyText . encodePrettyToTextBuilder
+toJsonText = TB.toLazyText . (<> TB.fromText "\n") . encodePrettyToTextBuilder
 
 -- | Write a JSON-convertible haskell value to a pretty-printed JSON file.
 -- Eg: writeJsonFile "a.json" nulltransaction

hledger-lib/Hledger/Reports/PostingsReport.hs

@@ -24,8 +24,7 @@ where
 import Data.List
 import Data.List.Extra (nubSort)
 import Data.Maybe
--- import Data.Text (Text)
+import Data.Text (Text)
-import qualified Data.Text as T
 import Data.Time.Calendar
 import Safe (headMay, lastMay)
 
@@ -38,9 +37,7 @@ import Hledger.Reports.ReportOptions
 -- | A postings report is a list of postings with a running total, a label
 -- for the total field, and a little extra transaction info to help with rendering.
 -- This is used eg for the register command.
-type PostingsReport = (String               -- label for the running balance column XXX remove
+type PostingsReport = [PostingsReportItem] -- line items, one per posting
-                      ,[PostingsReportItem] -- line items, one per posting
-                      )
 type PostingsReportItem = (Maybe Day    -- The posting date, if this is the first posting in a
                                         -- transaction or if it's different from the previous
                                         -- posting's date. Or if this a summary posting, the
@@ -49,7 +46,7 @@ type PostingsReportItem = (Maybe Day    -- The posting date, if this is the firs
                           ,Maybe Day    -- If this is a summary posting, the report interval's
                                         -- end date if this is the first summary posting in
                                         -- the interval.
-                          ,Maybe String -- The posting's transaction's description, if this is the first posting in the transaction.
+                          ,Maybe Text   -- The posting's transaction's description, if this is the first posting in the transaction.
                           ,Posting      -- The posting, possibly with the account name depth-clipped.
                           ,MixedAmount  -- The running total after this posting, or with --average,
                                         -- the running average posting amount. With --historical,
@@ -66,8 +63,7 @@ type SummaryPosting = (Posting, Day)
 -- | Select postings from the journal and add running balance and other
 -- information to make a postings report. Used by eg hledger's register command.
 postingsReport :: ReportSpec -> Journal -> PostingsReport
-postingsReport rspec@ReportSpec{rsOpts=ropts@ReportOpts{..}} j =
+postingsReport rspec@ReportSpec{rsOpts=ropts@ReportOpts{..}} j = items
-  (totallabel, items)
     where
       reportspan  = adjustReportDates rspec j
       whichdate   = whichDateFromOpts ropts
@@ -130,8 +126,6 @@ registerRunningCalculationFn ropts
   | average_ ropts = \i avg amt -> avg + divideMixedAmount (fromIntegral i) (amt - avg)
   | otherwise      = \_ bal amt -> bal + amt
 
-totallabel = "Total"
-
 -- | Adjust report start/end dates to more useful ones based on
 -- journal data and report intervals. Ie:
 -- 1. If the start date is unspecified, use the earliest date in the journal (if any)
@@ -206,14 +200,13 @@ mkpostingsReportItem :: Bool -> Bool -> WhichDate -> Maybe Day -> Posting -> Mix
 mkpostingsReportItem showdate showdesc wd menddate p b =
   (if showdate then Just date else Nothing
   ,menddate
-  ,if showdesc then Just desc else Nothing
+  ,if showdesc then tdescription <$> ptransaction p else Nothing
   ,p
   ,b
   )
   where
     date = case wd of PrimaryDate   -> postingDate p
                       SecondaryDate -> postingDate2 p
-    desc = T.unpack $ maybe "" tdescription $ ptransaction p
 
 -- | Convert a list of postings into summary postings, one per interval,
 -- aggregated to the specified depth if any.
@@ -267,7 +260,7 @@ negatePostingAmount p = p { pamount = negate $ pamount p }
 tests_PostingsReport = tests "PostingsReport" [
 
    test "postingsReport" $ do
-    let (query, journal) `gives` n = (length $ snd $ postingsReport defreportspec{rsQuery=query} journal) @?= n
+    let (query, journal) `gives` n = (length $ postingsReport defreportspec{rsQuery=query} journal) @?= n
     -- with the query specified explicitly
     (Any, nulljournal) `gives` 0
     (Any, samplejournal) `gives` 13
@@ -276,10 +269,10 @@ tests_PostingsReport = tests "PostingsReport" [
     (And [Depth 1, StatusQ Cleared, Acct (toRegex' "expenses")], samplejournal) `gives` 2
     (And [And [Depth 1, StatusQ Cleared], Acct (toRegex' "expenses")], samplejournal) `gives` 2
     -- with query and/or command-line options
-    (length $ snd $ postingsReport defreportspec samplejournal) @?= 13
+    (length $ postingsReport defreportspec samplejournal) @?= 13
-    (length $ snd $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11
+    (length $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11
-    (length $ snd $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1, empty_=True}} samplejournal) @?= 20
+    (length $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1, empty_=True}} samplejournal) @?= 20
-    (length $ snd $ postingsReport defreportspec{rsQuery=Acct $ toRegex' "assets:bank:checking"} samplejournal) @?= 5
+    (length $ postingsReport defreportspec{rsQuery=Acct $ toRegex' "assets:bank:checking"} samplejournal) @?= 5
 
      -- (defreportopts, And [Acct "a a", Acct "'b"], samplejournal2) `gives` 0
      -- [(Just (fromGregorian 2008 01 01,"income"),assets:bank:checking             $1,$1)

hledger/Hledger/Cli/Commands/Add.hs

@@ -30,6 +30,8 @@ import qualified Data.Set as S
 import Data.Maybe
 import Data.Text (Text)
 import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO as TL
 import Data.Time.Calendar (Day)
 import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat)
 import Safe (headDef, headMay, atMay)
@@ -442,7 +444,7 @@ journalAddTransaction j@Journal{jtxns=ts} opts t = do
     -- unelided shows all amounts explicitly, in case there's a price, cf #283
   when (debug_ opts > 0) $ do
     putStrLn $ printf "\nAdded transaction to %s:" f
-    putStrLn =<< registerFromString (showTransaction t)
+    TL.putStrLn =<< registerFromString (T.pack $ showTransaction t)
   return j{jtxns=ts++[t]}
 
 -- | Append a string, typically one or more transactions, to a journal
@@ -464,9 +466,9 @@ ensureOneNewlineTerminated :: String -> String
 ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse
 
 -- | Convert a string of journal data into a register report.
-registerFromString :: String -> IO String
+registerFromString :: Text -> IO TL.Text
 registerFromString s = do
-  j <- readJournal' $ T.pack s
+  j <- readJournal' s
   return . postingsReportAsText opts $ postingsReport rspec j
       where
         ropts = defreportopts{empty_=True}

hledger/Hledger/Cli/Commands/Register.hs

@@ -23,6 +23,7 @@ import Data.Maybe
 -- import Data.Text (Text)
 import qualified Data.Text as T
 import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Builder as TB
 import System.Console.CmdArgs.Explicit
 import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV)
 
@@ -58,16 +59,17 @@ registermode = hledgerCommandMode
 
 -- | Print a (posting) register report.
 register :: CliOpts -> Journal -> IO ()
-register opts@CliOpts{reportspec_=rspec} j = do
+register opts@CliOpts{reportspec_=rspec} j =
-  let fmt = outputFormatFromOpts opts
+    writeOutputLazyText opts . render $ postingsReport rspec j
-      render | fmt=="txt"  = postingsReportAsText
+  where
-             | fmt=="csv"  = const ((++"\n") . printCSV . postingsReportAsCsv)
+    fmt = outputFormatFromOpts opts
-             | fmt=="json" = const ((++"\n") . TL.unpack . toJsonText)
+    render | fmt=="txt"  = postingsReportAsText opts
-             | otherwise   = const $ error' $ unsupportedOutputFormatError fmt  -- PARTIAL:
+           | fmt=="csv"  = TL.pack . printCSV . postingsReportAsCsv
-  writeOutput opts . render opts $ postingsReport rspec j
+           | fmt=="json" = toJsonText
+           | otherwise   = error' $ unsupportedOutputFormatError fmt  -- PARTIAL:
 
 postingsReportAsCsv :: PostingsReport -> CSV
-postingsReportAsCsv (_,is) =
+postingsReportAsCsv is =
   ["txnidx","date","code","description","account","amount","total"]
   :
   map postingsReportItemAsCsvRecord is
@@ -89,13 +91,17 @@ postingsReportItemAsCsvRecord (_, _, _, p, b) = [idx,date,code,desc,acct,amt,bal
     bal = showMixedAmountOneLineWithoutPrice False b
 
 -- | Render a register report as plain text suitable for console output.
-postingsReportAsText :: CliOpts -> PostingsReport -> String
+postingsReportAsText :: CliOpts -> PostingsReport -> TL.Text
-postingsReportAsText opts (_,items) = unlines $ map (postingsReportItemAsText opts amtwidth balwidth) items
+postingsReportAsText opts items =
+    TB.toLazyText . unlinesB $
+      map (postingsReportItemAsText opts amtwidth balwidth) items
   where
     amtwidth = maximumStrict $ map (snd . showMixed showAmount (Just 12) Nothing False . itemamt) items
     balwidth = maximumStrict $ map (snd . showMixed showAmount (Just 12) Nothing False . itembal) items
     itemamt (_,_,_,Posting{pamount=a},_) = a
     itembal (_,_,_,_,a) = a
+    unlinesB [] = mempty
+    unlinesB xs = mconcat (intersperse (TB.fromText "\n") xs) <> TB.fromText "\n"
 
 -- | Render one register report line item as plain text. Layout is like so:
 -- @
@@ -119,36 +125,30 @@ postingsReportAsText opts (_,items) = unlines $ map (postingsReportItemAsText op
 -- has multiple commodities. Does not yet support formatting control
 -- like balance reports.
 --
-postingsReportItemAsText :: CliOpts -> Int -> Int -> PostingsReportItem -> String
+postingsReportItemAsText :: CliOpts -> Int -> Int -> PostingsReportItem -> TB.Builder
 postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, menddate, mdesc, p, b) =
   -- use elide*Width to be wide-char-aware
   -- trace (show (totalwidth, datewidth, descwidth, acctwidth, amtwidth, balwidth)) $
-  intercalate "\n" $
+  foldMap mconcat . intersperse ([TB.fromText "\n"]) . map (map TB.fromText) $
-    concat [fitString (Just datewidth) (Just datewidth) True True date
+    [ fitText (Just datewidth) (Just datewidth) True True date
-           ," "
+    , " "
-           ,fitString (Just descwidth) (Just descwidth) True True desc
+    , fitText (Just descwidth) (Just descwidth) True True desc
-           ,"  "
+    , "  "
-           ,fitString (Just acctwidth) (Just acctwidth) True True acct
+    , fitText (Just acctwidth) (Just acctwidth) True True acct
-           ,"  "
+    , "  "
-           ,amtfirstline
+    , amtfirstline
-           ,"  "
+    , "  "
-           ,balfirstline
+    , balfirstline
-           ]
+    ]
     :
-    [concat [spacer
+    [ [ spacer, a, "  ", b ] | (a,b) <- zip amtrest balrest ]
-            ,a
-            ,"  "
-            ,b
-            ]
-     | (a,b) <- zip amtrest balrest
-     ]
     where
       -- calculate widths
       (totalwidth,mdescwidth) = registerWidthsFromOpts opts
       (datewidth, date) = case (mdate,menddate) of
-                            (Just _, Just _)   -> (21, showDateSpan (DateSpan mdate menddate))
+                            (Just _, Just _)   -> (21, T.pack $ showDateSpan (DateSpan mdate menddate))
                             (Nothing, Just _)  -> (21, "")
-                            (Just d, Nothing)  -> (10, showDate d)
+                            (Just d, Nothing)  -> (10, T.pack $ showDate d)
                             _                  -> (10, "")
       (amtwidth, balwidth)
         | shortfall <= 0 = (preferredamtwidth, preferredbalwidth)
@@ -171,24 +171,25 @@ postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, mendda
 
       -- gather content
       desc = fromMaybe "" mdesc
-      acct = parenthesise $ T.unpack $ elideAccountName awidth $ paccount p
+      acct = parenthesise . elideAccountName awidth $ paccount p
          where
           (parenthesise, awidth) =
             case ptype p of
-              BalancedVirtualPosting -> (\s -> "["++s++"]", acctwidth-2)
+              BalancedVirtualPosting -> (\s -> wrap "[" "]" s, acctwidth-2)
-              VirtualPosting         -> (\s -> "("++s++")", acctwidth-2)
+              VirtualPosting         -> (\s -> wrap "(" ")" s, acctwidth-2)
               _                      -> (id,acctwidth)
-      amt = fst $ showMixed showAmountWithoutPrice (Just amtwidth) (Just amtwidth) (color_ . rsOpts $ reportspec_ opts) $ pamount p
+          wrap a b x = a <> x <> b
-      bal = fst $ showMixed showAmountWithoutPrice (Just balwidth) (Just balwidth) (color_ . rsOpts $ reportspec_ opts) b
+      amt = T.pack . fst $ showMixed showAmountWithoutPrice (Just amtwidth) (Just amtwidth) (color_ . rsOpts $ reportspec_ opts) $ pamount p
+      bal = T.pack . fst $ showMixed showAmountWithoutPrice (Just balwidth) (Just balwidth) (color_ . rsOpts $ reportspec_ opts) b
       -- alternate behaviour, show null amounts as 0 instead of blank
       -- amt = if null amt' then "0" else amt'
       -- bal = if null bal' then "0" else bal'
-      (amtlines, ballines) = (lines amt, lines bal)
+      (amtlines, ballines) = (T.lines amt, T.lines bal)
       (amtlen, ballen) = (length amtlines, length ballines)
       numlines = max 1 (max amtlen ballen)
-      (amtfirstline:amtrest) = take numlines $ amtlines ++ repeat (replicate amtwidth ' ') -- posting amount is top-aligned
+      (amtfirstline:amtrest) = take numlines $ amtlines ++ repeat (T.replicate amtwidth " ") -- posting amount is top-aligned
-      (balfirstline:balrest) = take numlines $ replicate (numlines - ballen) (replicate balwidth ' ') ++ ballines -- balance amount is bottom-aligned
+      (balfirstline:balrest) = take numlines $ replicate (numlines - ballen) (T.replicate balwidth " ") ++ ballines -- balance amount is bottom-aligned
-      spacer = replicate (totalwidth - (amtwidth + 2 + balwidth)) ' '
+      spacer = T.replicate (totalwidth - (amtwidth + 2 + balwidth)) " "
 
 -- tests
 
@@ -198,7 +199,7 @@ tests_Register = tests "Register" [
     test "unicode in register layout" $ do
       j <- readJournal' "2009/01/01 * медвежья шкура\n  расходы:покупки  100\n  актив:наличные\n"
       let rspec = defreportspec
-      (postingsReportAsText defcliopts $ postingsReport rspec j)
+      (TL.unpack . postingsReportAsText defcliopts $ postingsReport rspec j)
         @?=
         unlines
         ["2009-01-01 медвежья шкура       расходы:покупки                100           100"

hledger/Hledger/Cli/Commands/Registermatch.hs

@@ -10,6 +10,7 @@ where
 import Data.Char (toUpper)
 import Data.List
 import qualified Data.Text as T
+import qualified Data.Text.Lazy.IO as TL
 import Hledger
 import Hledger.Cli.CliOptions
 import Hledger.Cli.Commands.Register
@@ -25,14 +26,13 @@ registermatch :: CliOpts -> Journal -> IO ()
 registermatch opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j =
   case listofstringopt "args" rawopts of
     [desc] -> do
-        let (_,pris) = postingsReport rspec j
+        let ps = [p | (_,_,_,p,_) <- postingsReport rspec j]
-            ps = [p | (_,_,_,p,_) <- pris]
         case similarPosting ps desc of
           Nothing -> putStrLn "no matches found."
-          Just p  -> putStr $ postingsReportAsText opts ("",[pri])
+          Just p  -> TL.putStr $ postingsReportAsText opts [pri]
                      where pri = (Just (postingDate p)
                                  ,Nothing
-                                 ,Just $ T.unpack (maybe "" tdescription $ ptransaction p)
+                                 ,tdescription <$> ptransaction p
                                  ,p
                                  ,0)
     _ -> putStrLn "please provide one description argument."

hledger/Hledger/Cli/Utils.hs

@@ -13,6 +13,7 @@ module Hledger.Cli.Utils
      unsupportedOutputFormatError,
      withJournalDo,
      writeOutput,
+     writeOutputLazyText,
      journalTransform,
      journalAddForecast,
      journalReload,
@@ -34,6 +35,8 @@ import Data.List
 import Data.Maybe
 import qualified Data.Text as T
 import qualified Data.Text.IO as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.IO as TL
 import Data.Time (UTCTime, Day, addDays)
 import Safe (readMay)
 import System.Console.CmdArgs
@@ -159,6 +162,14 @@ writeOutput opts s = do
   f <- outputFileFromOpts opts
   (if f == "-" then putStr else writeFile f) s
 
+-- | Write some output to stdout or to a file selected by --output-file.
+-- If the file exists it will be overwritten. This function operates on Lazy
+-- Text values.
+writeOutputLazyText :: CliOpts -> TL.Text -> IO ()
+writeOutputLazyText opts s = do
+  f <- outputFileFromOpts opts
+  (if f == "-" then TL.putStr else TL.writeFile f) s
+
 -- -- | Get a journal from the given string and options, or throw an error.
 -- readJournal :: CliOpts -> String -> IO Journal
 -- readJournal opts s = readJournal def Nothing s >>= either error' return