WIP: Adopt pretty rendering

hledger-lib/Hledger/Data/Amount.hs

@@ -71,6 +71,7 @@ module Hledger.Data.Amount (
   showAmount,
   cshowAmount,
   showAmountWithZeroCommodity,
+  prettyAmountWithZeroCommodity,
   showAmountDebug,
   showAmountWithoutPrice,
   maxprecision,
@@ -85,6 +86,8 @@ module Hledger.Data.Amount (
   setAmountDecimalPoint,
   withDecimalPoint,
   canonicaliseAmount,
+  simplifyZeroAmount,
+  amountStripPrice,
   -- * MixedAmount
   nullmixedamt,
   missingmixedamt,
@@ -94,6 +97,7 @@ module Hledger.Data.Amount (
   filterMixedAmountByCommodity,
   normaliseMixedAmountSquashPricesForDisplay,
   normaliseMixedAmount,
+  mixedAmountStripPrices,
   -- ** arithmetic
   costOfMixedAmount,
   mixedAmountToCost,
@@ -131,17 +135,18 @@ module Hledger.Data.Amount (
 import Data.Char (isDigit)
 import Data.Decimal (roundTo, decimalPlaces, normalizeDecimal)
 import Data.Function (on)
+import Data.String
 import Data.List
 import qualified Data.Map as M
 import Data.Map (findWithDefault)
 import Data.Maybe
 import qualified Data.Text as T
-import Safe (maximumDef)
 import Text.Printf
 
 import Hledger.Data.Types
 import Hledger.Data.Commodity
-import Hledger.Utils
+import Hledger.Utils hiding (Red)
+import Hledger.Utils.Pretty
 
 
 deriving instance Show MarketPrice
@@ -166,6 +171,12 @@ instance Num Amount where
     (-)                          = similarAmountsOp (-)
     (*)                          = similarAmountsOp (*)
 
+instance Pretty Amount where
+    pretty a | a == missingamt = mempty
+    pretty a =
+        (if isNegativeAmount a then annNegative else id) $
+        fromString $ showAmount a
+
 -- | The empty simple amount.
 amount, nullamt :: Amount
 amount = Amount{acommodity="", aquantity=0, aprice=Nothing, astyle=amountstyle, aismultiplier=False}
@@ -266,17 +277,12 @@ digits = "123456789" :: String
 -- | Does this amount appear to be zero when displayed with its given precision ?
 isZeroAmount :: Amount -> Bool
 isZeroAmount --  a==missingamt = False
-  = not . any (`elem` digits) . showAmountWithoutPriceOrCommodity
+  = not . any (`elem` digits) . showamountquantity
 
 -- | Is this amount "really" zero, regardless of the display precision ?
 isReallyZeroAmount :: Amount -> Bool
 isReallyZeroAmount Amount{aquantity=q} = q == 0
 
--- | Get the string representation of an amount, based on its commodity's
--- display settings except using the specified precision.
-showAmountWithPrecision :: Int -> Amount -> String
-showAmountWithPrecision p = showAmount . setAmountPrecision p
-
 -- | Set an amount's display precision.
 setAmountPrecision :: Int -> Amount -> Amount
 setAmountPrecision p a@Amount{astyle=s} = a{astyle=s{asprecision=p}}
@@ -318,7 +324,7 @@ showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice
 
 -- | Get the string representation of an amount, without any \@ price.
 showAmountWithoutPrice :: Amount -> String
-showAmountWithoutPrice a = showAmount a{aprice=Nothing}
+showAmountWithoutPrice = showPretty . amountStripPrice
 
 -- | Set an amount's internal precision, ie rounds the Decimal representing
 -- the amount's quantity to some number of decimal places.
@@ -345,14 +351,6 @@ setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalpoint=mc} }
 withDecimalPoint :: Amount -> Maybe Char -> Amount
 withDecimalPoint = flip setAmountDecimalPoint
 
--- | Colour version.
-cshowAmountWithoutPrice :: Amount -> String
-cshowAmountWithoutPrice a = cshowAmount a{aprice=Nothing}
-
--- | Get the string representation of an amount, without any price or commodity symbol.
-showAmountWithoutPriceOrCommodity :: Amount -> String
-showAmountWithoutPriceOrCommodity a = showAmount a{acommodity="", aprice=Nothing}
-
 showAmountPrice :: Maybe AmountPrice -> String
 showAmountPrice Nothing                = ""
 showAmountPrice (Just (UnitPrice pa))  = " @ "  ++ showAmount pa
@@ -383,33 +381,53 @@ styleAmountExceptPrecision styles a@Amount{astyle=AmountStyle{asprecision=origp}
 -- zero are converted to just \"0\". The special "missing" amount is
 -- displayed as the empty string.
 showAmount :: Amount -> String
-showAmount = showAmountHelper False
+showAmount = showAmountWithZeroCommodity . simplifyZeroAmount
 
 -- | Colour version. For a negative amount, adds ANSI codes to change the colour,
 -- currently to hard-coded red.
 cshowAmount :: Amount -> String
-cshowAmount a =
-  (if isNegativeAmount a then color Dull Red else id) $
-  showAmountHelper False a
+cshowAmount = cshowPretty
+
+-- | Strips price information from amount
+amountStripPrice :: Amount -> Amount
+amountStripPrice a = a {aprice=Nothing}
+
+prettyAmountWithZeroCommodity :: Amount -> Doc AnsiStyle
+prettyAmountWithZeroCommodity a =
+    (if isNegativeAmount a then annNegative else id) $
+    fromString $ showAmountWithZeroCommodity a
 
-showAmountHelper :: Bool -> Amount -> String
-showAmountHelper _ Amount{acommodity="AUTO"} = ""
-showAmountHelper showzerocommodity a@Amount{acommodity=c, aprice=mp, astyle=AmountStyle{..}} =
+-- | Strip commodity and precision from zero amount
+-- Have no effect on non-zero values
+-- >>> plain . pretty . simplifyZeroAmount $ hrs 1
+-- 1.00h
+--
+-- But will strip uselss information from zero
+-- >>> plain . pretty . simplifyZeroAmount $ usd 0.00 @@ eur 12
+-- 0 @@ €12.00
+--
+-- Unless it is 'missingamt'
+-- >>> plain . pretty . simplifyZeroAmount $ missingamt
+-- <BLANKLINE>
+simplifyZeroAmount :: Amount -> Amount
+simplifyZeroAmount a@Amount{astyle=astyle0}
+    | a == missingamt = a
+    | isZeroAmount a = a{acommodity="", aquantity=0, astyle=astyle0{asprecision=0}}
+    | otherwise = a
+
+-- | Like showAmount, but show a zero amount's commodity if it has one.
+showAmountWithZeroCommodity :: Amount -> String
+showAmountWithZeroCommodity a | a == missingamt = ""
+showAmountWithZeroCommodity a@Amount{acommodity=c, aprice=mp, astyle=AmountStyle{..}} =
     case ascommodityside of
-      L -> printf "%s%s%s%s" (T.unpack c') space quantity' price
-      R -> printf "%s%s%s%s" quantity' space (T.unpack c') price
+      L -> printf "%s%s%s%s" (T.unpack c') space quantity price
+      R -> printf "%s%s%s%s" quantity space (T.unpack c') price
     where
       quantity = showamountquantity a
-      displayingzero = not (any (`elem` digits) quantity)
-      (quantity',c') | displayingzero && not showzerocommodity = ("0","")
-                     | otherwise = (quantity, quoteCommoditySymbolIfNeeded c)
+      c' = quoteCommoditySymbolIfNeeded c
       space = if not (T.null c') && ascommodityspaced then " " else "" :: String
       price = showAmountPrice mp
 
--- | Like showAmount, but show a zero amount's commodity if it has one.
-showAmountWithZeroCommodity :: Amount -> String
-showAmountWithZeroCommodity = showAmountHelper True
-
 -- | Get the string representation of the number part of of an amount,
 -- using the display settings from its commodity.
 showamountquantity :: Amount -> String
@@ -476,6 +494,9 @@ instance Num MixedAmount where
     abs    = error' "error, mixed amounts do not support abs"
     signum = error' "error, mixed amounts do not support signum"
 
+instance Pretty MixedAmount where
+    pretty = prettyMixedAmountHelper pretty
+
 -- | The empty mixed amount.
 nullmixedamt :: MixedAmount
 nullmixedamt = Mixed []
@@ -635,26 +656,37 @@ styleMixedAmount styles (Mixed as) = Mixed $ map (styleAmount styles) as
 -- | Get the string representation of a mixed amount, after
 -- normalising it to one amount per commodity. Assumes amounts have
 -- no or similar prices, otherwise this can show misleading prices.
+-- >>> showMixedAmount $ mixed [usd 0]
+-- "0"
+-- >>> showMixedAmount $ mixed [usd 1, usd (-1), hrs 5]
+-- "5.00h"
 showMixedAmount :: MixedAmount -> String
-showMixedAmount = showMixedAmountHelper False False
+showMixedAmount = showPretty
 
 -- | Like showMixedAmount, but zero amounts are shown with their
 -- commodity if they have one.
+-- >>> showMixedAmountWithZeroCommodity $ mixed [usd 0]
+-- "$0.00"
 showMixedAmountWithZeroCommodity :: MixedAmount -> String
-showMixedAmountWithZeroCommodity = showMixedAmountHelper True False
+showMixedAmountWithZeroCommodity = showWide . plain . prettyMixedAmountWithZeroCommodity
 
 -- | Get the one-line string representation of a mixed amount.
 showMixedAmountOneLine :: MixedAmount -> String
-showMixedAmountOneLine = showMixedAmountHelper False True
-
-showMixedAmountHelper :: Bool -> Bool -> MixedAmount -> String
-showMixedAmountHelper showzerocommodity useoneline m =
-  join $ map showamt $ amounts $ normaliseMixedAmountSquashPricesForDisplay m
-  where
-    join | useoneline = intercalate ", "
-         | otherwise  = vConcatRightAligned
-    showamt | showzerocommodity = showAmountWithZeroCommodity
-            | otherwise         = showAmount
+showMixedAmountOneLine = showWide . plain . hgroup . pretty
+
+prettyMixedAmountWithZeroCommodity :: MixedAmount -> Doc AnsiStyle
+prettyMixedAmountWithZeroCommodity = prettyMixedAmountHelper prettyAmountWithZeroCommodity
+
+-- | Helper for rendering 'MixedAmount' with vertical/horizontal layout, but with custom prettify function.
+-- >>> prettyMixedAmountHelper pretty $ Mixed [usd 1, eur 10]
+--  $1.00
+-- €10.00
+prettyMixedAmountHelper :: (Amount -> Doc a) -> MixedAmount -> Doc a
+prettyMixedAmountHelper prettyAmount m = verical `flatAlt` flat where
+    Mixed as = normaliseMixedAmountSquashPricesForDisplay m
+    docs = map prettyAmount as
+    verical = vcatRight docs
+    flat = encloseSep mempty mempty ", " docs
 
 -- | Compact labelled trace of a mixed amount, for debugging.
 ltraceamount :: String -> MixedAmount -> MixedAmount
@@ -668,8 +700,7 @@ setMixedAmountPrecision p (Mixed as) = Mixed $ map (setAmountPrecision p) as
 -- component amounts with the specified precision, ignoring their
 -- commoditys' display precision settings.
 showMixedAmountWithPrecision :: Int -> MixedAmount -> String
-showMixedAmountWithPrecision p m =
-    vConcatRightAligned $ map (showAmountWithPrecision p) $ amounts $ normaliseMixedAmountSquashPricesForDisplay m
+showMixedAmountWithPrecision p = showWide . plain . pretty . setMixedAmountPrecision p
 
 -- | Get an unambiguous string representation of a mixed amount for debugging.
 showMixedAmountDebug :: MixedAmount -> String
@@ -680,43 +711,40 @@ showMixedAmountDebug m | m == missingmixedamt = "(missing)"
 -- TODO these and related fns are comically complicated:
 
 -- | Get the string representation of a mixed amount, without showing any transaction prices.
+--
+-- For multi-currency output it alignes everything to the right:
+-- >>> putStrLn . showMixedAmountWithoutPrice $ Mixed [usd 1, eur 10]
+--  $1.00
+-- €10.00
+--
+-- Before rendering 'MixedAmount' implicitly normalized for displaying:
+-- >>> putStrLn . showMixedAmountWithoutPrice $ Mixed [usd 1, usd (-1)]
+-- 0
 showMixedAmountWithoutPrice :: MixedAmount -> String
-showMixedAmountWithoutPrice m = intercalate "\n" $ map showamt as
-  where
-    Mixed as = normaliseMixedAmountSquashPricesForDisplay $ mixedAmountStripPrices m
-    showamt = printf (printf "%%%ds" width) . showAmountWithoutPrice
-      where
-        width = maximumDef 0 $ map (length . showAmount) as
+showMixedAmountWithoutPrice = showPretty . mixedAmountStripPrices
 
 -- | Colour version of showMixedAmountWithoutPrice. Any individual Amount
 -- which is negative is wrapped in ANSI codes to make it display in red.
 cshowMixedAmountWithoutPrice :: MixedAmount -> String
-cshowMixedAmountWithoutPrice m = intercalate "\n" $ map showamt as
-  where
-    Mixed as = normaliseMixedAmountSquashPricesForDisplay $ mixedAmountStripPrices m
-    showamt a =
-      (if isNegativeAmount a then color Dull Red else id) $
-      printf (printf "%%%ds" width) $ showAmountWithoutPrice a
-      where
-        width = maximumDef 0 $ map (length . showAmount) as
+cshowMixedAmountWithoutPrice = cshowPretty . mixedAmountStripPrices
 
+-- | Strip price from 'MixedAmount'
 mixedAmountStripPrices :: MixedAmount -> MixedAmount
-mixedAmountStripPrices (Mixed as) = Mixed $ map (\a -> a{aprice=Nothing}) as
+mixedAmountStripPrices (Mixed as) = Mixed $ map amountStripPrice as
 
 -- | Get the one-line string representation of a mixed amount, but without
 -- any \@ prices.
+--
+-- >>> showMixedAmountOneLineWithoutPrice $ Mixed [usd 1 @@ eur 3, hrs 10]
+-- "$1.00, 10.00h"
+--
+-- Note that this implementation doesn't guarantee flattened look
 showMixedAmountOneLineWithoutPrice :: MixedAmount -> String
-showMixedAmountOneLineWithoutPrice m = intercalate ", " $ map showAmountWithoutPrice as
-    where
-      (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m
-      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=Nothing}
+showMixedAmountOneLineWithoutPrice = showMixedAmountOneLine . mixedAmountStripPrices
 
 -- | Colour version.
 cshowMixedAmountOneLineWithoutPrice :: MixedAmount -> String
-cshowMixedAmountOneLineWithoutPrice m = intercalate ", " $ map cshowAmountWithoutPrice as
-    where
-      (Mixed as) = normaliseMixedAmountSquashPricesForDisplay $ stripPrices m
-      stripPrices (Mixed as) = Mixed $ map stripprice as where stripprice a = a{aprice=Nothing}
+cshowMixedAmountOneLineWithoutPrice = showWide . hgroup . pretty . mixedAmountStripPrices
 
 -- | Canonicalise a mixed amount's display styles using the provided commodity style map.
 canonicaliseMixedAmount :: M.Map CommoditySymbol AmountStyle -> MixedAmount -> MixedAmount
@@ -728,6 +756,8 @@ canonicaliseMixedAmount styles (Mixed as) = Mixed $ map (canonicaliseAmount styl
 mixedAmountTotalPriceToUnitPrice :: MixedAmount -> MixedAmount
 mixedAmountTotalPriceToUnitPrice (Mixed as) = Mixed $ map amountTotalPriceToUnitPrice as
 
+annNegative = annotate (colorDull Red)
+
 
 -------------------------------------------------------------------------------
 -- tests

hledger-lib/Hledger/Utils/Pretty.hs

@@ -0,0 +1,69 @@
+module Hledger.Utils.Pretty
+( module Hledger.Utils.Pretty
+  -- * Re-export some stuff to avoid ugly imports
+, Doc
+, flatAlt
+, encloseSep
+, annotate
+, AnsiStyle
+, Color(..)
+, colorDull
+, color
+)  where
+
+import Data.String
+import Safe (maximumDef)
+import qualified Data.Text as T
+import Data.Text.Prettyprint.Doc hiding (Pretty(..))
+import Data.Text.Prettyprint.Doc.Render.String
+import Data.Text.Prettyprint.Doc.Render.Terminal
+
+class Pretty a where
+    pretty :: a -> Doc AnsiStyle
+
+-- | Align multiple documents joined vertically to the right
+--
+-- You may want to override flat representation.
+--
+-- >>> vcatRight ["abc", "defg", "hi"]
+--  abc
+-- defg
+--   hi
+vcatRight :: [Doc a] -> Doc a
+vcatRight docs = vcat [indent (totalWidth - width) doc | (width, doc) <- measured]
+  where
+    measured = [(docWidth doc, doc) | doc <- docs]
+    totalWidth = maximumDef 0 $ map fst measured
+
+-- | Try to re-group 'Doc' horizontally.
+hgroup :: Doc a -> Doc a
+hgroup = group
+
+-- | Simple estimation of 'Doc' width given that there is no width limit
+--
+-- >>> docWidth "abc\ndefg\nhi"
+-- 4
+--
+-- Note that current implementation is really dummy...
+docWidth :: Doc a -> Int
+docWidth = maximumDef 0 . map length . lines . renderString . layoutWide where
+
+layoutWide :: Doc a -> SimpleDocStream a
+layoutWide = layoutPretty defaultLayoutOptions{layoutPageWidth = Unbounded}
+
+-- Some compatibility between various pretty-printers
+
+plain :: Doc a -> Doc b
+plain = unAnnotate
+
+text :: String -> Doc ann
+text = fromString
+
+-- Temporary utility for show*/cshow* functions.
+-- TODO: drop once fully migrated to 'Doc'
+showPretty, cshowPretty :: Pretty a => a -> String
+showPretty = showWide . plain . pretty
+cshowPretty = showWide . pretty
+
+showWide :: Doc AnsiStyle -> String
+showWide = T.unpack . renderStrict . layoutWide