mirror of
https://github.com/simonmichael/hledger.git
synced 2024-09-20 02:37:12 +03:00
Merge Xitian9/reporttext (#1427)
Many parts of the hledger-lib and hledger APIs have become more Text-ified, expecting or returning Text instead of String. Some functions now use WideBuilder (a text "builder" which keeps track of width), to concatenate text more efficiently. There are some helpers for converting to and from WideBuilder (wbUnpack, wbToText..) showAmountB/showMixedAmountB are new amount-displaying functions taking an AmountDisplayOpts. These will probably replace the old show(Mixed)Amount* functions. This reduces hledger's time and resident memory requirements by roughly 10%.
This commit is contained in:
commit
c96734474c
@ -5,7 +5,8 @@
|
||||
|
||||
{-| Construct two balance reports for two different time periods and use one of the as "budget" for
|
||||
the other, thus comparing them
|
||||
-}
|
||||
-}
|
||||
import Data.Text.Lazy.IO as TL
|
||||
import System.Environment (getArgs)
|
||||
import Hledger.Cli
|
||||
|
||||
@ -34,7 +35,7 @@ main = do
|
||||
(_,_,report1) <- mbReport report1args
|
||||
(ropts2,j,report2) <- mbReport report2args
|
||||
let pastAsBudget = combineBudgetAndActual ropts2 j report1{prDates=prDates report2} report2
|
||||
putStrLn $ budgetReportAsText ropts2 pastAsBudget
|
||||
TL.putStrLn $ budgetReportAsText ropts2 pastAsBudget
|
||||
where
|
||||
mbReport args = do
|
||||
opts@CliOpts{reportspec_=rspec} <- getHledgerCliOpts' cmdmode args
|
||||
|
@ -70,7 +70,8 @@ hledger-check-fancyassertions "(assets:overdraft < £2000) ==> (*assets:checkin
|
||||
my checking account (including subaccounts)."
|
||||
-}
|
||||
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
|
||||
module Main where
|
||||
|
||||
@ -86,7 +87,9 @@ import Data.List.NonEmpty (NonEmpty(..), nonEmpty, toList)
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
import Data.Time.Calendar (toGregorian)
|
||||
import Data.Time.Calendar.OrdinalDate (mondayStartWeek, sundayStartWeek, toOrdinalDate)
|
||||
import Data.Text (isPrefixOf, pack, unpack)
|
||||
import Data.Text (Text, isPrefixOf, pack, unpack)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Hledger.Data as H
|
||||
import qualified Hledger.Query as H
|
||||
import qualified Hledger.Read as H
|
||||
@ -124,17 +127,17 @@ main = do
|
||||
-- | Check assertions against a collection of grouped postings:
|
||||
-- assertions must hold when all postings in the group have been
|
||||
-- applied. Print out errors as they are found.
|
||||
checkAssertions :: [(H.AccountName, H.MixedAmount)] -> [(String, Predicate)] -> [NonEmpty H.Posting] -> IO Bool
|
||||
checkAssertions :: [(H.AccountName, H.MixedAmount)] -> [(Text, Predicate)] -> [NonEmpty H.Posting] -> IO Bool
|
||||
checkAssertions balances0 asserts0 postingss
|
||||
| null failed = pure True
|
||||
| otherwise = putStrLn (intercalate "\n\n" failed) >> pure False
|
||||
| otherwise = T.putStrLn (T.intercalate "\n\n" failed) >> pure False
|
||||
where
|
||||
(_, _, failed) = foldl' applyAndCheck (balances0, asserts0, []) postingss
|
||||
|
||||
-- Apply a collection of postings and check the assertions.
|
||||
applyAndCheck :: ([(H.AccountName, H.MixedAmount)], [(String, Predicate)], [String])
|
||||
applyAndCheck :: ([(H.AccountName, H.MixedAmount)], [(Text, Predicate)], [Text])
|
||||
-> NonEmpty H.Posting
|
||||
-> ([(H.AccountName, H.MixedAmount)], [(String, Predicate)], [String])
|
||||
-> ([(H.AccountName, H.MixedAmount)], [(Text, Predicate)], [Text])
|
||||
applyAndCheck (starting, asserts, errs) ps =
|
||||
let ps' = toList ps
|
||||
closing = starting `addAccounts` closingBalances' ps'
|
||||
@ -145,25 +148,25 @@ checkAssertions balances0 asserts0 postingss
|
||||
|
||||
-- Check an assertion against a collection of account balances,
|
||||
-- and return an error on failure.
|
||||
check :: H.Posting -> [(H.AccountName, H.MixedAmount)] -> (String, Predicate) -> Maybe String
|
||||
check :: H.Posting -> [(H.AccountName, H.MixedAmount)] -> (Text, Predicate) -> Maybe Text
|
||||
check lastp balances (pstr, p)
|
||||
| checkAssertion balances p = Nothing
|
||||
| otherwise = Just . unlines $
|
||||
| otherwise = Just . T.unlines $
|
||||
let after = case H.ptransaction lastp of
|
||||
Just t ->
|
||||
"after transaction:\n" ++ H.showTransaction t ++
|
||||
"(after posting: " ++ init (H.showPosting lastp) ++ ")\n\n"
|
||||
"after transaction:\n" <> H.showTransaction t <>
|
||||
"(after posting: " <> T.pack (init $ H.showPosting lastp) <> ")\n\n"
|
||||
Nothing ->
|
||||
"after posting:\n" ++ H.showPosting lastp
|
||||
"after posting:\n" <> T.pack (H.showPosting lastp)
|
||||
|
||||
-- Restrict to accounts mentioned in the predicate, and pretty-print balances
|
||||
balances' = map (first unpack) $ filter (flip inAssertion p . fst) balances
|
||||
maxalen = maximum $ map (length . fst) balances'
|
||||
accounts = [ a <> padding <> show m
|
||||
balances' = filter (flip inAssertion p . fst) balances
|
||||
maxalen = maximum $ map (T.length . fst) balances'
|
||||
accounts = [ a <> padding <> T.pack (show m)
|
||||
| (a,m) <- balances'
|
||||
, let padding = replicate (2 + maxalen - length a) ' '
|
||||
, let padding = T.replicate (2 + maxalen - T.length a) " "
|
||||
]
|
||||
in [ "assertion '" ++ pstr ++ "' violated", after ++ "relevant balances:"] ++ map (" "++) accounts
|
||||
in [ "assertion '" <> pstr <> "' violated", after <> "relevant balances:"] ++ map (" "<>) accounts
|
||||
|
||||
-- | Check an assertion holds for a collection of account balances.
|
||||
checkAssertion :: [(H.AccountName, H.MixedAmount)] -> Predicate -> Bool
|
||||
@ -322,17 +325,17 @@ data Opts = Opts
|
||||
-- ^ Include only non-virtual postings.
|
||||
, sunday :: Bool
|
||||
-- ^ Week starts on Sunday.
|
||||
, assertionsDaily :: [(String, Predicate)]
|
||||
, assertionsDaily :: [(Text, Predicate)]
|
||||
-- ^ Account assertions that must hold at the end of each day.
|
||||
, assertionsWeekly :: [(String, Predicate)]
|
||||
, assertionsWeekly :: [(Text, Predicate)]
|
||||
-- ^ Account assertions that must hold at the end of each week.
|
||||
, assertionsMonthly :: [(String, Predicate)]
|
||||
, assertionsMonthly :: [(Text, Predicate)]
|
||||
-- ^ Account assertions that must hold at the end of each month.
|
||||
, assertionsQuarterly :: [(String, Predicate)]
|
||||
, assertionsQuarterly :: [(Text, Predicate)]
|
||||
-- ^ Account assertions that must hold at the end of each quarter.
|
||||
, assertionsYearly :: [(String, Predicate)]
|
||||
, assertionsYearly :: [(Text, Predicate)]
|
||||
-- ^ Account assertions that must hold at the end of each year.
|
||||
, assertionsAlways :: [(String, Predicate)]
|
||||
, assertionsAlways :: [(Text, Predicate)]
|
||||
-- ^ Account assertions that must hold after each txn.
|
||||
}
|
||||
deriving (Show)
|
||||
@ -388,13 +391,13 @@ args = info (helper <*> parser) $ mconcat
|
||||
|
||||
-- Turn a Parsec parser into a ReadM parser that also returns the
|
||||
-- input.
|
||||
readParsec :: H.JournalParser ReadM a -> ReadM (String, a)
|
||||
readParsec :: H.JournalParser ReadM a -> ReadM (Text, a)
|
||||
readParsec p = do
|
||||
s <- str
|
||||
parsed <- P.runParserT (runStateT p H.nulljournal) "" (pack s)
|
||||
parsed <- P.runParserT (runStateT p H.nulljournal) "" s
|
||||
case parsed of
|
||||
Right (a, _) -> pure (s, a)
|
||||
Left err -> fail ("failed to parse input '" ++ s ++ "': " ++ show err)
|
||||
Left err -> fail ("failed to parse input '" ++ unpack s ++ "': " ++ show err)
|
||||
|
||||
readParsec' :: H.SimpleTextParser a -> ReadM (String, a)
|
||||
readParsec' p = do
|
||||
|
@ -9,6 +9,7 @@ import System.Environment (getArgs)
|
||||
import Hledger.Cli
|
||||
import qualified Data.Map as M
|
||||
import Data.Map.Merge.Strict
|
||||
import qualified Data.Text.Lazy.IO as TL
|
||||
|
||||
appendReports :: MultiBalanceReport -> MultiBalanceReport -> MultiBalanceReport
|
||||
appendReports r1 r2 =
|
||||
@ -62,7 +63,7 @@ main = do
|
||||
(_,report1) <- mbReport report1args
|
||||
(rspec2,report2) <- mbReport report2args
|
||||
let merged = appendReports report1 report2
|
||||
putStrLn $ multiBalanceReportAsText (rsOpts rspec2) merged
|
||||
TL.putStrLn $ multiBalanceReportAsText (rsOpts rspec2) merged
|
||||
where
|
||||
mbReport args = do
|
||||
opts@CliOpts{reportspec_=rspec} <- getHledgerCliOpts' cmdmode args
|
||||
|
@ -69,7 +69,7 @@ main = do
|
||||
pr = postingsReport rspec{rsQuery = And [Acct $ accountNameToAccountRegexCI acct, q]} j
|
||||
|
||||
-- dates of postings to acct (in report)
|
||||
pdates = map (postingDate . fourth5) (snd pr)
|
||||
pdates = map (postingDate . fourth5) pr
|
||||
-- the specified report end date or today's date
|
||||
enddate = fromMaybe today menddate
|
||||
dates = pdates ++ [enddate]
|
||||
|
@ -7,6 +7,7 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
import Data.String.QQ (s)
|
||||
import qualified Data.Text.IO as T
|
||||
import Hledger
|
||||
import Hledger.Cli
|
||||
|
||||
@ -33,7 +34,7 @@ main = do
|
||||
q = rsQuery rspec
|
||||
ts = filter (q `matchesTransaction`) $ jtxns $ journalSelectingAmountFromOpts (rsOpts rspec) j
|
||||
ts' = map transactionSwapDates ts
|
||||
mapM_ (putStrLn . showTransaction) ts'
|
||||
mapM_ (T.putStrLn . showTransaction) ts'
|
||||
|
||||
transactionSwapDates :: Transaction -> Transaction
|
||||
transactionSwapDates t@Transaction{tdate2=Nothing} = t
|
||||
|
@ -30,8 +30,8 @@ instance Show Account where
|
||||
aname
|
||||
(if aboring then "y" else "n" :: String)
|
||||
anumpostings
|
||||
(showMixedAmount aebalance)
|
||||
(showMixedAmount aibalance)
|
||||
(wbUnpack $ showMixedAmountB noColour aebalance)
|
||||
(wbUnpack $ showMixedAmountB noColour aibalance)
|
||||
|
||||
instance Eq Account where
|
||||
(==) a b = aname a == aname b -- quick equality test for speed
|
||||
@ -265,6 +265,6 @@ showAccountsBoringFlag = unlines . map (show . aboring) . flattenAccounts
|
||||
|
||||
showAccountDebug a = printf "%-25s %4s %4s %s"
|
||||
(aname a)
|
||||
(showMixedAmount $ aebalance a)
|
||||
(showMixedAmount $ aibalance a)
|
||||
(wbUnpack . showMixedAmountB noColour $ aebalance a)
|
||||
(wbUnpack . showMixedAmountB noColour $ aibalance a)
|
||||
(if aboring a then "b" else " " :: String)
|
||||
|
@ -208,31 +208,31 @@ clipOrEllipsifyAccountName (Just 0) = const "..."
|
||||
clipOrEllipsifyAccountName n = clipAccountName n
|
||||
|
||||
-- | Escape an AccountName for use within a regular expression.
|
||||
-- >>> putStr $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#"
|
||||
-- >>> putStr . T.unpack $ escapeName "First?!#$*?$(*) !@^#*? %)*!@#"
|
||||
-- First\?!#\$\*\?\$\(\*\) !@\^#\*\? %\)\*!@#
|
||||
escapeName :: AccountName -> String
|
||||
escapeName = T.unpack . T.concatMap escapeChar
|
||||
escapeName :: AccountName -> Text
|
||||
escapeName = T.concatMap escapeChar
|
||||
where
|
||||
escapeChar c = if c `elem` escapedChars then T.snoc "\\" c else T.singleton c
|
||||
escapedChars = ['[', '?', '+', '|', '(', ')', '*', '$', '^', '\\']
|
||||
|
||||
-- | Convert an account name to a regular expression matching it and its subaccounts.
|
||||
accountNameToAccountRegex :: AccountName -> Regexp
|
||||
accountNameToAccountRegex a = toRegex' $ '^' : escapeName a ++ "(:|$)" -- PARTIAL: Is this safe after escapeName?
|
||||
accountNameToAccountRegex a = toRegex' $ "^" <> escapeName a <> "(:|$)" -- PARTIAL: Is this safe after escapeName?
|
||||
|
||||
-- | Convert an account name to a regular expression matching it and its subaccounts,
|
||||
-- case insensitively.
|
||||
accountNameToAccountRegexCI :: AccountName -> Regexp
|
||||
accountNameToAccountRegexCI a = toRegexCI' $ '^' : escapeName a ++ "(:|$)" -- PARTIAL: Is this safe after escapeName?
|
||||
accountNameToAccountRegexCI a = toRegexCI' $ "^" <> escapeName a <> "(:|$)" -- PARTIAL: Is this safe after escapeName?
|
||||
|
||||
-- | Convert an account name to a regular expression matching it but not its subaccounts.
|
||||
accountNameToAccountOnlyRegex :: AccountName -> Regexp
|
||||
accountNameToAccountOnlyRegex a = toRegex' $ '^' : escapeName a ++ "$" -- PARTIAL: Is this safe after escapeName?
|
||||
accountNameToAccountOnlyRegex a = toRegex' $ "^" <> escapeName a <> "$" -- PARTIAL: Is this safe after escapeName?
|
||||
|
||||
-- | Convert an account name to a regular expression matching it but not its subaccounts,
|
||||
-- case insensitively.
|
||||
accountNameToAccountOnlyRegexCI :: AccountName -> Regexp
|
||||
accountNameToAccountOnlyRegexCI a = toRegexCI' $ '^' : escapeName a ++ "$" -- PARTIAL: Is this safe after escapeName?
|
||||
accountNameToAccountOnlyRegexCI a = toRegexCI' $ "^" <> escapeName a <> "$" -- PARTIAL: Is this safe after escapeName?
|
||||
|
||||
-- -- | Does this string look like an exact account-matching regular expression ?
|
||||
--isAccountRegex :: String -> Bool
|
||||
|
@ -40,7 +40,10 @@ exchange rates.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE StandaloneDeriving, RecordWildCards, OverloadedStrings #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE StandaloneDeriving #-}
|
||||
|
||||
module Hledger.Data.Amount (
|
||||
-- * Amount
|
||||
@ -66,10 +69,15 @@ module Hledger.Data.Amount (
|
||||
multiplyAmountAndPrice,
|
||||
amountTotalPriceToUnitPrice,
|
||||
-- ** rendering
|
||||
AmountDisplayOpts(..),
|
||||
noColour,
|
||||
noPrice,
|
||||
oneLine,
|
||||
amountstyle,
|
||||
styleAmount,
|
||||
styleAmountExceptPrecision,
|
||||
amountUnstyled,
|
||||
showAmountB,
|
||||
showAmount,
|
||||
cshowAmount,
|
||||
showAmountWithZeroCommodity,
|
||||
@ -117,11 +125,10 @@ module Hledger.Data.Amount (
|
||||
showMixedAmountOneLineWithoutPrice,
|
||||
showMixedAmountElided,
|
||||
showMixedAmountWithZeroCommodity,
|
||||
showMixedAmountWithPrecision,
|
||||
showMixed,
|
||||
showMixedUnnormalised,
|
||||
showMixedOneLine,
|
||||
showMixedOneLineUnnormalised,
|
||||
showMixedAmountB,
|
||||
showMixedAmountLinesB,
|
||||
wbToText,
|
||||
wbUnpack,
|
||||
setMixedAmountPrecision,
|
||||
canonicaliseMixedAmount,
|
||||
-- * misc.
|
||||
@ -130,17 +137,22 @@ module Hledger.Data.Amount (
|
||||
) where
|
||||
|
||||
import Control.Monad (foldM)
|
||||
import Data.Char (isDigit)
|
||||
import Data.Decimal (decimalPlaces, normalizeDecimal, roundTo)
|
||||
import Data.Decimal (DecimalRaw(..), decimalPlaces, normalizeDecimal, roundTo)
|
||||
import Data.Default (Default(..))
|
||||
import Data.Function (on)
|
||||
import Data.List (genericSplitAt, groupBy, intercalate, mapAccumL,
|
||||
partition, sortBy)
|
||||
import Data.List (groupBy, intercalate, intersperse, mapAccumL, partition,
|
||||
sortBy)
|
||||
import Data.List.NonEmpty (NonEmpty(..), nonEmpty)
|
||||
import qualified Data.Map as M
|
||||
import Data.Map (findWithDefault)
|
||||
import Data.Maybe (fromMaybe)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import Data.Word (Word8)
|
||||
import Safe (lastDef, lastMay)
|
||||
import Safe (headDef, lastDef, lastMay)
|
||||
import Text.Printf (printf)
|
||||
|
||||
import Hledger.Data.Types
|
||||
@ -150,13 +162,45 @@ import Hledger.Utils
|
||||
deriving instance Show MarketPrice
|
||||
|
||||
|
||||
-- | Options for the display of Amount and MixedAmount.
|
||||
data AmountDisplayOpts = AmountDisplayOpts
|
||||
{ displayPrice :: Bool -- ^ Whether to display the Price of an Amount.
|
||||
, displayZeroCommodity :: Bool -- ^ If the Amount rounds to 0, whether to display its commodity string.
|
||||
, displayColour :: Bool -- ^ Whether to colourise negative Amounts.
|
||||
, displayNormalised :: Bool -- ^ Whether to normalise MixedAmounts before displaying.
|
||||
, displayOneLine :: Bool -- ^ Whether to display on one line.
|
||||
, displayMinWidth :: Maybe Int -- ^ Minimum width to pad to
|
||||
, displayMaxWidth :: Maybe Int -- ^ Maximum width to clip to
|
||||
} deriving (Show)
|
||||
|
||||
-- | Display Amount and MixedAmount with no colour.
|
||||
instance Default AmountDisplayOpts where def = noColour
|
||||
|
||||
-- | Display Amount and MixedAmount with no colour.
|
||||
noColour :: AmountDisplayOpts
|
||||
noColour = AmountDisplayOpts { displayPrice = True
|
||||
, displayColour = False
|
||||
, displayZeroCommodity = False
|
||||
, displayNormalised = True
|
||||
, displayOneLine = False
|
||||
, displayMinWidth = Nothing
|
||||
, displayMaxWidth = Nothing
|
||||
}
|
||||
|
||||
-- | Display Amount and MixedAmount with no prices.
|
||||
noPrice :: AmountDisplayOpts
|
||||
noPrice = def{displayPrice=False}
|
||||
|
||||
-- | Display Amount and MixedAmount on one line with no prices.
|
||||
oneLine :: AmountDisplayOpts
|
||||
oneLine = def{displayOneLine=True, displayPrice=False}
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Amount styles
|
||||
|
||||
-- | Default amount style
|
||||
amountstyle = AmountStyle L False (Precision 0) (Just '.') Nothing
|
||||
|
||||
|
||||
-------------------------------------------------------------------------------
|
||||
-- Amount
|
||||
|
||||
@ -327,10 +371,10 @@ setAmountDecimalPoint mc a@Amount{ astyle=s } = a{ astyle=s{asdecimalpoint=mc} }
|
||||
withDecimalPoint :: Amount -> Maybe Char -> Amount
|
||||
withDecimalPoint = flip setAmountDecimalPoint
|
||||
|
||||
showAmountPrice :: Maybe AmountPrice -> String
|
||||
showAmountPrice Nothing = ""
|
||||
showAmountPrice (Just (UnitPrice pa)) = " @ " ++ showAmount pa
|
||||
showAmountPrice (Just (TotalPrice pa)) = " @@ " ++ showAmount pa
|
||||
showAmountPrice :: Maybe AmountPrice -> WideBuilder
|
||||
showAmountPrice Nothing = mempty
|
||||
showAmountPrice (Just (UnitPrice pa)) = WideBuilder (TB.fromString " @ ") 3 <> showAmountB noColour pa
|
||||
showAmountPrice (Just (TotalPrice pa)) = WideBuilder (TB.fromString " @@ ") 4 <> showAmountB noColour pa
|
||||
|
||||
showAmountPriceDebug :: Maybe AmountPrice -> String
|
||||
showAmountPriceDebug Nothing = ""
|
||||
@ -361,40 +405,49 @@ amountUnstyled a = a{astyle=amountstyle}
|
||||
-- commodity's display settings. String representations equivalent to
|
||||
-- zero are converted to just \"0\". The special "missing" amount is
|
||||
-- displayed as the empty string.
|
||||
--
|
||||
-- > showAmount = wbUnpack . showAmountB noColour
|
||||
showAmount :: Amount -> String
|
||||
showAmount = showAmountHelper False
|
||||
showAmount = wbUnpack . showAmountB noColour
|
||||
|
||||
-- | General function to generate a WideBuilder for an Amount, according the
|
||||
-- supplied AmountDisplayOpts. The special "missing" amount is displayed as
|
||||
-- the empty string. This is the main function to use for showing
|
||||
-- Amounts, constructing a builder; it can then be converted to a Text with
|
||||
-- wbToText, or to a String with wbUnpack.
|
||||
showAmountB :: AmountDisplayOpts -> Amount -> WideBuilder
|
||||
showAmountB _ Amount{acommodity="AUTO"} = mempty
|
||||
showAmountB opts a@Amount{astyle=style} =
|
||||
color $ case ascommodityside style of
|
||||
L -> c' <> space <> quantity' <> price
|
||||
R -> quantity' <> space <> c' <> price
|
||||
where
|
||||
quantity = showamountquantity a
|
||||
(quantity',c) | amountLooksZero a && not (displayZeroCommodity opts) = (WideBuilder (TB.singleton '0') 1,"")
|
||||
| otherwise = (quantity, quoteCommoditySymbolIfNeeded $ acommodity a)
|
||||
space = if not (T.null c) && ascommodityspaced style then WideBuilder (TB.singleton ' ') 1 else mempty
|
||||
c' = WideBuilder (TB.fromText c) (textWidth c)
|
||||
price = if displayPrice opts then showAmountPrice (aprice a) else mempty
|
||||
color = if displayColour opts && isNegativeAmount a then colorB Dull Red else id
|
||||
|
||||
-- | Colour version. For a negative amount, adds ANSI codes to change the colour,
|
||||
-- currently to hard-coded red.
|
||||
--
|
||||
-- > cshowAmount = wbUnpack . showAmountB def{displayColour=True}
|
||||
cshowAmount :: Amount -> String
|
||||
cshowAmount a = (if isNegativeAmount a then color Dull Red else id) $
|
||||
showAmountHelper False a
|
||||
cshowAmount = wbUnpack . showAmountB def{displayColour=True}
|
||||
|
||||
-- | Get the string representation of an amount, without any \@ price.
|
||||
--
|
||||
-- > showAmountWithoutPrice = wbUnpack . showAmountB noPrice
|
||||
showAmountWithoutPrice :: Amount -> String
|
||||
showAmountWithoutPrice a = showAmount a{aprice=Nothing}
|
||||
|
||||
-- | Get the string representation of an amount, based on its commodity's
|
||||
-- display settings except using the specified precision.
|
||||
showAmountWithPrecision :: AmountPrecision -> Amount -> String
|
||||
showAmountWithPrecision p = showAmount . setAmountPrecision p
|
||||
|
||||
showAmountHelper :: Bool -> Amount -> String
|
||||
showAmountHelper _ Amount{acommodity="AUTO"} = ""
|
||||
showAmountHelper showzerocommodity 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
|
||||
where
|
||||
quantity = showamountquantity a
|
||||
(quantity',c') | amountLooksZero a && not showzerocommodity = ("0","")
|
||||
| otherwise = (quantity, quoteCommoditySymbolIfNeeded c)
|
||||
space = if not (T.null c') && ascommodityspaced then " " else "" :: String
|
||||
price = showAmountPrice mp
|
||||
showAmountWithoutPrice = wbUnpack . showAmountB noPrice
|
||||
|
||||
-- | Like showAmount, but show a zero amount's commodity if it has one.
|
||||
--
|
||||
-- > showAmountWithZeroCommodity = wbUnpack . showAmountB noColour{displayZeryCommodity=True}
|
||||
showAmountWithZeroCommodity :: Amount -> String
|
||||
showAmountWithZeroCommodity = showAmountHelper True
|
||||
showAmountWithZeroCommodity = wbUnpack . showAmountB noColour{displayZeroCommodity=True}
|
||||
|
||||
-- | Get a string representation of an amount for debugging,
|
||||
-- appropriate to the current debug level. 9 shows maximum detail.
|
||||
@ -402,35 +455,40 @@ showAmountDebug :: Amount -> String
|
||||
showAmountDebug Amount{acommodity="AUTO"} = "(missing)"
|
||||
showAmountDebug Amount{..} = printf "Amount {acommodity=%s, aquantity=%s, aprice=%s, astyle=%s}" (show acommodity) (show aquantity) (showAmountPriceDebug aprice) (show astyle)
|
||||
|
||||
-- | Get the string representation of the number part of of an amount,
|
||||
-- using the display settings from its commodity.
|
||||
showamountquantity :: Amount -> String
|
||||
-- | Get a Text Builder for the string representation of the number part of of an amount,
|
||||
-- using the display settings from its commodity. Also returns the width of the
|
||||
-- number.
|
||||
showamountquantity :: Amount -> WideBuilder
|
||||
showamountquantity amt@Amount{astyle=AmountStyle{asdecimalpoint=mdec, asdigitgroups=mgrps}} =
|
||||
punctuatenumber (fromMaybe '.' mdec) mgrps . show $ amountRoundedQuantity amt
|
||||
|
||||
-- | Replace a number string's decimal mark with the specified
|
||||
-- character, and add the specified digit group marks. The last digit
|
||||
-- group will be repeated as needed.
|
||||
punctuatenumber :: Char -> Maybe DigitGroupStyle -> String -> String
|
||||
punctuatenumber dec mgrps s = sign ++ reverse (applyDigitGroupStyle mgrps (reverse int)) ++ frac''
|
||||
where
|
||||
(sign,num) = break isDigit s
|
||||
(int,frac) = break (=='.') num
|
||||
frac' = dropWhile (=='.') frac
|
||||
frac'' | null frac' = ""
|
||||
| otherwise = dec:frac'
|
||||
|
||||
applyDigitGroupStyle :: Maybe DigitGroupStyle -> String -> String
|
||||
applyDigitGroupStyle Nothing s = s
|
||||
applyDigitGroupStyle (Just (DigitGroups c gs)) s = addseps (repeatLast gs) s
|
||||
signB <> intB <> fracB
|
||||
where
|
||||
addseps [] s = s
|
||||
addseps (g:gs) s
|
||||
| toInteger (length s) <= toInteger g = s
|
||||
| otherwise = let (part,rest) = genericSplitAt g s
|
||||
in part ++ c : addseps gs rest
|
||||
repeatLast [] = []
|
||||
repeatLast gs = init gs ++ repeat (last gs)
|
||||
Decimal e n = amountRoundedQuantity amt
|
||||
|
||||
strN = T.pack . show $ abs n
|
||||
len = T.length strN
|
||||
intLen = max 1 $ len - fromIntegral e
|
||||
dec = fromMaybe '.' mdec
|
||||
padded = T.replicate (fromIntegral e + 1 - len) "0" <> strN
|
||||
(intPart, fracPart) = T.splitAt intLen padded
|
||||
|
||||
intB = applyDigitGroupStyle mgrps intLen $ if e == 0 then strN else intPart
|
||||
signB = if n < 0 then WideBuilder (TB.singleton '-') 1 else mempty
|
||||
fracB = if e > 0 then WideBuilder (TB.singleton dec <> TB.fromText fracPart) (fromIntegral e + 1) else mempty
|
||||
|
||||
-- | Split a string representation into chunks according to DigitGroupStyle,
|
||||
-- returning a Text builder and the number of separators used.
|
||||
applyDigitGroupStyle :: Maybe DigitGroupStyle -> Int -> T.Text -> WideBuilder
|
||||
applyDigitGroupStyle Nothing l s = WideBuilder (TB.fromText s) l
|
||||
applyDigitGroupStyle (Just (DigitGroups _ [])) l s = WideBuilder (TB.fromText s) l
|
||||
applyDigitGroupStyle (Just (DigitGroups c (g:gs))) l s = addseps (g:|gs) (toInteger l) s
|
||||
where
|
||||
addseps (g:|gs) l s
|
||||
| l' > 0 = addseps gs' l' rest <> WideBuilder (TB.singleton c <> TB.fromText part) (fromIntegral g + 1)
|
||||
| otherwise = WideBuilder (TB.fromText s) (fromInteger l)
|
||||
where
|
||||
(rest, part) = T.splitAt (fromInteger l') s
|
||||
gs' = fromMaybe (g:|[]) $ nonEmpty gs
|
||||
l' = l - toInteger g
|
||||
|
||||
-- like journalCanonicaliseAmounts
|
||||
-- | Canonicalise an amount's display style using the provided commodity style map.
|
||||
@ -622,40 +680,46 @@ mixedAmountUnstyled = mapMixedAmount amountUnstyled
|
||||
-- | 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 = wbUnpack . showMixedAmountB noColour
|
||||
showMixedAmount :: MixedAmount -> String
|
||||
showMixedAmount = fst . showMixed showAmount Nothing Nothing False
|
||||
showMixedAmount = wbUnpack . showMixedAmountB noColour
|
||||
|
||||
-- | Get the one-line string representation of a mixed amount.
|
||||
--
|
||||
-- > showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLine
|
||||
showMixedAmountOneLine :: MixedAmount -> String
|
||||
showMixedAmountOneLine = fst . showMixedOneLine showAmountWithoutPrice Nothing Nothing False
|
||||
showMixedAmountOneLine = wbUnpack . showMixedAmountB oneLine
|
||||
|
||||
-- | Like showMixedAmount, but zero amounts are shown with their
|
||||
-- commodity if they have one.
|
||||
--
|
||||
-- > showMixedAmountWithZeroCommodity = wbUnpack . showMixedAmountB noColour{displayZeroCommodity=True}
|
||||
showMixedAmountWithZeroCommodity :: MixedAmount -> String
|
||||
showMixedAmountWithZeroCommodity = fst . showMixed showAmountWithZeroCommodity Nothing Nothing False
|
||||
|
||||
-- | Get the string representation of a mixed amount, showing each of its
|
||||
-- component amounts with the specified precision, ignoring their
|
||||
-- commoditys' display precision settings.
|
||||
showMixedAmountWithPrecision :: AmountPrecision -> MixedAmount -> String
|
||||
showMixedAmountWithPrecision p = fst . showMixed (showAmountWithPrecision p) Nothing Nothing False
|
||||
showMixedAmountWithZeroCommodity = wbUnpack . showMixedAmountB noColour{displayZeroCommodity=True}
|
||||
|
||||
-- | Get the string representation of a mixed amount, without showing any transaction prices.
|
||||
-- With a True argument, adds ANSI codes to show negative amounts in red.
|
||||
--
|
||||
-- > showMixedAmountWithoutPrice c = wbUnpack . showMixedAmountB noPrice{displayColour=c}
|
||||
showMixedAmountWithoutPrice :: Bool -> MixedAmount -> String
|
||||
showMixedAmountWithoutPrice c = fst . showMixed showAmountWithoutPrice Nothing Nothing c
|
||||
showMixedAmountWithoutPrice c = wbUnpack . showMixedAmountB noPrice{displayColour=c}
|
||||
|
||||
-- | Get the one-line string representation of a mixed amount, but without
|
||||
-- any \@ prices.
|
||||
-- With a True argument, adds ANSI codes to show negative amounts in red.
|
||||
--
|
||||
-- > showMixedAmountOneLineWithoutPrice c = wbUnpack . showMixedAmountB oneLine{displayColour=c}
|
||||
showMixedAmountOneLineWithoutPrice :: Bool -> MixedAmount -> String
|
||||
showMixedAmountOneLineWithoutPrice c = fst . showMixedOneLine showAmountWithoutPrice Nothing Nothing c
|
||||
showMixedAmountOneLineWithoutPrice c = wbUnpack . showMixedAmountB oneLine{displayColour=c}
|
||||
|
||||
-- | Like showMixedAmountOneLineWithoutPrice, but show at most the given width,
|
||||
-- with an elision indicator if there are more.
|
||||
-- With a True argument, adds ANSI codes to show negative amounts in red.
|
||||
--
|
||||
-- > showMixedAmountElided w c = wbUnpack . showMixedAmountB oneLine{displayColour=c, displayMaxWidth=Just w}
|
||||
showMixedAmountElided :: Int -> Bool -> MixedAmount -> String
|
||||
showMixedAmountElided w c = fst . showMixedOneLine showAmountWithoutPrice Nothing (Just w) c
|
||||
showMixedAmountElided w c = wbUnpack . showMixedAmountB oneLine{displayColour=c, displayMaxWidth=Just w}
|
||||
|
||||
-- | Get an unambiguous string representation of a mixed amount for debugging.
|
||||
showMixedAmountDebug :: MixedAmount -> String
|
||||
@ -663,59 +727,65 @@ showMixedAmountDebug m | m == missingmixedamt = "(missing)"
|
||||
| otherwise = printf "Mixed [%s]" as
|
||||
where as = intercalate "\n " $ map showAmountDebug $ amounts m
|
||||
|
||||
-- | General function to display a MixedAmount, one Amount on each line.
|
||||
-- It takes a function to display each Amount, an optional minimum width
|
||||
-- to pad to, an optional maximum width to display, and a Bool to determine
|
||||
-- whether to colourise negative numbers. Amounts longer than the maximum
|
||||
-- width (if given) will be elided. The function also returns the actual
|
||||
-- width of the output string.
|
||||
showMixed :: (Amount -> String) -> Maybe Int -> Maybe Int -> Bool -> MixedAmount -> (String, Int)
|
||||
showMixed showamt mmin mmax c =
|
||||
showMixedUnnormalised showamt mmin mmax c . normaliseMixedAmountSquashPricesForDisplay
|
||||
|
||||
-- | Like showMixed, but does not normalise the MixedAmount before displaying.
|
||||
showMixedUnnormalised :: (Amount -> String) -> Maybe Int -> Maybe Int -> Bool -> MixedAmount -> (String, Int)
|
||||
showMixedUnnormalised showamt mmin mmax c (Mixed as) =
|
||||
(intercalate "\n" $ map finalise elided, width)
|
||||
-- | General function to generate a WideBuilder for a MixedAmount, according the
|
||||
-- supplied AmountDisplayOpts. This is the main function to use for showing
|
||||
-- MixedAmounts, constructing a builder; it can then be converted to a Text with
|
||||
-- wbToText, or to a String with wbUnpack.
|
||||
--
|
||||
-- If a maximum width is given then:
|
||||
-- - If displayed on one line, it will display as many Amounts as can
|
||||
-- fit in the given width, and further Amounts will be elided.
|
||||
-- - If displayed on multiple lines, any Amounts longer than the
|
||||
-- maximum width will be elided.
|
||||
showMixedAmountB :: AmountDisplayOpts -> MixedAmount -> WideBuilder
|
||||
showMixedAmountB opts ma
|
||||
| displayOneLine opts = showMixedAmountOneLineB opts ma
|
||||
| otherwise = WideBuilder (wbBuilder . mconcat $ intersperse sep lines) width
|
||||
where
|
||||
width = maximum $ fromMaybe 0 mmin : map adLength elided
|
||||
astrs = amtDisplayList sepwidth showamt as
|
||||
sepwidth = 0 -- "\n" has width 0
|
||||
lines = showMixedAmountLinesB opts ma
|
||||
width = headDef 0 $ map wbWidth lines
|
||||
sep = WideBuilder (TB.singleton '\n') 0
|
||||
|
||||
finalise = adString . pad . if c then colourise else id
|
||||
pad amt = amt{ adString = applyN (width - adLength amt) (' ':) $ adString amt
|
||||
, adLength = width
|
||||
}
|
||||
-- | Helper for showMixedAmountB to show a MixedAmount on multiple lines. This returns
|
||||
-- the list of WideBuilders: one for each Amount in the MixedAmount (possibly
|
||||
-- normalised), and padded/elided to the appropriate width. This does not
|
||||
-- honour displayOneLine: all amounts will be displayed as if displayOneLine
|
||||
-- were False.
|
||||
showMixedAmountLinesB :: AmountDisplayOpts -> MixedAmount -> [WideBuilder]
|
||||
showMixedAmountLinesB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWidth=mmin} ma =
|
||||
map (adBuilder . pad) elided
|
||||
where
|
||||
Mixed amts = if displayNormalised opts then normaliseMixedAmountSquashPricesForDisplay ma else ma
|
||||
|
||||
astrs = amtDisplayList (wbWidth sep) (showAmountB opts) amts
|
||||
sep = WideBuilder (TB.singleton '\n') 0
|
||||
width = maximum $ fromMaybe 0 mmin : map (wbWidth . adBuilder) elided
|
||||
|
||||
pad amt = amt{ adBuilder = WideBuilder (TB.fromText $ T.replicate w " ") w <> adBuilder amt }
|
||||
where w = width - wbWidth (adBuilder amt)
|
||||
|
||||
elided = maybe id elideTo mmax astrs
|
||||
elideTo m xs = maybeAppend elisionStr short
|
||||
where
|
||||
elisionStr = elisionDisplay (Just m) sepwidth (length long) $ lastDef nullAmountDisplay short
|
||||
(short, long) = partition ((m>=) . adLength) xs
|
||||
elisionStr = elisionDisplay (Just m) (wbWidth sep) (length long) $ lastDef nullAmountDisplay short
|
||||
(short, long) = partition ((m>=) . wbWidth . adBuilder) xs
|
||||
|
||||
-- | General function to display a MixedAmount on a single line. It
|
||||
-- takes a function to display each Amount, an optional minimum width to
|
||||
-- pad to, an optional maximum width to display, and a Bool to determine
|
||||
-- whether to colourise negative numbers. It will display as many Amounts
|
||||
-- as it can in the maximum width (if given), and further Amounts will be
|
||||
-- elided. The function also returns the actual width of the output string.
|
||||
showMixedOneLine :: (Amount -> String) -> Maybe Int -> Maybe Int -> Bool -> MixedAmount -> (String, Int)
|
||||
showMixedOneLine showamt mmin mmax c =
|
||||
showMixedOneLineUnnormalised showamt mmin mmax c . normaliseMixedAmountSquashPricesForDisplay
|
||||
|
||||
-- | Like showMixedOneLine, but does not normalise the MixedAmount before
|
||||
-- displaying.
|
||||
showMixedOneLineUnnormalised :: (Amount -> String) -> Maybe Int -> Maybe Int -> Bool -> MixedAmount -> (String, Int)
|
||||
showMixedOneLineUnnormalised showamt mmin mmax c (Mixed as) =
|
||||
(pad . intercalate ", " $ map finalise elided, max width $ fromMaybe 0 mmin)
|
||||
-- | Helper for showMixedAmountB to deal with single line displays. This does not
|
||||
-- honour displayOneLine: all amounts will be displayed as if displayOneLine
|
||||
-- were True.
|
||||
showMixedAmountOneLineB :: AmountDisplayOpts -> MixedAmount -> WideBuilder
|
||||
showMixedAmountOneLineB opts@AmountDisplayOpts{displayMaxWidth=mmax,displayMinWidth=mmin} ma =
|
||||
WideBuilder (wbBuilder . pad . mconcat . intersperse sep $ map adBuilder elided) . max width $ fromMaybe 0 mmin
|
||||
where
|
||||
width = maybe 0 adTotal $ lastMay elided
|
||||
astrs = amtDisplayList sepwidth showamt as
|
||||
sepwidth = 2 -- ", " has width 2
|
||||
n = length as
|
||||
Mixed amts = if displayNormalised opts then normaliseMixedAmountSquashPricesForDisplay ma else ma
|
||||
|
||||
finalise = adString . if c then colourise else id
|
||||
pad = applyN (fromMaybe 0 mmin - width) (' ':)
|
||||
width = maybe 0 adTotal $ lastMay elided
|
||||
astrs = amtDisplayList (wbWidth sep) (showAmountB opts) amts
|
||||
sep = WideBuilder (TB.fromString ", ") 2
|
||||
n = length amts
|
||||
|
||||
pad = (WideBuilder (TB.fromText $ T.replicate w " ") w <>)
|
||||
where w = fromMaybe 0 mmin - width
|
||||
|
||||
elided = maybe id elideTo mmax astrs
|
||||
elideTo m = addElide . takeFitting m . withElided
|
||||
@ -728,39 +798,36 @@ showMixedOneLineUnnormalised showamt mmin mmax c (Mixed as) =
|
||||
dropWhileRev p = foldr (\x xs -> if null xs && p x then [] else x:xs) []
|
||||
|
||||
-- Add the elision strings (if any) to each amount
|
||||
withElided = zipWith (\num amt -> (amt, elisionDisplay Nothing sepwidth num amt)) [n-1,n-2..0]
|
||||
withElided = zipWith (\num amt -> (amt, elisionDisplay Nothing (wbWidth sep) num amt)) [n-1,n-2..0]
|
||||
|
||||
data AmountDisplay = AmountDisplay
|
||||
{ adAmount :: !Amount -- ^ Amount displayed
|
||||
, adString :: !String -- ^ String representation of the Amount
|
||||
, adLength :: !Int -- ^ Length of the string representation
|
||||
, adTotal :: !Int -- ^ Cumulative length of MixedAmount this Amount is part of,
|
||||
-- including separators
|
||||
} deriving (Show)
|
||||
{ adBuilder :: !WideBuilder -- ^ String representation of the Amount
|
||||
, adTotal :: !Int -- ^ Cumulative length of MixedAmount this Amount is part of,
|
||||
-- including separators
|
||||
}
|
||||
|
||||
nullAmountDisplay :: AmountDisplay
|
||||
nullAmountDisplay = AmountDisplay nullamt "" 0 0
|
||||
nullAmountDisplay = AmountDisplay mempty 0
|
||||
|
||||
amtDisplayList :: Int -> (Amount -> String) -> [Amount] -> [AmountDisplay]
|
||||
amtDisplayList :: Int -> (Amount -> WideBuilder) -> [Amount] -> [AmountDisplay]
|
||||
amtDisplayList sep showamt = snd . mapAccumL display (-sep)
|
||||
where
|
||||
display tot amt = (tot', AmountDisplay amt str width tot')
|
||||
display tot amt = (tot', AmountDisplay str tot')
|
||||
where
|
||||
str = showamt amt
|
||||
width = strWidth str
|
||||
tot' = tot + width + sep
|
||||
tot' = tot + (wbWidth str) + sep
|
||||
|
||||
-- The string "m more", added to the previous running total
|
||||
elisionDisplay :: Maybe Int -> Int -> Int -> AmountDisplay -> Maybe AmountDisplay
|
||||
elisionDisplay mmax sep n lastAmt
|
||||
| n > 0 = Just $ AmountDisplay 0 str len (adTotal lastAmt + len)
|
||||
| n > 0 = Just $ AmountDisplay (WideBuilder (TB.fromText str) len) (adTotal lastAmt + len)
|
||||
| otherwise = Nothing
|
||||
where
|
||||
fullString = show n ++ " more.."
|
||||
fullString = T.pack $ show n ++ " more.."
|
||||
-- sep from the separator, 7 from " more..", 1 + floor (logBase 10 n) from number
|
||||
fullLength = sep + 8 + floor (logBase 10 $ fromIntegral n)
|
||||
|
||||
str | Just m <- mmax, fullLength > m = take (m - 2) fullString ++ ".."
|
||||
str | Just m <- mmax, fullLength > m = T.take (m - 2) fullString <> ".."
|
||||
| otherwise = fullString
|
||||
len = case mmax of Nothing -> fullLength
|
||||
Just m -> max 2 $ min m fullLength
|
||||
@ -769,10 +836,6 @@ maybeAppend :: Maybe a -> [a] -> [a]
|
||||
maybeAppend Nothing = id
|
||||
maybeAppend (Just a) = (++[a])
|
||||
|
||||
colourise :: AmountDisplay -> AmountDisplay
|
||||
colourise amt = amt{adString=markColour $ adString amt}
|
||||
where markColour = if isNegativeAmount (adAmount amt) then color Dull Red else id
|
||||
|
||||
-- | Compact labelled trace of a mixed amount, for debugging.
|
||||
ltraceamount :: String -> MixedAmount -> MixedAmount
|
||||
ltraceamount s = traceWith (((s ++ ": ") ++).showMixedAmount)
|
||||
|
@ -110,19 +110,19 @@ import Hledger.Utils
|
||||
|
||||
-- Help ppShow parse and line-wrap DateSpans better in debug output.
|
||||
instance Show DateSpan where
|
||||
show s = "DateSpan " ++ showDateSpan s
|
||||
show s = "DateSpan " ++ T.unpack (showDateSpan s)
|
||||
|
||||
showDate :: Day -> String
|
||||
showDate = show
|
||||
showDate :: Day -> Text
|
||||
showDate = T.pack . show
|
||||
|
||||
-- | Render a datespan as a display string, abbreviating into a
|
||||
-- compact form if possible.
|
||||
showDateSpan :: DateSpan -> String
|
||||
showDateSpan :: DateSpan -> Text
|
||||
showDateSpan = showPeriod . dateSpanAsPeriod
|
||||
|
||||
-- | Like showDateSpan, but show month spans as just the abbreviated month name
|
||||
-- in the current locale.
|
||||
showDateSpanMonthAbbrev :: DateSpan -> String
|
||||
showDateSpanMonthAbbrev :: DateSpan -> Text
|
||||
showDateSpanMonthAbbrev = showPeriodMonthAbbrev . dateSpanAsPeriod
|
||||
|
||||
-- | Get the current local date.
|
||||
@ -388,13 +388,13 @@ spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e)
|
||||
|
||||
-- | Convert a smart date string to an explicit yyyy\/mm\/dd string using
|
||||
-- the provided reference date, or raise an error.
|
||||
fixSmartDateStr :: Day -> Text -> String
|
||||
fixSmartDateStr :: Day -> Text -> Text
|
||||
fixSmartDateStr d s =
|
||||
either (error' . printf "could not parse date %s %s" (show s) . show) id $ -- PARTIAL:
|
||||
(fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) String)
|
||||
(fixSmartDateStrEither d s :: Either (ParseErrorBundle Text CustomErr) Text)
|
||||
|
||||
-- | A safe version of fixSmartDateStr.
|
||||
fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) String
|
||||
fixSmartDateStrEither :: Day -> Text -> Either (ParseErrorBundle Text CustomErr) Text
|
||||
fixSmartDateStrEither d = fmap showDate . fixSmartDateStrEither' d
|
||||
|
||||
fixSmartDateStrEither'
|
||||
|
@ -87,20 +87,20 @@ module Hledger.Data.Journal (
|
||||
tests_Journal,
|
||||
)
|
||||
where
|
||||
import Control.Monad
|
||||
import Control.Monad.Except
|
||||
import Control.Monad.Extra
|
||||
|
||||
import Control.Monad.Except (ExceptT(..), runExceptT, throwError)
|
||||
import Control.Monad.Extra (whenM)
|
||||
import Control.Monad.Reader as R
|
||||
import Control.Monad.ST
|
||||
import Data.Array.ST
|
||||
import Control.Monad.ST (ST, runST)
|
||||
import Data.Array.ST (STArray, getElems, newListArray, writeArray)
|
||||
import Data.Default (Default(..))
|
||||
import Data.Function ((&))
|
||||
import qualified Data.HashTable.Class as H (toList)
|
||||
import qualified Data.HashTable.ST.Cuckoo as H
|
||||
import Data.List
|
||||
import Data.List (find, sortOn)
|
||||
import Data.List.Extra (groupSort, nubSort)
|
||||
import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust, mapMaybe)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup (Semigroup(..))
|
||||
#endif
|
||||
@ -108,10 +108,10 @@ import qualified Data.Set as S
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Safe (headMay, headDef)
|
||||
import Data.Time.Calendar
|
||||
import Data.Tree
|
||||
import Data.Time.Calendar (Day, addDays, fromGregorian)
|
||||
import Data.Tree (Tree, flatten)
|
||||
import System.Time (ClockTime(TOD))
|
||||
import Text.Printf
|
||||
import Text.Printf (printf)
|
||||
|
||||
import Hledger.Utils
|
||||
import Hledger.Data.Types
|
||||
@ -895,7 +895,7 @@ checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt
|
||||
Nothing -> "?" -- shouldn't happen
|
||||
Just t -> printf "%s\ntransaction:\n%s"
|
||||
(showGenericSourcePos pos)
|
||||
(chomp $ showTransaction t)
|
||||
(textChomp $ showTransaction t)
|
||||
:: String
|
||||
where
|
||||
pos = baposition $ fromJust $ pbalanceassertion p
|
||||
@ -926,11 +926,11 @@ checkIllegalBalanceAssignmentB p = do
|
||||
checkBalanceAssignmentPostingDateB :: Posting -> Balancing s ()
|
||||
checkBalanceAssignmentPostingDateB p =
|
||||
when (hasBalanceAssignment p && isJust (pdate p)) $
|
||||
throwError $ unlines $
|
||||
throwError . T.unpack $ T.unlines
|
||||
["postings which are balance assignments may not have a custom date."
|
||||
,"Please write the posting amount explicitly, or remove the posting date:"
|
||||
,""
|
||||
,maybe (unlines $ showPostingLines p) showTransaction $ ptransaction p
|
||||
,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p
|
||||
]
|
||||
|
||||
-- | Throw an error if this posting is trying to do a balance assignment and
|
||||
@ -940,16 +940,16 @@ checkBalanceAssignmentUnassignableAccountB :: Posting -> Balancing s ()
|
||||
checkBalanceAssignmentUnassignableAccountB p = do
|
||||
unassignable <- R.asks bsUnassignable
|
||||
when (hasBalanceAssignment p && paccount p `S.member` unassignable) $
|
||||
throwError $ unlines $
|
||||
throwError . T.unpack $ T.unlines
|
||||
["balance assignments cannot be used with accounts which are"
|
||||
,"posted to by transaction modifier rules (auto postings)."
|
||||
,"Please write the posting amount explicitly, or remove the rule."
|
||||
,""
|
||||
,"account: "++T.unpack (paccount p)
|
||||
,"account: " <> paccount p
|
||||
,""
|
||||
,"transaction:"
|
||||
,""
|
||||
,maybe (unlines $ showPostingLines p) showTransaction $ ptransaction p
|
||||
,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p
|
||||
]
|
||||
|
||||
--
|
||||
|
@ -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
|
||||
|
@ -5,6 +5,8 @@ a richer abstraction than DateSpan. See also Types and Dates.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Hledger.Data.Period (
|
||||
periodAsDateSpan
|
||||
,dateSpanAsPeriod
|
||||
@ -30,6 +32,8 @@ module Hledger.Data.Period (
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Calendar.MonthDay
|
||||
import Data.Time.Calendar.OrdinalDate
|
||||
@ -155,21 +159,23 @@ isStandardPeriod = isStandardPeriod' . simplifyPeriod
|
||||
--
|
||||
-- >>> showPeriod (WeekPeriod (fromGregorian 2016 7 25))
|
||||
-- "2016-07-25W30"
|
||||
showPeriod (DayPeriod b) = formatTime defaultTimeLocale "%F" b -- DATE
|
||||
showPeriod (WeekPeriod b) = formatTime defaultTimeLocale "%FW%V" b -- STARTDATEWYEARWEEK
|
||||
showPeriod (MonthPeriod y m) = printf "%04d-%02d" y m -- YYYY-MM
|
||||
showPeriod (QuarterPeriod y q) = printf "%04dQ%d" y q -- YYYYQN
|
||||
showPeriod (YearPeriod y) = printf "%04d" y -- YYYY
|
||||
showPeriod (PeriodBetween b e) = formatTime defaultTimeLocale "%F" b
|
||||
showPeriod :: Period -> Text
|
||||
showPeriod (DayPeriod b) = T.pack $ formatTime defaultTimeLocale "%F" b -- DATE
|
||||
showPeriod (WeekPeriod b) = T.pack $ formatTime defaultTimeLocale "%FW%V" b -- STARTDATEWYEARWEEK
|
||||
showPeriod (MonthPeriod y m) = T.pack $ printf "%04d-%02d" y m -- YYYY-MM
|
||||
showPeriod (QuarterPeriod y q) = T.pack $ printf "%04dQ%d" y q -- YYYYQN
|
||||
showPeriod (YearPeriod y) = T.pack $ printf "%04d" y -- YYYY
|
||||
showPeriod (PeriodBetween b e) = T.pack $ formatTime defaultTimeLocale "%F" b
|
||||
++ formatTime defaultTimeLocale "..%F" (addDays (-1) e) -- STARTDATE..INCLUSIVEENDDATE
|
||||
showPeriod (PeriodFrom b) = formatTime defaultTimeLocale "%F.." b -- STARTDATE..
|
||||
showPeriod (PeriodTo e) = formatTime defaultTimeLocale "..%F" (addDays (-1) e) -- ..INCLUSIVEENDDATE
|
||||
showPeriod (PeriodFrom b) = T.pack $ formatTime defaultTimeLocale "%F.." b -- STARTDATE..
|
||||
showPeriod (PeriodTo e) = T.pack $ formatTime defaultTimeLocale "..%F" (addDays (-1) e) -- ..INCLUSIVEENDDATE
|
||||
showPeriod PeriodAll = ".."
|
||||
|
||||
-- | Like showPeriod, but if it's a month period show just
|
||||
-- the 3 letter month name abbreviation for the current locale.
|
||||
showPeriodMonthAbbrev :: Period -> Text
|
||||
showPeriodMonthAbbrev (MonthPeriod _ m) -- Jan
|
||||
| m > 0 && m <= length monthnames = snd $ monthnames !! (m-1)
|
||||
| m > 0 && m <= length monthnames = T.pack . snd $ monthnames !! (m-1)
|
||||
where monthnames = months defaultTimeLocale
|
||||
showPeriodMonthAbbrev p = showPeriod p
|
||||
|
||||
|
@ -16,6 +16,7 @@ where
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Text.Printf
|
||||
|
||||
import Hledger.Data.Types
|
||||
@ -40,7 +41,7 @@ _ptgen str = do
|
||||
case checkPeriodicTransactionStartDate i s t of
|
||||
Just e -> error' e -- PARTIAL:
|
||||
Nothing ->
|
||||
mapM_ (putStr . showTransaction) $
|
||||
mapM_ (T.putStr . showTransaction) $
|
||||
runPeriodicTransaction
|
||||
nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }
|
||||
nulldatespan
|
||||
@ -52,7 +53,7 @@ _ptgenspan str span = do
|
||||
case checkPeriodicTransactionStartDate i s t of
|
||||
Just e -> error' e -- PARTIAL:
|
||||
Nothing ->
|
||||
mapM_ (putStr . showTransaction) $
|
||||
mapM_ (T.putStr . showTransaction) $
|
||||
runPeriodicTransaction
|
||||
nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }
|
||||
span
|
||||
|
@ -161,20 +161,20 @@ originalPosting p = fromMaybe p $ poriginal p
|
||||
-- XXX once rendered user output, but just for debugging now; clean up
|
||||
showPosting :: Posting -> String
|
||||
showPosting p@Posting{paccount=a,pamount=amt,ptype=t} =
|
||||
unlines $ [concatTopPadded [show (postingDate p) ++ " ", showaccountname a ++ " ", showamount amt, showComment (pcomment p)]]
|
||||
unlines $ [concatTopPadded [show (postingDate p) ++ " ", showaccountname a ++ " ", showamount amt, T.unpack . showComment $ pcomment p]]
|
||||
where
|
||||
ledger3ishlayout = False
|
||||
acctnamewidth = if ledger3ishlayout then 25 else 22
|
||||
showaccountname = fitString (Just acctnamewidth) Nothing False False . bracket . T.unpack . elideAccountName width
|
||||
showaccountname = T.unpack . fitText (Just acctnamewidth) Nothing False False . bracket . elideAccountName width
|
||||
(bracket,width) = case t of
|
||||
BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)
|
||||
VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)
|
||||
_ -> (id,acctnamewidth)
|
||||
showamount = fst . showMixed showAmount (Just 12) Nothing False
|
||||
BalancedVirtualPosting -> (wrap "[" "]", acctnamewidth-2)
|
||||
VirtualPosting -> (wrap "(" ")", acctnamewidth-2)
|
||||
_ -> (id,acctnamewidth)
|
||||
showamount = wbUnpack . showMixedAmountB noColour{displayMinWidth=Just 12}
|
||||
|
||||
|
||||
showComment :: Text -> String
|
||||
showComment t = if T.null t then "" else " ;" ++ T.unpack t
|
||||
showComment :: Text -> Text
|
||||
showComment t = if T.null t then "" else " ;" <> t
|
||||
|
||||
isReal :: Posting -> Bool
|
||||
isReal p = ptype p == RegularPosting
|
||||
@ -274,9 +274,9 @@ accountNameWithoutPostingType a = case accountNamePostingType a of
|
||||
RegularPosting -> a
|
||||
|
||||
accountNameWithPostingType :: PostingType -> AccountName -> AccountName
|
||||
accountNameWithPostingType BalancedVirtualPosting a = "["<>accountNameWithoutPostingType a<>"]"
|
||||
accountNameWithPostingType VirtualPosting a = "("<>accountNameWithoutPostingType a<>")"
|
||||
accountNameWithPostingType RegularPosting a = accountNameWithoutPostingType a
|
||||
accountNameWithPostingType BalancedVirtualPosting = wrap "[" "]" . accountNameWithoutPostingType
|
||||
accountNameWithPostingType VirtualPosting = wrap "(" ")" . accountNameWithoutPostingType
|
||||
accountNameWithPostingType RegularPosting = accountNameWithoutPostingType
|
||||
|
||||
-- | Prefix one account name to another, preserving posting type
|
||||
-- indicators like concatAccountNames.
|
||||
|
@ -2,7 +2,10 @@
|
||||
-- hledger's report item fields. The formats are used by
|
||||
-- report-specific renderers like renderBalanceReportItem.
|
||||
|
||||
{-# LANGUAGE FlexibleContexts, OverloadedStrings, TypeFamilies, PackageImports #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
|
||||
module Hledger.Data.StringFormat (
|
||||
parseStringFormat
|
||||
@ -10,7 +13,6 @@ module Hledger.Data.StringFormat (
|
||||
, StringFormat(..)
|
||||
, StringFormatComponent(..)
|
||||
, ReportItemField(..)
|
||||
, overlineWidth
|
||||
, defaultBalanceLineFormat
|
||||
, tests_StringFormat
|
||||
) where
|
||||
@ -21,22 +23,20 @@ import Numeric (readDec)
|
||||
import Data.Char (isPrint)
|
||||
import Data.Default (Default(..))
|
||||
import Data.Maybe (isJust)
|
||||
-- import qualified Data.Text as T
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.Megaparsec
|
||||
import Text.Megaparsec.Char (char, digitChar, string)
|
||||
|
||||
import Hledger.Utils.Parse (SimpleStringParser)
|
||||
import Hledger.Utils.String (formatString)
|
||||
import Hledger.Utils.Parse (SimpleTextParser)
|
||||
import Hledger.Utils.Text (formatText)
|
||||
import Hledger.Utils.Test
|
||||
|
||||
-- | A format specification/template to use when rendering a report line item as text.
|
||||
--
|
||||
-- A format is an optional width, along with a sequence of components;
|
||||
-- each is either a literal string, or a hledger report item field with
|
||||
-- specified width and justification whose value will be interpolated
|
||||
-- at render time. The optional width determines the length of the
|
||||
-- overline to draw above the totals row; if it is Nothing, then the
|
||||
-- maximum width of all lines is used.
|
||||
-- A format is a sequence of components; each is either a literal
|
||||
-- string, or a hledger report item field with specified width and
|
||||
-- justification whose value will be interpolated at render time.
|
||||
--
|
||||
-- A component's value may be a multi-line string (or a
|
||||
-- multi-commodity amount), in which case the final string will be
|
||||
@ -47,13 +47,13 @@ import Hledger.Utils.Test
|
||||
-- mode, which provides a limited StringFormat renderer.
|
||||
--
|
||||
data StringFormat =
|
||||
OneLine (Maybe Int) [StringFormatComponent] -- ^ multi-line values will be rendered on one line, comma-separated
|
||||
| TopAligned (Maybe Int) [StringFormatComponent] -- ^ values will be top-aligned (and bottom-padded to the same height)
|
||||
| BottomAligned (Maybe Int) [StringFormatComponent] -- ^ values will be bottom-aligned (and top-padded)
|
||||
OneLine [StringFormatComponent] -- ^ multi-line values will be rendered on one line, comma-separated
|
||||
| TopAligned [StringFormatComponent] -- ^ values will be top-aligned (and bottom-padded to the same height)
|
||||
| BottomAligned [StringFormatComponent] -- ^ values will be bottom-aligned (and top-padded)
|
||||
deriving (Show, Eq)
|
||||
|
||||
data StringFormatComponent =
|
||||
FormatLiteral String -- ^ Literal text to be rendered as-is
|
||||
FormatLiteral Text -- ^ Literal text to be rendered as-is
|
||||
| FormatField Bool
|
||||
(Maybe Int)
|
||||
(Maybe Int)
|
||||
@ -81,14 +81,9 @@ data ReportItemField =
|
||||
|
||||
instance Default StringFormat where def = defaultBalanceLineFormat
|
||||
|
||||
overlineWidth :: StringFormat -> Maybe Int
|
||||
overlineWidth (OneLine w _) = w
|
||||
overlineWidth (TopAligned w _) = w
|
||||
overlineWidth (BottomAligned w _) = w
|
||||
|
||||
-- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)"
|
||||
defaultBalanceLineFormat :: StringFormat
|
||||
defaultBalanceLineFormat = BottomAligned (Just 20) [
|
||||
defaultBalanceLineFormat = BottomAligned [
|
||||
FormatField False (Just 20) Nothing TotalField
|
||||
, FormatLiteral " "
|
||||
, FormatField True (Just 2) Nothing DepthSpacerField
|
||||
@ -102,37 +97,37 @@ defaultBalanceLineFormat = BottomAligned (Just 20) [
|
||||
----------------------------------------------------------------------
|
||||
|
||||
-- | Parse a string format specification, or return a parse error.
|
||||
parseStringFormat :: String -> Either String StringFormat
|
||||
parseStringFormat :: Text -> Either String StringFormat
|
||||
parseStringFormat input = case (runParser (stringformatp <* eof) "(unknown)") input of
|
||||
Left y -> Left $ show y
|
||||
Right x -> Right x
|
||||
|
||||
defaultStringFormatStyle = BottomAligned
|
||||
|
||||
stringformatp :: SimpleStringParser StringFormat
|
||||
stringformatp :: SimpleTextParser StringFormat
|
||||
stringformatp = do
|
||||
alignspec <- optional (try $ char '%' >> oneOf ("^_,"::String))
|
||||
let constructor =
|
||||
case alignspec of
|
||||
Just '^' -> TopAligned Nothing
|
||||
Just '_' -> BottomAligned Nothing
|
||||
Just ',' -> OneLine Nothing
|
||||
_ -> defaultStringFormatStyle Nothing
|
||||
Just '^' -> TopAligned
|
||||
Just '_' -> BottomAligned
|
||||
Just ',' -> OneLine
|
||||
_ -> defaultStringFormatStyle
|
||||
constructor <$> many componentp
|
||||
|
||||
componentp :: SimpleStringParser StringFormatComponent
|
||||
componentp :: SimpleTextParser StringFormatComponent
|
||||
componentp = formatliteralp <|> formatfieldp
|
||||
|
||||
formatliteralp :: SimpleStringParser StringFormatComponent
|
||||
formatliteralp :: SimpleTextParser StringFormatComponent
|
||||
formatliteralp = do
|
||||
s <- some c
|
||||
s <- T.pack <$> some c
|
||||
return $ FormatLiteral s
|
||||
where
|
||||
isPrintableButNotPercentage x = isPrint x && x /= '%'
|
||||
c = (satisfy isPrintableButNotPercentage <?> "printable character")
|
||||
<|> try (string "%%" >> return '%')
|
||||
|
||||
formatfieldp :: SimpleStringParser StringFormatComponent
|
||||
formatfieldp :: SimpleTextParser StringFormatComponent
|
||||
formatfieldp = do
|
||||
char '%'
|
||||
leftJustified <- optional (char '-')
|
||||
@ -147,7 +142,7 @@ formatfieldp = do
|
||||
Just text -> Just m where ((m,_):_) = readDec text
|
||||
_ -> Nothing
|
||||
|
||||
fieldp :: SimpleStringParser ReportItemField
|
||||
fieldp :: SimpleTextParser ReportItemField
|
||||
fieldp = do
|
||||
try (string "account" >> return AccountField)
|
||||
<|> try (string "depth_spacer" >> return DepthSpacerField)
|
||||
@ -161,8 +156,8 @@ fieldp = do
|
||||
formatStringTester fs value expected = actual @?= expected
|
||||
where
|
||||
actual = case fs of
|
||||
FormatLiteral l -> formatString False Nothing Nothing l
|
||||
FormatField leftJustify min max _ -> formatString leftJustify min max value
|
||||
FormatLiteral l -> formatText False Nothing Nothing l
|
||||
FormatField leftJustify min max _ -> formatText leftJustify min max value
|
||||
|
||||
tests_StringFormat = tests "StringFormat" [
|
||||
|
||||
@ -176,25 +171,25 @@ tests_StringFormat = tests "StringFormat" [
|
||||
formatStringTester (FormatField True (Just 20) (Just 20) DescriptionField) "description" "description "
|
||||
formatStringTester (FormatField True Nothing (Just 3) DescriptionField) "description" "des"
|
||||
|
||||
,let s `gives` expected = test s $ parseStringFormat s @?= Right expected
|
||||
,let s `gives` expected = test s $ parseStringFormat (T.pack s) @?= Right expected
|
||||
in tests "parseStringFormat" [
|
||||
"" `gives` (defaultStringFormatStyle Nothing [])
|
||||
, "D" `gives` (defaultStringFormatStyle Nothing [FormatLiteral "D"])
|
||||
, "%(date)" `gives` (defaultStringFormatStyle Nothing [FormatField False Nothing Nothing DescriptionField])
|
||||
, "%(total)" `gives` (defaultStringFormatStyle Nothing [FormatField False Nothing Nothing TotalField])
|
||||
"" `gives` (defaultStringFormatStyle [])
|
||||
, "D" `gives` (defaultStringFormatStyle [FormatLiteral "D"])
|
||||
, "%(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing DescriptionField])
|
||||
, "%(total)" `gives` (defaultStringFormatStyle [FormatField False Nothing Nothing TotalField])
|
||||
-- TODO
|
||||
-- , "^%(total)" `gives` (TopAligned [FormatField False Nothing Nothing TotalField])
|
||||
-- , "_%(total)" `gives` (BottomAligned [FormatField False Nothing Nothing TotalField])
|
||||
-- , ",%(total)" `gives` (OneLine [FormatField False Nothing Nothing TotalField])
|
||||
, "Hello %(date)!" `gives` (defaultStringFormatStyle Nothing [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"])
|
||||
, "%-(date)" `gives` (defaultStringFormatStyle Nothing [FormatField True Nothing Nothing DescriptionField])
|
||||
, "%20(date)" `gives` (defaultStringFormatStyle Nothing [FormatField False (Just 20) Nothing DescriptionField])
|
||||
, "%.10(date)" `gives` (defaultStringFormatStyle Nothing [FormatField False Nothing (Just 10) DescriptionField])
|
||||
, "%20.10(date)" `gives` (defaultStringFormatStyle Nothing [FormatField False (Just 20) (Just 10) DescriptionField])
|
||||
, "%20(account) %.10(total)" `gives` (defaultStringFormatStyle Nothing [FormatField False (Just 20) Nothing AccountField
|
||||
,FormatLiteral " "
|
||||
,FormatField False Nothing (Just 10) TotalField
|
||||
])
|
||||
, "Hello %(date)!" `gives` (defaultStringFormatStyle [FormatLiteral "Hello ", FormatField False Nothing Nothing DescriptionField, FormatLiteral "!"])
|
||||
, "%-(date)" `gives` (defaultStringFormatStyle [FormatField True Nothing Nothing DescriptionField])
|
||||
, "%20(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing DescriptionField])
|
||||
, "%.10(date)" `gives` (defaultStringFormatStyle [FormatField False Nothing (Just 10) DescriptionField])
|
||||
, "%20.10(date)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) (Just 10) DescriptionField])
|
||||
, "%20(account) %.10(total)" `gives` (defaultStringFormatStyle [FormatField False (Just 20) Nothing AccountField
|
||||
,FormatLiteral " "
|
||||
,FormatField False Nothing (Just 10) TotalField
|
||||
])
|
||||
, test "newline not parsed" $ assertLeft $ parseStringFormat "\n"
|
||||
]
|
||||
]
|
||||
|
@ -6,6 +6,7 @@ converted to 'Transactions' and queried like a ledger.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Hledger.Data.Timeclock (
|
||||
@ -14,14 +15,18 @@ module Hledger.Data.Timeclock (
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Maybe
|
||||
import Data.Maybe (fromMaybe)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
-- import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
import Data.Time.Clock
|
||||
import Data.Time.Format
|
||||
import Data.Time.LocalTime
|
||||
import Text.Printf
|
||||
import Data.Time.Calendar (addDays)
|
||||
import Data.Time.Clock (addUTCTime, getCurrentTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime, parseTimeM)
|
||||
import Data.Time.LocalTime (LocalTime(..), TimeOfDay(..), getCurrentTimeZone,
|
||||
localTimeToUTC, midnight, utc, utcToLocalTime)
|
||||
import Text.Printf (printf)
|
||||
|
||||
import Hledger.Utils
|
||||
import Hledger.Data.Types
|
||||
@ -90,8 +95,8 @@ errorWithSourceLine line msg = error $ "line " ++ show line ++ ": " ++ msg
|
||||
entryFromTimeclockInOut :: TimeclockEntry -> TimeclockEntry -> Transaction
|
||||
entryFromTimeclockInOut i o
|
||||
| otime >= itime = t
|
||||
| otherwise =
|
||||
error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t -- PARTIAL:
|
||||
| otherwise = error' . T.unpack $
|
||||
"clock-out time less than clock-in time in:\n" <> showTransaction t -- PARTIAL:
|
||||
where
|
||||
t = Transaction {
|
||||
tindex = 0,
|
||||
|
@ -7,11 +7,12 @@ tags.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE Rank2Types #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
|
||||
module Hledger.Data.Transaction (
|
||||
-- * Transaction
|
||||
@ -44,8 +45,6 @@ module Hledger.Data.Transaction (
|
||||
-- * rendering
|
||||
showTransaction,
|
||||
showTransactionOneLineAmounts,
|
||||
showTransactionUnelided,
|
||||
showTransactionUnelidedOneLineAmounts,
|
||||
-- showPostingLine,
|
||||
showPostingLines,
|
||||
-- * GenericSourcePos
|
||||
@ -57,13 +56,19 @@ module Hledger.Data.Transaction (
|
||||
tests_Transaction
|
||||
)
|
||||
where
|
||||
import Data.List
|
||||
|
||||
import Data.Default (def)
|
||||
import Data.List (intercalate, partition)
|
||||
import Data.List.Extra (nubSort)
|
||||
import Data.Maybe
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
import Text.Printf
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import Data.Time.Calendar (Day, fromGregorian)
|
||||
import qualified Data.Map as M
|
||||
|
||||
import Hledger.Utils
|
||||
@ -72,6 +77,8 @@ import Hledger.Data.Dates
|
||||
import Hledger.Data.Posting
|
||||
import Hledger.Data.Amount
|
||||
import Hledger.Data.Valuation
|
||||
import Text.Tabular
|
||||
import Text.Tabular.AsciiWide
|
||||
|
||||
sourceFilePath :: GenericSourcePos -> FilePath
|
||||
sourceFilePath = \case
|
||||
@ -148,53 +155,46 @@ To facilitate this, postings with explicit multi-commodity amounts
|
||||
are displayed as multiple similar postings, one per commodity.
|
||||
(Normally does not happen with this function).
|
||||
-}
|
||||
showTransaction :: Transaction -> String
|
||||
showTransaction = showTransactionHelper False
|
||||
|
||||
-- | Deprecated alias for 'showTransaction'
|
||||
showTransactionUnelided :: Transaction -> String
|
||||
showTransactionUnelided = showTransaction -- TODO: drop it
|
||||
showTransaction :: Transaction -> Text
|
||||
showTransaction = TL.toStrict . TB.toLazyText . showTransactionHelper False
|
||||
|
||||
-- | Like showTransaction, but explicit multi-commodity amounts
|
||||
-- are shown on one line, comma-separated. In this case the output will
|
||||
-- not be parseable journal syntax.
|
||||
showTransactionOneLineAmounts :: Transaction -> String
|
||||
showTransactionOneLineAmounts = showTransactionHelper True
|
||||
|
||||
-- | Deprecated alias for 'showTransactionOneLineAmounts'
|
||||
showTransactionUnelidedOneLineAmounts :: Transaction -> String
|
||||
showTransactionUnelidedOneLineAmounts = showTransactionOneLineAmounts -- TODO: drop it
|
||||
showTransactionOneLineAmounts :: Transaction -> Text
|
||||
showTransactionOneLineAmounts = TL.toStrict . TB.toLazyText . showTransactionHelper True
|
||||
|
||||
-- | Helper for showTransaction*.
|
||||
showTransactionHelper :: Bool -> Transaction -> String
|
||||
showTransactionHelper :: Bool -> Transaction -> TB.Builder
|
||||
showTransactionHelper onelineamounts t =
|
||||
unlines $ [descriptionline]
|
||||
++ newlinecomments
|
||||
++ (postingsAsLines onelineamounts (tpostings t))
|
||||
++ [""]
|
||||
where
|
||||
descriptionline = rstrip $ concat [date, status, code, desc, samelinecomment]
|
||||
date = showDate (tdate t) ++ maybe "" (("="++) . showDate) (tdate2 t)
|
||||
status | tstatus t == Cleared = " *"
|
||||
| tstatus t == Pending = " !"
|
||||
| otherwise = ""
|
||||
code = if T.length (tcode t) > 0 then printf " (%s)" $ T.unpack $ tcode t else ""
|
||||
desc = if null d then "" else " " ++ d where d = T.unpack $ tdescription t
|
||||
(samelinecomment, newlinecomments) =
|
||||
case renderCommentLines (tcomment t) of [] -> ("",[])
|
||||
c:cs -> (c,cs)
|
||||
TB.fromText descriptionline <> newline
|
||||
<> foldMap ((<> newline) . TB.fromText) newlinecomments
|
||||
<> foldMap ((<> newline) . TB.fromText) (postingsAsLines onelineamounts $ tpostings t)
|
||||
<> newline
|
||||
where
|
||||
descriptionline = T.stripEnd $ T.concat [date, status, code, desc, samelinecomment]
|
||||
date = showDate (tdate t) <> maybe "" (("="<>) . showDate) (tdate2 t)
|
||||
status | tstatus t == Cleared = " *"
|
||||
| tstatus t == Pending = " !"
|
||||
| otherwise = ""
|
||||
code = if T.null (tcode t) then "" else wrap " (" ")" $ tcode t
|
||||
desc = if T.null d then "" else " " <> d where d = tdescription t
|
||||
(samelinecomment, newlinecomments) =
|
||||
case renderCommentLines (tcomment t) of [] -> ("",[])
|
||||
c:cs -> (c,cs)
|
||||
newline = TB.singleton '\n'
|
||||
|
||||
-- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines.
|
||||
-- The first line (unless empty) will have leading space, subsequent lines will have a larger indent.
|
||||
renderCommentLines :: Text -> [String]
|
||||
renderCommentLines :: Text -> [Text]
|
||||
renderCommentLines t =
|
||||
case lines $ T.unpack t of
|
||||
case T.lines t of
|
||||
[] -> []
|
||||
[l] -> [(commentSpace . comment) l] -- single-line comment
|
||||
[l] -> [commentSpace $ comment l] -- single-line comment
|
||||
("":ls) -> "" : map (lineIndent . comment) ls -- multi-line comment with empty first line
|
||||
(l:ls) -> (commentSpace . comment) l : map (lineIndent . comment) ls
|
||||
(l:ls) -> commentSpace (comment l) : map (lineIndent . comment) ls
|
||||
where
|
||||
comment = ("; "++)
|
||||
comment = ("; "<>)
|
||||
|
||||
-- | Given a transaction and its postings, render the postings, suitable
|
||||
-- for `print` output. Normally this output will be valid journal syntax which
|
||||
@ -214,7 +214,7 @@ renderCommentLines t =
|
||||
-- Posting amounts will be aligned with each other, starting about 4 columns
|
||||
-- beyond the widest account name (see postingAsLines for details).
|
||||
--
|
||||
postingsAsLines :: Bool -> [Posting] -> [String]
|
||||
postingsAsLines :: Bool -> [Posting] -> [Text]
|
||||
postingsAsLines onelineamounts ps = concatMap (postingAsLines False onelineamounts ps) ps
|
||||
|
||||
-- | Render one posting, on one or more lines, suitable for `print` output.
|
||||
@ -236,41 +236,55 @@ postingsAsLines onelineamounts ps = concatMap (postingAsLines False onelineamoun
|
||||
-- increased if needed to match the posting with the longest account name.
|
||||
-- This is used to align the amounts of a transaction's postings.
|
||||
--
|
||||
postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [String]
|
||||
postingAsLines elideamount onelineamounts pstoalignwith p = concat [
|
||||
postingblock
|
||||
++ newlinecomments
|
||||
| postingblock <- postingblocks]
|
||||
postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [Text]
|
||||
postingAsLines elideamount onelineamounts pstoalignwith p =
|
||||
concatMap (++ newlinecomments) postingblocks
|
||||
where
|
||||
postingblocks = [map rstrip $ lines $ concatTopPadded [statusandaccount, " ", amt, assertion, samelinecomment] | amt <- shownAmounts]
|
||||
assertion = maybe "" ((' ':).showBalanceAssertion) $ pbalanceassertion p
|
||||
statusandaccount = lineIndent $ fitString (Just $ minwidth) Nothing False True $ pstatusandacct p
|
||||
where
|
||||
-- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned
|
||||
minwidth = maximum $ map ((2+) . textWidth . T.pack . pacctstr) pstoalignwith
|
||||
pstatusandacct p' = pstatusprefix p' ++ pacctstr p'
|
||||
pstatusprefix p' | null s = ""
|
||||
| otherwise = s ++ " "
|
||||
where s = show $ pstatus p'
|
||||
pacctstr p' = showAccountName Nothing (ptype p') (paccount p')
|
||||
-- This needs to be converted to strict Text in order to strip trailing
|
||||
-- spaces. This adds a small amount of inefficiency, and the only difference
|
||||
-- is whether there are trailing spaces in print (and related) reports. This
|
||||
-- could be removed and we could just keep everything as a Text Builder, but
|
||||
-- would require adding trailing spaces to 42 failing tests.
|
||||
postingblocks = [map T.stripEnd . T.lines . TL.toStrict $
|
||||
render [ alignCell BottomLeft statusandaccount
|
||||
, alignCell BottomLeft " "
|
||||
, Cell BottomLeft [amt]
|
||||
, Cell BottomLeft [assertion]
|
||||
, alignCell BottomLeft samelinecomment
|
||||
]
|
||||
| amt <- shownAmounts]
|
||||
render = renderRow def{tableBorders=False, borderSpaces=False} . Group NoLine . map Header
|
||||
assertion = maybe mempty ((WideBuilder (TB.singleton ' ') 1 <>).showBalanceAssertion) $ pbalanceassertion p
|
||||
statusandaccount = lineIndent . fitText (Just $ minwidth) Nothing False True $ pstatusandacct p
|
||||
where
|
||||
-- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned
|
||||
minwidth = maximum $ map ((2+) . textWidth . pacctstr) pstoalignwith
|
||||
pstatusandacct p' = pstatusprefix p' <> pacctstr p'
|
||||
pstatusprefix p' = case pstatus p' of
|
||||
Unmarked -> ""
|
||||
s -> T.pack (show s) <> " "
|
||||
pacctstr p' = showAccountName Nothing (ptype p') (paccount p')
|
||||
|
||||
-- currently prices are considered part of the amount string when right-aligning amounts
|
||||
shownAmounts
|
||||
| elideamount = [""]
|
||||
| onelineamounts = [fst . showMixedOneLineUnnormalised showAmount (Just amtwidth) Nothing False $ pamount p]
|
||||
| null (amounts $ pamount p) = [""]
|
||||
| otherwise = lines . fst . showMixedUnnormalised showAmount (Just amtwidth) Nothing False $ pamount p
|
||||
| elideamount || null (amounts $ pamount p) = [mempty]
|
||||
| otherwise = showMixedAmountLinesB displayopts $ pamount p
|
||||
where
|
||||
amtwidth = maximum $ 12 : map (snd . showMixedUnnormalised showAmount Nothing Nothing False . pamount) pstoalignwith -- min. 12 for backwards compatibility
|
||||
displayopts = noColour{displayOneLine=onelineamounts, displayMinWidth = Just amtwidth, displayNormalised=False}
|
||||
amtwidth = maximum $ 12 : map (wbWidth . showMixedAmountB displayopts{displayMinWidth=Nothing} . pamount) pstoalignwith -- min. 12 for backwards compatibility
|
||||
|
||||
(samelinecomment, newlinecomments) =
|
||||
case renderCommentLines (pcomment p) of [] -> ("",[])
|
||||
c:cs -> (c,cs)
|
||||
|
||||
-- | Render a balance assertion, as the =[=][*] symbol and expected amount.
|
||||
showBalanceAssertion :: BalanceAssertion -> [Char]
|
||||
showBalanceAssertion :: BalanceAssertion -> WideBuilder
|
||||
showBalanceAssertion BalanceAssertion{..} =
|
||||
"=" ++ ['=' | batotal] ++ ['*' | bainclusive] ++ " " ++ showAmountWithZeroCommodity baamount
|
||||
singleton '=' <> eq <> ast <> singleton ' ' <> showAmountB def{displayZeroCommodity=True} baamount
|
||||
where
|
||||
eq = if batotal then singleton '=' else mempty
|
||||
ast = if bainclusive then singleton '*' else mempty
|
||||
singleton c = WideBuilder (TB.singleton c) 1
|
||||
|
||||
-- | Render a posting, simply. Used in balance assertion errors.
|
||||
-- showPostingLine p =
|
||||
@ -286,33 +300,27 @@ showBalanceAssertion BalanceAssertion{..} =
|
||||
|
||||
-- | Render a posting, at the appropriate width for aligning with
|
||||
-- its siblings if any. Used by the rewrite command.
|
||||
showPostingLines :: Posting -> [String]
|
||||
showPostingLines :: Posting -> [Text]
|
||||
showPostingLines p = postingAsLines False False ps p where
|
||||
ps | Just t <- ptransaction p = tpostings t
|
||||
| otherwise = [p]
|
||||
|
||||
-- | Prepend a suitable indent for a posting (or transaction/posting comment) line.
|
||||
lineIndent :: String -> String
|
||||
lineIndent = (" "++)
|
||||
lineIndent :: Text -> Text
|
||||
lineIndent = (" "<>)
|
||||
|
||||
-- | Prepend the space required before a same-line comment.
|
||||
commentSpace :: String -> String
|
||||
commentSpace = (" "++)
|
||||
commentSpace :: Text -> Text
|
||||
commentSpace = (" "<>)
|
||||
|
||||
-- | Show an account name, clipped to the given width if any, and
|
||||
-- appropriately bracketed/parenthesised for the given posting type.
|
||||
showAccountName :: Maybe Int -> PostingType -> AccountName -> String
|
||||
showAccountName :: Maybe Int -> PostingType -> AccountName -> Text
|
||||
showAccountName w = fmt
|
||||
where
|
||||
fmt RegularPosting = maybe id take w . T.unpack
|
||||
fmt VirtualPosting = parenthesise . maybe id (takeEnd . subtract 2) w . T.unpack
|
||||
fmt BalancedVirtualPosting = bracket . maybe id (takeEnd . subtract 2) w . T.unpack
|
||||
|
||||
parenthesise :: String -> String
|
||||
parenthesise s = "("++s++")"
|
||||
|
||||
bracket :: String -> String
|
||||
bracket s = "["++s++"]"
|
||||
fmt RegularPosting = maybe id T.take w
|
||||
fmt VirtualPosting = wrap "(" ")" . maybe id (T.takeEnd . subtract 2) w
|
||||
fmt BalancedVirtualPosting = wrap "[" "]" . maybe id (T.takeEnd . subtract 2) w
|
||||
|
||||
hasRealPostings :: Transaction -> Bool
|
||||
hasRealPostings = not . null . realPostings
|
||||
@ -427,7 +435,9 @@ transactionBalanceError t errs =
|
||||
|
||||
annotateErrorWithTransaction :: Transaction -> String -> String
|
||||
annotateErrorWithTransaction t s =
|
||||
unlines [showGenericSourcePos $ tsourcepos t, s, rstrip $ showTransaction t]
|
||||
unlines [ showGenericSourcePos $ tsourcepos t, s
|
||||
, T.unpack . T.stripEnd $ showTransaction t
|
||||
]
|
||||
|
||||
-- | Infer up to one missing amount for this transactions's real postings, and
|
||||
-- likewise for its balanced virtual postings, if needed; or return an error
|
||||
@ -678,7 +688,7 @@ tests_Transaction =
|
||||
Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]}
|
||||
(fst <$> inferBalancingAmount M.empty nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` missingamt]}) @?=
|
||||
Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]}
|
||||
|
||||
|
||||
, tests "showTransaction" [
|
||||
test "null transaction" $ showTransaction nulltransaction @?= "0000-01-01\n\n"
|
||||
, test "non-null transaction" $ showTransaction
|
||||
@ -701,7 +711,7 @@ tests_Transaction =
|
||||
}
|
||||
]
|
||||
} @?=
|
||||
unlines
|
||||
T.unlines
|
||||
[ "2012-05-14=2012-05-15 (code) desc ; tcomment1"
|
||||
, " ; tcomment2"
|
||||
, " * a $1.00"
|
||||
@ -727,7 +737,7 @@ tests_Transaction =
|
||||
, posting {paccount = "assets:checking", pamount = Mixed [usd (-47.18)], ptransaction = Just t}
|
||||
]
|
||||
in showTransaction t) @?=
|
||||
(unlines
|
||||
(T.unlines
|
||||
[ "2007-01-28 coopportunity"
|
||||
, " expenses:food:groceries $47.18"
|
||||
, " assets:checking $-47.18"
|
||||
@ -750,7 +760,7 @@ tests_Transaction =
|
||||
[ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18]}
|
||||
, posting {paccount = "assets:checking", pamount = Mixed [usd (-47.19)]}
|
||||
])) @?=
|
||||
(unlines
|
||||
(T.unlines
|
||||
[ "2007-01-28 coopportunity"
|
||||
, " expenses:food:groceries $47.18"
|
||||
, " assets:checking $-47.19"
|
||||
@ -771,7 +781,7 @@ tests_Transaction =
|
||||
""
|
||||
[]
|
||||
[posting {paccount = "expenses:food:groceries", pamount = missingmixedamt}])) @?=
|
||||
(unlines ["2007-01-28 coopportunity", " expenses:food:groceries", ""])
|
||||
(T.unlines ["2007-01-28 coopportunity", " expenses:food:groceries", ""])
|
||||
, test "show a transaction with a priced commodityless amount" $
|
||||
(showTransaction
|
||||
(txnTieKnot $
|
||||
@ -789,7 +799,7 @@ tests_Transaction =
|
||||
[ posting {paccount = "a", pamount = Mixed [num 1 `at` (usd 2 `withPrecision` Precision 0)]}
|
||||
, posting {paccount = "b", pamount = missingmixedamt}
|
||||
])) @?=
|
||||
(unlines ["2010-01-01 x", " a 1 @ $2", " b", ""])
|
||||
(T.unlines ["2010-01-01 x", " a 1 @ $2", " b", ""])
|
||||
]
|
||||
, tests "balanceTransaction" [
|
||||
test "detect unbalanced entry, sign error" $
|
||||
|
@ -26,7 +26,7 @@ import Hledger.Data.Amount
|
||||
import Hledger.Data.Transaction
|
||||
import Hledger.Query
|
||||
import Hledger.Data.Posting (commentJoin, commentAddTag)
|
||||
import Hledger.Utils.Debug
|
||||
import Hledger.Utils
|
||||
|
||||
-- $setup
|
||||
-- >>> :set -XOverloadedStrings
|
||||
@ -62,7 +62,8 @@ modifyTransactions d tmods ts = do
|
||||
-- postings when certain other postings are present.
|
||||
--
|
||||
-- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]}
|
||||
-- >>> test = either putStr (putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction nulldate
|
||||
-- >>> import qualified Data.Text.IO as T
|
||||
-- >>> test = either putStr (T.putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction nulldate
|
||||
-- >>> test $ TransactionModifier "" ["pong" `post` usd 2]
|
||||
-- 0000-01-01
|
||||
-- ping $1.00
|
||||
@ -137,7 +138,7 @@ postingRuleMultiplier p =
|
||||
renderPostingCommentDates :: Posting -> Posting
|
||||
renderPostingCommentDates p = p { pcomment = comment' }
|
||||
where
|
||||
dates = T.concat $ catMaybes [T.pack . showDate <$> pdate p, ("=" <>) . T.pack . showDate <$> pdate2 p]
|
||||
dates = T.concat $ catMaybes [showDate <$> pdate p, ("=" <>) . showDate <$> pdate2 p]
|
||||
comment'
|
||||
| T.null dates = pcomment p
|
||||
| otherwise = ("[" <> dates <> "]") `commentJoin` pcomment p
|
||||
| otherwise = (wrap "[" "]" dates) `commentJoin` pcomment p
|
||||
|
@ -66,6 +66,7 @@ import Data.Maybe (fromMaybe, isJust, mapMaybe)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Monoid ((<>))
|
||||
#endif
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar (Day, fromGregorian )
|
||||
import Safe (readDef, readMay, maximumByMay, maximumMay, minimumMay)
|
||||
@ -107,11 +108,11 @@ data Query = Any -- ^ always match
|
||||
instance Default Query where def = Any
|
||||
|
||||
-- | Construct a payee tag
|
||||
payeeTag :: Maybe String -> Either RegexError Query
|
||||
payeeTag :: Maybe Text -> Either RegexError Query
|
||||
payeeTag = fmap (Tag (toRegexCI' "payee")) . maybe (pure Nothing) (fmap Just . toRegexCI)
|
||||
|
||||
-- | Construct a note tag
|
||||
noteTag :: Maybe String -> Either RegexError Query
|
||||
noteTag :: Maybe Text -> Either RegexError Query
|
||||
noteTag = fmap (Tag (toRegexCI' "note")) . maybe (pure Nothing) (fmap Just . toRegexCI)
|
||||
|
||||
-- | Construct a generated-transaction tag
|
||||
@ -262,11 +263,11 @@ parseQueryTerm d (T.stripPrefix "not:" -> Just s) =
|
||||
Right (Left m) -> Right $ Left $ Not m
|
||||
Right (Right _) -> Right $ Left Any -- not:somequeryoption will be ignored
|
||||
Left err -> Left err
|
||||
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left . Code <$> toRegexCI (T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left . Desc <$> toRegexCI (T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Left <$> payeeTag (Just $ T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left <$> noteTag (Just $ T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI (T.unpack s)
|
||||
parseQueryTerm _ (T.stripPrefix "code:" -> Just s) = Left . Code <$> toRegexCI s
|
||||
parseQueryTerm _ (T.stripPrefix "desc:" -> Just s) = Left . Desc <$> toRegexCI s
|
||||
parseQueryTerm _ (T.stripPrefix "payee:" -> Just s) = Left <$> payeeTag (Just s)
|
||||
parseQueryTerm _ (T.stripPrefix "note:" -> Just s) = Left <$> noteTag (Just s)
|
||||
parseQueryTerm _ (T.stripPrefix "acct:" -> Just s) = Left . Acct <$> toRegexCI s
|
||||
parseQueryTerm d (T.stripPrefix "date2:" -> Just s) =
|
||||
case parsePeriodExpr d s of Left e -> Left $ "\"date2:"++T.unpack s++"\" gave a "++showDateParseError e
|
||||
Right (_,span) -> Right $ Left $ Date2 span
|
||||
@ -283,7 +284,7 @@ parseQueryTerm _ (T.stripPrefix "depth:" -> Just s)
|
||||
| otherwise = Left "depth: should have a positive number"
|
||||
where n = readDef 0 (T.unpack s)
|
||||
|
||||
parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left . Sym <$> toRegexCI ('^' : T.unpack s ++ "$") -- support cur: as an alias
|
||||
parseQueryTerm _ (T.stripPrefix "cur:" -> Just s) = Left . Sym <$> toRegexCI ("^" <> s <> "$") -- support cur: as an alias
|
||||
parseQueryTerm _ (T.stripPrefix "tag:" -> Just s) = Left <$> parseTag s
|
||||
parseQueryTerm _ "" = Right $ Left $ Any
|
||||
parseQueryTerm d s = parseQueryTerm d $ defaultprefix<>":"<>s
|
||||
@ -322,20 +323,19 @@ parseAmountQueryTerm amtarg =
|
||||
(parse ">" -> Just q) -> Right (AbsGt ,q)
|
||||
(parse "=" -> Just q) -> Right (AbsEq ,q)
|
||||
(parse "" -> Just q) -> Right (AbsEq ,q)
|
||||
_ -> Left $
|
||||
"could not parse as a comparison operator followed by an optionally-signed number: "
|
||||
++ T.unpack amtarg
|
||||
_ -> Left . T.unpack $
|
||||
"could not parse as a comparison operator followed by an optionally-signed number: " <> amtarg
|
||||
where
|
||||
-- Strip outer whitespace from the text, require and remove the
|
||||
-- specified prefix, remove all whitespace from the remainder, and
|
||||
-- read it as a simple integer or decimal if possible.
|
||||
parse :: T.Text -> T.Text -> Maybe Quantity
|
||||
parse p s = (T.stripPrefix p . T.strip) s >>= readMay . filter (not.(==' ')) . T.unpack
|
||||
parse p s = (T.stripPrefix p . T.strip) s >>= readMay . T.unpack . T.filter (/=' ')
|
||||
|
||||
parseTag :: T.Text -> Either RegexError Query
|
||||
parseTag s = do
|
||||
tag <- toRegexCI . T.unpack $ if T.null v then s else n
|
||||
body <- if T.null v then pure Nothing else Just <$> toRegexCI (tail $ T.unpack v)
|
||||
tag <- toRegexCI $ if T.null v then s else n
|
||||
body <- if T.null v then pure Nothing else Just <$> toRegexCI (T.tail v)
|
||||
return $ Tag tag body
|
||||
where (n,v) = T.break (=='=') s
|
||||
|
||||
@ -554,7 +554,7 @@ matchesAccount (None) _ = False
|
||||
matchesAccount (Not m) a = not $ matchesAccount m a
|
||||
matchesAccount (Or ms) a = any (`matchesAccount` a) ms
|
||||
matchesAccount (And ms) a = all (`matchesAccount` a) ms
|
||||
matchesAccount (Acct r) a = regexMatch r $ T.unpack a -- XXX pack
|
||||
matchesAccount (Acct r) a = regexMatchText r a
|
||||
matchesAccount (Depth d) a = accountNameLevel a <= d
|
||||
matchesAccount (Tag _ _) _ = False
|
||||
matchesAccount _ _ = True
|
||||
@ -564,7 +564,7 @@ matchesMixedAmount q (Mixed []) = q `matchesAmount` nullamt
|
||||
matchesMixedAmount q (Mixed as) = any (q `matchesAmount`) as
|
||||
|
||||
matchesCommodity :: Query -> CommoditySymbol -> Bool
|
||||
matchesCommodity (Sym r) = regexMatch r . T.unpack
|
||||
matchesCommodity (Sym r) = regexMatchText r
|
||||
matchesCommodity _ = const True
|
||||
|
||||
-- | Does the match expression match this (simple) amount ?
|
||||
@ -603,10 +603,10 @@ matchesPosting (Any) _ = True
|
||||
matchesPosting (None) _ = False
|
||||
matchesPosting (Or qs) p = any (`matchesPosting` p) qs
|
||||
matchesPosting (And qs) p = all (`matchesPosting` p) qs
|
||||
matchesPosting (Code r) p = regexMatch r $ maybe "" (T.unpack . tcode) $ ptransaction p
|
||||
matchesPosting (Desc r) p = regexMatch r $ maybe "" (T.unpack . tdescription) $ ptransaction p
|
||||
matchesPosting (Code r) p = maybe False (regexMatchText r . tcode) $ ptransaction p
|
||||
matchesPosting (Desc r) p = maybe False (regexMatchText r . tdescription) $ ptransaction p
|
||||
matchesPosting (Acct r) p = matches p || matches (originalPosting p)
|
||||
where matches p = regexMatch r . T.unpack $ paccount p -- XXX pack
|
||||
where matches = regexMatchText r . paccount
|
||||
matchesPosting (Date span) p = span `spanContainsDate` postingDate p
|
||||
matchesPosting (Date2 span) p = span `spanContainsDate` postingDate2 p
|
||||
matchesPosting (StatusQ s) p = postingStatus p == s
|
||||
@ -615,8 +615,8 @@ matchesPosting q@(Depth _) Posting{paccount=a} = q `matchesAccount` a
|
||||
matchesPosting q@(Amt _ _) Posting{pamount=amt} = q `matchesMixedAmount` amt
|
||||
matchesPosting (Sym r) Posting{pamount=Mixed as} = any (matchesCommodity (Sym r)) $ map acommodity as
|
||||
matchesPosting (Tag n v) p = case (reString n, v) of
|
||||
("payee", Just v) -> maybe False (regexMatch v . T.unpack . transactionPayee) $ ptransaction p
|
||||
("note", Just v) -> maybe False (regexMatch v . T.unpack . transactionNote) $ ptransaction p
|
||||
("payee", Just v) -> maybe False (regexMatchText v . transactionPayee) $ ptransaction p
|
||||
("note", Just v) -> maybe False (regexMatchText v . transactionNote) $ ptransaction p
|
||||
(_, v) -> matchesTags n v $ postingAllTags p
|
||||
|
||||
-- | Does the match expression match this transaction ?
|
||||
@ -626,8 +626,8 @@ matchesTransaction (Any) _ = True
|
||||
matchesTransaction (None) _ = False
|
||||
matchesTransaction (Or qs) t = any (`matchesTransaction` t) qs
|
||||
matchesTransaction (And qs) t = all (`matchesTransaction` t) qs
|
||||
matchesTransaction (Code r) t = regexMatch r $ T.unpack $ tcode t
|
||||
matchesTransaction (Desc r) t = regexMatch r $ T.unpack $ tdescription t
|
||||
matchesTransaction (Code r) t = regexMatchText r $ tcode t
|
||||
matchesTransaction (Desc r) t = regexMatchText r $ tdescription t
|
||||
matchesTransaction q@(Acct _) t = any (q `matchesPosting`) $ tpostings t
|
||||
matchesTransaction (Date span) t = spanContainsDate span $ tdate t
|
||||
matchesTransaction (Date2 span) t = spanContainsDate span $ transactionDate2 t
|
||||
@ -637,15 +637,15 @@ matchesTransaction q@(Amt _ _) t = any (q `matchesPosting`) $ tpostings t
|
||||
matchesTransaction (Depth d) t = any (Depth d `matchesPosting`) $ tpostings t
|
||||
matchesTransaction q@(Sym _) t = any (q `matchesPosting`) $ tpostings t
|
||||
matchesTransaction (Tag n v) t = case (reString n, v) of
|
||||
("payee", Just v) -> regexMatch v . T.unpack . transactionPayee $ t
|
||||
("note", Just v) -> regexMatch v . T.unpack . transactionNote $ t
|
||||
("payee", Just v) -> regexMatchText v $ transactionPayee t
|
||||
("note", Just v) -> regexMatchText v $ transactionNote t
|
||||
(_, v) -> matchesTags n v $ transactionAllTags t
|
||||
|
||||
-- | Does the query match the name and optionally the value of any of these tags ?
|
||||
matchesTags :: Regexp -> Maybe Regexp -> [Tag] -> Bool
|
||||
matchesTags namepat valuepat = not . null . filter (matches namepat valuepat)
|
||||
where
|
||||
matches npat vpat (n,v) = regexMatch npat (T.unpack n) && maybe (const True) regexMatch vpat (T.unpack v)
|
||||
matches npat vpat (n,v) = regexMatchText npat n && maybe (const True) regexMatchText vpat v
|
||||
|
||||
-- | Does the query match this market price ?
|
||||
matchesPriceDirective :: Query -> PriceDirective -> Bool
|
||||
|
@ -11,8 +11,9 @@ to import modules below this one.
|
||||
-}
|
||||
|
||||
--- ** language
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
--- ** exports
|
||||
@ -53,9 +54,13 @@ import Data.List (group, sort, sortBy)
|
||||
import Data.List.NonEmpty (nonEmpty)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Ord (comparing)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import Data.Semigroup (sconcat)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Time (Day)
|
||||
import Safe (headDef)
|
||||
import System.Directory (doesFileExist, getHomeDirectory)
|
||||
@ -63,8 +68,7 @@ import System.Environment (getEnv)
|
||||
import System.Exit (exitFailure)
|
||||
import System.FilePath ((<.>), (</>), splitDirectories, splitFileName)
|
||||
import System.Info (os)
|
||||
import System.IO (stderr, writeFile)
|
||||
import Text.Printf (hPrintf, printf)
|
||||
import System.IO (hPutStr, stderr)
|
||||
|
||||
import Hledger.Data.Dates (getCurrentDay, parsedateM, showDate)
|
||||
import Hledger.Data.Types
|
||||
@ -191,9 +195,9 @@ requireJournalFileExists "-" = return ()
|
||||
requireJournalFileExists f = do
|
||||
exists <- doesFileExist f
|
||||
when (not exists) $ do -- XXX might not be a journal file
|
||||
hPrintf stderr "The hledger journal file \"%s\" was not found.\n" f
|
||||
hPrintf stderr "Please create it first, eg with \"hledger add\" or a text editor.\n"
|
||||
hPrintf stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n"
|
||||
hPutStr stderr $ "The hledger journal file \"" <> show f <> "\" was not found.\n"
|
||||
hPutStr stderr "Please create it first, eg with \"hledger add\" or a text editor.\n"
|
||||
hPutStr stderr "Or, specify an existing journal file with -f or LEDGER_FILE.\n"
|
||||
exitFailure
|
||||
|
||||
-- | Ensure there is a journal file at the given path, creating an empty one if needed.
|
||||
@ -202,14 +206,14 @@ requireJournalFileExists f = do
|
||||
ensureJournalFileExists :: FilePath -> IO ()
|
||||
ensureJournalFileExists f = do
|
||||
when (os/="mingw32" && isWindowsUnsafeDotPath f) $ do
|
||||
hPrintf stderr "Part of file path %s\n ends with a dot, which is unsafe on Windows; please use a different path.\n" (show f)
|
||||
hPutStr stderr $ "Part of file path \"" <> show f <> "\"\n ends with a dot, which is unsafe on Windows; please use a different path.\n"
|
||||
exitFailure
|
||||
exists <- doesFileExist f
|
||||
when (not exists) $ do
|
||||
hPrintf stderr "Creating hledger journal file %s.\n" f
|
||||
hPutStr stderr $ "Creating hledger journal file " <> show f <> ".\n"
|
||||
-- note Hledger.Utils.UTF8.* do no line ending conversion on windows,
|
||||
-- we currently require unix line endings on all platforms.
|
||||
newJournalContent >>= writeFile f
|
||||
newJournalContent >>= T.writeFile f
|
||||
|
||||
-- | Does any part of this path contain non-. characters and end with a . ?
|
||||
-- Such paths are not safe to use on Windows (cf #1056).
|
||||
@ -221,10 +225,10 @@ isWindowsUnsafeDotPath =
|
||||
splitDirectories
|
||||
|
||||
-- | Give the content for a new auto-created journal file.
|
||||
newJournalContent :: IO String
|
||||
newJournalContent :: IO Text
|
||||
newJournalContent = do
|
||||
d <- getCurrentDay
|
||||
return $ printf "; journal created %s by hledger\n" (show d)
|
||||
return $ "; journal created " <> T.pack (show d) <> " by hledger\n"
|
||||
|
||||
-- A "LatestDates" is zero or more copies of the same date,
|
||||
-- representing the latest transaction date read from a file,
|
||||
@ -240,7 +244,7 @@ latestDates = headDef [] . take 1 . group . reverse . sort
|
||||
-- | Remember that these transaction dates were the latest seen when
|
||||
-- reading this journal file.
|
||||
saveLatestDates :: LatestDates -> FilePath -> IO ()
|
||||
saveLatestDates dates f = writeFile (latestDatesFileFor f) $ unlines $ map showDate dates
|
||||
saveLatestDates dates f = T.writeFile (latestDatesFileFor f) $ T.unlines $ map showDate dates
|
||||
|
||||
-- | What were the latest transaction dates seen the last time this
|
||||
-- journal file was read ? If there were multiple transactions on the
|
||||
|
@ -379,11 +379,11 @@ journalCheckPayeesDeclared j = sequence_ $ map checkpayee $ jtxns j
|
||||
where
|
||||
checkpayee t
|
||||
| p `elem` ps = Right ()
|
||||
| otherwise = Left $
|
||||
| otherwise = Left $
|
||||
printf "undeclared payee \"%s\"\nat: %s\n\n%s"
|
||||
(T.unpack p)
|
||||
(T.unpack p)
|
||||
(showGenericSourcePos $ tsourcepos t)
|
||||
(linesPrepend2 "> " " " $ chomp1 $ showTransaction t)
|
||||
(linesPrepend2 "> " " " . (<>"\n") . textChomp $ showTransaction t)
|
||||
where
|
||||
p = transactionPayee t
|
||||
ps = journalPayeesDeclared j
|
||||
@ -397,11 +397,11 @@ journalCheckAccountsDeclared j = sequence_ $ map checkacct $ journalPostings j
|
||||
| paccount `elem` as = Right ()
|
||||
| otherwise = Left $
|
||||
(printf "undeclared account \"%s\"\n" (T.unpack paccount))
|
||||
++ case ptransaction of
|
||||
++ case ptransaction of
|
||||
Nothing -> ""
|
||||
Just t -> printf "in transaction at: %s\n\n%s"
|
||||
(showGenericSourcePos $ tsourcepos t)
|
||||
(linesPrepend " " $ chomp1 $ showTransaction t)
|
||||
(linesPrepend " " . (<>"\n") . textChomp $ showTransaction t)
|
||||
where
|
||||
as = journalAccountNamesDeclared j
|
||||
|
||||
@ -416,13 +416,13 @@ journalCheckCommoditiesDeclared j =
|
||||
Nothing -> Right ()
|
||||
Just c -> Left $
|
||||
(printf "undeclared commodity \"%s\"\n" (T.unpack c))
|
||||
++ case ptransaction of
|
||||
++ case ptransaction of
|
||||
Nothing -> ""
|
||||
Just t -> printf "in transaction at: %s\n\n%s"
|
||||
(showGenericSourcePos $ tsourcepos t)
|
||||
(linesPrepend " " $ chomp1 $ showTransaction t)
|
||||
(linesPrepend " " . (<>"\n") . textChomp $ showTransaction t)
|
||||
where
|
||||
mfirstundeclaredcomm =
|
||||
mfirstundeclaredcomm =
|
||||
headMay $ filter (not . (`elem` cs)) $ catMaybes $
|
||||
(acommodity . baamount <$> pbalanceassertion) :
|
||||
(map (Just . acommodity) . filter (/= missingamt) $ amounts pamount)
|
||||
@ -1144,7 +1144,7 @@ digitgroupp :: TextParser m DigitGrp
|
||||
digitgroupp = label "digits"
|
||||
$ makeGroup <$> takeWhile1P (Just "digit") isDigit
|
||||
where
|
||||
makeGroup = uncurry DigitGrp . foldl' step (0, 0) . T.unpack
|
||||
makeGroup = uncurry DigitGrp . T.foldl' step (0, 0)
|
||||
step (!l, !a) c = (l+1, a*10 + fromIntegral (digitToInt c))
|
||||
|
||||
--- *** comments
|
||||
@ -1483,7 +1483,7 @@ regexaliasp = do
|
||||
char '='
|
||||
skipNonNewlineSpaces
|
||||
repl <- anySingle `manyTill` eolof
|
||||
case toRegexCI re of
|
||||
case toRegexCI $ T.pack re of
|
||||
Right r -> return $! RegexAlias r repl
|
||||
Left e -> customFailure $! parseErrorAtRegion off1 off2 e
|
||||
|
||||
|
@ -11,17 +11,17 @@ A reader for CSV data, using an extra rules file to help interpret the data.
|
||||
-- stack haddock hledger-lib --fast --no-haddock-deps --haddock-arguments='--ignore-all-exports' --open
|
||||
|
||||
--- ** language
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiWayIf #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PackageImports #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
--- ** exports
|
||||
module Hledger.Read.CsvReader (
|
||||
@ -52,7 +52,6 @@ import Control.Monad.Trans.Class (lift)
|
||||
import Data.Char (toLower, isDigit, isSpace, isAlphaNum, isAscii, ord)
|
||||
import Data.Bifunctor (first)
|
||||
import "base-compat-batteries" Data.List.Compat
|
||||
import qualified Data.List.Split as LS (splitOn)
|
||||
import Data.Maybe (catMaybes, fromMaybe, isJust)
|
||||
import Data.MemoUgly (memo)
|
||||
import Data.Ord (comparing)
|
||||
@ -61,6 +60,8 @@ import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import qualified Data.Text.IO as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import Data.Time.Calendar (Day)
|
||||
import Data.Time.Format (parseTimeM, defaultTimeLocale)
|
||||
import Safe (atMay, headMay, lastMay, readDef, readMay)
|
||||
@ -88,7 +89,7 @@ import Hledger.Read.Common (aliasesFromOpts, Reader(..),InputOpts(..), amountp,
|
||||
|
||||
type CSV = [CsvRecord]
|
||||
type CsvRecord = [CsvValue]
|
||||
type CsvValue = String
|
||||
type CsvValue = Text
|
||||
|
||||
--- ** reader
|
||||
|
||||
@ -164,7 +165,7 @@ defaultRulesText csvfile = T.pack $ unlines
|
||||
," account2 assets:bank:savings\n"
|
||||
]
|
||||
|
||||
addDirective :: (DirectiveName, String) -> CsvRulesParsed -> CsvRulesParsed
|
||||
addDirective :: (DirectiveName, Text) -> CsvRulesParsed -> CsvRulesParsed
|
||||
addDirective d r = r{rdirectives=d:rdirectives r}
|
||||
|
||||
addAssignment :: (HledgerFieldName, FieldTemplate) -> CsvRulesParsed -> CsvRulesParsed
|
||||
@ -181,7 +182,7 @@ addAssignmentsFromList fs r = foldl' maybeAddAssignment r journalfieldnames
|
||||
where
|
||||
maybeAddAssignment rules f = (maybe id addAssignmentFromIndex $ elemIndex f fs) rules
|
||||
where
|
||||
addAssignmentFromIndex i = addAssignment (f, "%"++show (i+1))
|
||||
addAssignmentFromIndex i = addAssignment (f, T.pack $ '%':show (i+1))
|
||||
|
||||
addConditionalBlock :: ConditionalBlock -> CsvRulesParsed -> CsvRulesParsed
|
||||
addConditionalBlock b r = r{rconditionalblocks=b:rconditionalblocks r}
|
||||
@ -205,7 +206,7 @@ expandIncludes dir content = mapM (expandLine dir) (T.lines content) >>= return
|
||||
case line of
|
||||
(T.stripPrefix "include " -> Just f) -> expandIncludes dir' =<< T.readFile f'
|
||||
where
|
||||
f' = dir </> dropWhile isSpace (T.unpack f)
|
||||
f' = dir </> T.unpack (T.dropWhile isSpace f)
|
||||
dir' = takeDirectory f'
|
||||
_ -> return line
|
||||
|
||||
@ -240,7 +241,7 @@ validateRules rules = do
|
||||
-- | A set of data definitions and account-matching patterns sufficient to
|
||||
-- convert a particular CSV data file into meaningful journal transactions.
|
||||
data CsvRules' a = CsvRules' {
|
||||
rdirectives :: [(DirectiveName,String)],
|
||||
rdirectives :: [(DirectiveName,Text)],
|
||||
-- ^ top-level rules, as (keyword, value) pairs
|
||||
rcsvfieldindexes :: [(CsvFieldName, CsvFieldIndex)],
|
||||
-- ^ csv field names and their column number, if declared by a fields list
|
||||
@ -260,7 +261,7 @@ type CsvRulesParsed = CsvRules' ()
|
||||
-- | Type used after parsing is done. Directives, assignments and conditional blocks
|
||||
-- are in the same order as they were in the unput file and rblocksassigning is functional.
|
||||
-- Ready to be used for CSV record processing
|
||||
type CsvRules = CsvRules' (String -> [ConditionalBlock])
|
||||
type CsvRules = CsvRules' (Text -> [ConditionalBlock])
|
||||
|
||||
instance Eq CsvRules where
|
||||
r1 == r2 = (rdirectives r1, rcsvfieldindexes r1, rassignments r1) ==
|
||||
@ -277,27 +278,27 @@ instance Show CsvRules where
|
||||
type CsvRulesParser a = StateT CsvRulesParsed SimpleTextParser a
|
||||
|
||||
-- | The keyword of a CSV rule - "fields", "skip", "if", etc.
|
||||
type DirectiveName = String
|
||||
type DirectiveName = Text
|
||||
|
||||
-- | CSV field name.
|
||||
type CsvFieldName = String
|
||||
type CsvFieldName = Text
|
||||
|
||||
-- | 1-based CSV column number.
|
||||
type CsvFieldIndex = Int
|
||||
|
||||
-- | Percent symbol followed by a CSV field name or column number. Eg: %date, %1.
|
||||
type CsvFieldReference = String
|
||||
type CsvFieldReference = Text
|
||||
|
||||
-- | One of the standard hledger fields or pseudo-fields that can be assigned to.
|
||||
-- Eg date, account1, amount, amount1-in, date-format.
|
||||
type HledgerFieldName = String
|
||||
type HledgerFieldName = Text
|
||||
|
||||
-- | A text value to be assigned to a hledger field, possibly
|
||||
-- containing csv field references to be interpolated.
|
||||
type FieldTemplate = String
|
||||
type FieldTemplate = Text
|
||||
|
||||
-- | A strptime date parsing pattern, as supported by Data.Time.Format.
|
||||
type DateFormat = String
|
||||
type DateFormat = Text
|
||||
|
||||
-- | A prefix for a matcher test, either & or none (implicit or).
|
||||
data MatcherPrefix = And | None
|
||||
@ -453,16 +454,16 @@ commentlinep = lift skipNonNewlineSpaces >> commentcharp >> lift restofline >> r
|
||||
commentcharp :: CsvRulesParser Char
|
||||
commentcharp = oneOf (";#*" :: [Char])
|
||||
|
||||
directivep :: CsvRulesParser (DirectiveName, String)
|
||||
directivep :: CsvRulesParser (DirectiveName, Text)
|
||||
directivep = (do
|
||||
lift $ dbgparse 8 "trying directive"
|
||||
d <- fmap T.unpack $ choiceInState $ map (lift . string . T.pack) directives
|
||||
d <- choiceInState $ map (lift . string) directives
|
||||
v <- (((char ':' >> lift (many spacenonewline)) <|> lift (some spacenonewline)) >> directivevalp)
|
||||
<|> (optional (char ':') >> lift skipNonNewlineSpaces >> lift eolof >> return "")
|
||||
return (d, v)
|
||||
) <?> "directive"
|
||||
|
||||
directives :: [String]
|
||||
directives :: [Text]
|
||||
directives =
|
||||
["date-format"
|
||||
,"decimal-mark"
|
||||
@ -474,8 +475,8 @@ directives =
|
||||
, "balance-type"
|
||||
]
|
||||
|
||||
directivevalp :: CsvRulesParser String
|
||||
directivevalp = anySingle `manyTill` lift eolof
|
||||
directivevalp :: CsvRulesParser Text
|
||||
directivevalp = T.pack <$> anySingle `manyTill` lift eolof
|
||||
|
||||
fieldnamelistp :: CsvRulesParser [CsvFieldName]
|
||||
fieldnamelistp = (do
|
||||
@ -487,21 +488,18 @@ fieldnamelistp = (do
|
||||
f <- fromMaybe "" <$> optional fieldnamep
|
||||
fs <- some $ (separator >> fromMaybe "" <$> optional fieldnamep)
|
||||
lift restofline
|
||||
return $ map (map toLower) $ f:fs
|
||||
return . map T.toLower $ f:fs
|
||||
) <?> "field name list"
|
||||
|
||||
fieldnamep :: CsvRulesParser String
|
||||
fieldnamep :: CsvRulesParser Text
|
||||
fieldnamep = quotedfieldnamep <|> barefieldnamep
|
||||
|
||||
quotedfieldnamep :: CsvRulesParser String
|
||||
quotedfieldnamep = do
|
||||
char '"'
|
||||
f <- some $ noneOf ("\"\n:;#~" :: [Char])
|
||||
char '"'
|
||||
return f
|
||||
quotedfieldnamep :: CsvRulesParser Text
|
||||
quotedfieldnamep =
|
||||
char '"' *> takeWhile1P Nothing (`notElem` ("\"\n:;#~" :: [Char])) <* char '"'
|
||||
|
||||
barefieldnamep :: CsvRulesParser String
|
||||
barefieldnamep = some $ noneOf (" \t\n,;#~" :: [Char])
|
||||
barefieldnamep :: CsvRulesParser Text
|
||||
barefieldnamep = takeWhile1P Nothing (`notElem` (" \t\n,;#~" :: [Char]))
|
||||
|
||||
fieldassignmentp :: CsvRulesParser (HledgerFieldName, FieldTemplate)
|
||||
fieldassignmentp = do
|
||||
@ -513,10 +511,10 @@ fieldassignmentp = do
|
||||
return (f,v)
|
||||
<?> "field assignment"
|
||||
|
||||
journalfieldnamep :: CsvRulesParser String
|
||||
journalfieldnamep :: CsvRulesParser Text
|
||||
journalfieldnamep = do
|
||||
lift (dbgparse 8 "trying journalfieldnamep")
|
||||
T.unpack <$> choiceInState (map (lift . string . T.pack) journalfieldnames)
|
||||
choiceInState $ map (lift . string) journalfieldnames
|
||||
|
||||
maxpostings = 99
|
||||
|
||||
@ -524,14 +522,14 @@ maxpostings = 99
|
||||
-- Names must precede any other name they contain, for the parser
|
||||
-- (amount-in before amount; date2 before date). TODO: fix
|
||||
journalfieldnames =
|
||||
concat [[ "account" ++ i
|
||||
,"amount" ++ i ++ "-in"
|
||||
,"amount" ++ i ++ "-out"
|
||||
,"amount" ++ i
|
||||
,"balance" ++ i
|
||||
,"comment" ++ i
|
||||
,"currency" ++ i
|
||||
] | x <- [maxpostings, (maxpostings-1)..1], let i = show x]
|
||||
concat [[ "account" <> i
|
||||
,"amount" <> i <> "-in"
|
||||
,"amount" <> i <> "-out"
|
||||
,"amount" <> i
|
||||
,"balance" <> i
|
||||
,"comment" <> i
|
||||
,"currency" <> i
|
||||
] | x <- [maxpostings, (maxpostings-1)..1], let i = T.pack $ show x]
|
||||
++
|
||||
["amount-in"
|
||||
,"amount-out"
|
||||
@ -556,10 +554,10 @@ assignmentseparatorp = do
|
||||
]
|
||||
return ()
|
||||
|
||||
fieldvalp :: CsvRulesParser String
|
||||
fieldvalp :: CsvRulesParser Text
|
||||
fieldvalp = do
|
||||
lift $ dbgparse 8 "trying fieldvalp"
|
||||
anySingle `manyTill` lift eolof
|
||||
T.pack <$> anySingle `manyTill` lift eolof
|
||||
|
||||
-- A conditional block: one or more matchers, one per line, followed by one or more indented rules.
|
||||
conditionalblockp :: CsvRulesParser ConditionalBlock
|
||||
@ -587,14 +585,14 @@ conditionaltablep :: CsvRulesParser [ConditionalBlock]
|
||||
conditionaltablep = do
|
||||
lift $ dbgparse 8 "trying conditionaltablep"
|
||||
start <- getOffset
|
||||
string "if"
|
||||
string "if"
|
||||
sep <- lift $ satisfy (\c -> not (isAlphaNum c || isSpace c))
|
||||
fields <- journalfieldnamep `sepBy1` (char sep)
|
||||
newline
|
||||
body <- flip manyTill (lift eolof) $ do
|
||||
off <- getOffset
|
||||
m <- matcherp' (char sep >> return ())
|
||||
vs <- LS.splitOn [sep] <$> lift restofline
|
||||
vs <- T.split (==sep) . T.pack <$> lift restofline
|
||||
if (length vs /= length fields)
|
||||
then customFailure $ parseErrorAt off $ ((printf "line of conditional table should have %d values, but this one has only %d\n" (length fields) (length vs)) :: String)
|
||||
else return (m,vs)
|
||||
@ -655,8 +653,7 @@ csvfieldreferencep :: CsvRulesParser CsvFieldReference
|
||||
csvfieldreferencep = do
|
||||
lift $ dbgparse 8 "trying csvfieldreferencep"
|
||||
char '%'
|
||||
f <- fieldnamep
|
||||
return $ '%' : quoteIfNeeded f
|
||||
T.cons '%' . textQuoteIfNeeded <$> fieldnamep
|
||||
|
||||
-- A single regular expression
|
||||
regexp :: CsvRulesParser () -> CsvRulesParser Regexp
|
||||
@ -665,7 +662,7 @@ regexp end = do
|
||||
-- notFollowedBy matchoperatorp
|
||||
c <- lift nonspace
|
||||
cs <- anySingle `manyTill` end
|
||||
case toRegexCI . strip $ c:cs of
|
||||
case toRegexCI . T.strip . T.pack $ c:cs of
|
||||
Left x -> Fail.fail $ "CSV parser: " ++ x
|
||||
Right x -> return x
|
||||
|
||||
@ -721,7 +718,7 @@ readJournalFromCsv mrulesfile csvfile csvdata =
|
||||
let skiplines = case getDirective "skip" rules of
|
||||
Nothing -> 0
|
||||
Just "" -> 1
|
||||
Just s -> readDef (throwerr $ "could not parse skip value: " ++ show s) s
|
||||
Just s -> readDef (throwerr $ "could not parse skip value: " ++ show s) $ T.unpack s
|
||||
|
||||
-- parse csv
|
||||
let
|
||||
@ -779,18 +776,17 @@ readJournalFromCsv mrulesfile csvfile csvdata =
|
||||
|
||||
when (not rulesfileexists) $ do
|
||||
dbg1IO "creating conversion rules file" rulesfile
|
||||
writeFile rulesfile $ T.unpack rulestext
|
||||
T.writeFile rulesfile rulestext
|
||||
|
||||
return $ Right nulljournal{jtxns=txns''}
|
||||
|
||||
-- | Parse special separator names TAB and SPACE, or return the first
|
||||
-- character. Return Nothing on empty string
|
||||
parseSeparator :: String -> Maybe Char
|
||||
parseSeparator = specials . map toLower
|
||||
parseSeparator :: Text -> Maybe Char
|
||||
parseSeparator = specials . T.toLower
|
||||
where specials "space" = Just ' '
|
||||
specials "tab" = Just '\t'
|
||||
specials (x:_) = Just x
|
||||
specials [] = Nothing
|
||||
specials xs = fst <$> T.uncons xs
|
||||
|
||||
parseCsv :: Char -> FilePath -> Text -> IO (Either String CSV)
|
||||
parseCsv separator filePath csvdata =
|
||||
@ -813,15 +809,13 @@ parseResultToCsv :: (Foldable t, Functor t) => t (t B.ByteString) -> CSV
|
||||
parseResultToCsv = toListList . unpackFields
|
||||
where
|
||||
toListList = toList . fmap toList
|
||||
unpackFields = (fmap . fmap) (T.unpack . T.decodeUtf8)
|
||||
unpackFields = (fmap . fmap) T.decodeUtf8
|
||||
|
||||
printCSV :: CSV -> String
|
||||
printCSV records = unlined (printRecord `map` records)
|
||||
where printRecord = concat . intersperse "," . map printField
|
||||
printField f = "\"" ++ concatMap escape f ++ "\""
|
||||
escape '"' = "\"\""
|
||||
escape x = [x]
|
||||
unlined = concat . intersperse "\n"
|
||||
printCSV :: CSV -> TL.Text
|
||||
printCSV = TB.toLazyText . unlined . map printRecord
|
||||
where printRecord = mconcat . map TB.fromText . intersperse "," . map printField
|
||||
printField = wrap "\"" "\"" . T.replace "\"" "\\\"\\\""
|
||||
unlined = (<> TB.fromText "\n") . mconcat . intersperse "\n"
|
||||
|
||||
-- | Return the cleaned up and validated CSV data (can be empty), or an error.
|
||||
validateCsv :: CsvRules -> Int -> Either String CSV -> Either String [CsvRecord]
|
||||
@ -834,7 +828,7 @@ validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ dr
|
||||
(Nothing, Nothing) -> Nothing
|
||||
(Just _, _) -> Just maxBound
|
||||
(Nothing, Just "") -> Just 1
|
||||
(Nothing, Just x) -> Just (read x)
|
||||
(Nothing, Just x) -> Just (read $ T.unpack x)
|
||||
applyConditionalSkips [] = []
|
||||
applyConditionalSkips (r:rest) =
|
||||
case skipCount r of
|
||||
@ -866,7 +860,7 @@ validateCsv rules numhdrlines (Right rs) = validate $ applyConditionalSkips $ dr
|
||||
--- ** converting csv records to transactions
|
||||
|
||||
showRules rules record =
|
||||
unlines $ catMaybes [ (("the "++fld++" rule is: ")++) <$> getEffectiveAssignment rules record fld | fld <- journalfieldnames]
|
||||
T.unlines $ catMaybes [ (("the "<>fld<>" rule is: ")<>) <$> getEffectiveAssignment rules record fld | fld <- journalfieldnames]
|
||||
|
||||
-- | Look up the value (template) of a csv rule by rule keyword.
|
||||
csvRule :: CsvRules -> DirectiveName -> Maybe FieldTemplate
|
||||
@ -880,7 +874,7 @@ hledgerField = getEffectiveAssignment
|
||||
|
||||
-- | Look up the final value assigned to a hledger field, with csv field
|
||||
-- references interpolated.
|
||||
hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe String
|
||||
hledgerFieldValue :: CsvRules -> CsvRecord -> HledgerFieldName -> Maybe Text
|
||||
hledgerFieldValue rules record = fmap (renderTemplate rules record) . hledgerField rules record
|
||||
|
||||
transactionFromCsvRecord :: SourcePos -> CsvRules -> CsvRecord -> Transaction
|
||||
@ -892,18 +886,18 @@ transactionFromCsvRecord sourcepos rules record = t
|
||||
rule = csvRule rules :: DirectiveName -> Maybe FieldTemplate
|
||||
-- ruleval = csvRuleValue rules record :: DirectiveName -> Maybe String
|
||||
field = hledgerField rules record :: HledgerFieldName -> Maybe FieldTemplate
|
||||
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe String
|
||||
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text
|
||||
parsedate = parseDateWithCustomOrDefaultFormats (rule "date-format")
|
||||
mkdateerror datefield datevalue mdateformat = unlines
|
||||
["error: could not parse \""++datevalue++"\" as a date using date format "
|
||||
++maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" show mdateformat
|
||||
mkdateerror datefield datevalue mdateformat = T.unpack $ T.unlines
|
||||
["error: could not parse \""<>datevalue<>"\" as a date using date format "
|
||||
<>maybe "\"YYYY/M/D\", \"YYYY-M-D\" or \"YYYY.M.D\"" (T.pack . show) mdateformat
|
||||
,showRecord record
|
||||
,"the "++datefield++" rule is: "++(fromMaybe "required, but missing" $ field datefield)
|
||||
,"the date-format is: "++fromMaybe "unspecified" mdateformat
|
||||
,"the "<>datefield<>" rule is: "<>(fromMaybe "required, but missing" $ field datefield)
|
||||
,"the date-format is: "<>fromMaybe "unspecified" mdateformat
|
||||
,"you may need to "
|
||||
++"change your "++datefield++" rule, "
|
||||
++maybe "add a" (const "change your") mdateformat++" date-format rule, "
|
||||
++"or "++maybe "add a" (const "change your") mskip++" skip rule"
|
||||
<>"change your "<>datefield<>" rule, "
|
||||
<>maybe "add a" (const "change your") mdateformat<>" date-format rule, "
|
||||
<>"or "<>maybe "add a" (const "change your") mskip<>" skip rule"
|
||||
,"for m/d/y or d/m/y dates, use date-format %-m/%-d/%Y or date-format %-d/%-m/%Y"
|
||||
]
|
||||
where
|
||||
@ -923,25 +917,27 @@ transactionFromCsvRecord sourcepos rules record = t
|
||||
status =
|
||||
case fieldval "status" of
|
||||
Nothing -> Unmarked
|
||||
Just s -> either statuserror id $ runParser (statusp <* eof) "" $ T.pack s
|
||||
Just s -> either statuserror id $ runParser (statusp <* eof) "" s
|
||||
where
|
||||
statuserror err = error' $ unlines
|
||||
["error: could not parse \""++s++"\" as a cleared status (should be *, ! or empty)"
|
||||
,"the parse error is: "++customErrorBundlePretty err
|
||||
statuserror err = error' . T.unpack $ T.unlines
|
||||
["error: could not parse \""<>s<>"\" as a cleared status (should be *, ! or empty)"
|
||||
,"the parse error is: "<>T.pack (customErrorBundlePretty err)
|
||||
]
|
||||
code = maybe "" singleline $ fieldval "code"
|
||||
description = maybe "" singleline $ fieldval "description"
|
||||
comment = maybe "" singleline $ fieldval "comment"
|
||||
precomment = maybe "" singleline $ fieldval "precomment"
|
||||
|
||||
singleline = T.unwords . filter (not . T.null) . map T.strip . T.lines
|
||||
|
||||
----------------------------------------------------------------------
|
||||
-- 3. Generate the postings for which an account has been assigned
|
||||
-- (possibly indirectly due to an amount or balance assignment)
|
||||
|
||||
p1IsVirtual = (accountNamePostingType . T.pack <$> fieldval "account1") == Just VirtualPosting
|
||||
p1IsVirtual = (accountNamePostingType <$> fieldval "account1") == Just VirtualPosting
|
||||
ps = [p | n <- [1..maxpostings]
|
||||
,let comment = T.pack $ fromMaybe "" $ fieldval ("comment"++show n)
|
||||
,let currency = fromMaybe "" (fieldval ("currency"++show n) <|> fieldval "currency")
|
||||
,let comment = fromMaybe "" $ fieldval ("comment"<> T.pack (show n))
|
||||
,let currency = fromMaybe "" (fieldval ("currency"<> T.pack (show n)) <|> fieldval "currency")
|
||||
,let mamount = getAmount rules record currency p1IsVirtual n
|
||||
,let mbalance = getBalance rules record currency n
|
||||
,Just (acct,isfinal) <- [getAccount rules record mamount mbalance n] -- skips Nothings
|
||||
@ -965,10 +961,10 @@ transactionFromCsvRecord sourcepos rules record = t
|
||||
,tdate = date'
|
||||
,tdate2 = mdate2'
|
||||
,tstatus = status
|
||||
,tcode = T.pack code
|
||||
,tdescription = T.pack description
|
||||
,tcomment = T.pack comment
|
||||
,tprecedingcomment = T.pack precomment
|
||||
,tcode = code
|
||||
,tdescription = description
|
||||
,tcomment = comment
|
||||
,tprecedingcomment = precomment
|
||||
,tpostings = ps
|
||||
}
|
||||
|
||||
@ -979,7 +975,7 @@ transactionFromCsvRecord sourcepos rules record = t
|
||||
-- For postings 1 or 2 it also looks at "amount", "amount-in", "amount-out".
|
||||
-- If more than one of these has a value, it looks for one that is non-zero.
|
||||
-- If there's multiple non-zeros, or no non-zeros but multiple zeros, it throws an error.
|
||||
getAmount :: CsvRules -> CsvRecord -> String -> Bool -> Int -> Maybe MixedAmount
|
||||
getAmount :: CsvRules -> CsvRecord -> Text -> Bool -> Int -> Maybe MixedAmount
|
||||
getAmount rules record currency p1IsVirtual n =
|
||||
-- Warning, many tricky corner cases here.
|
||||
-- docs: hledger_csv.m4.md #### amount
|
||||
@ -988,14 +984,15 @@ getAmount rules record currency p1IsVirtual n =
|
||||
unnumberedfieldnames = ["amount","amount-in","amount-out"]
|
||||
|
||||
-- amount field names which can affect this posting
|
||||
fieldnames = map (("amount"++show n)++) ["","-in","-out"]
|
||||
fieldnames = map (("amount"<> T.pack(show n))<>) ["","-in","-out"]
|
||||
-- For posting 1, also recognise the old amount/amount-in/amount-out names.
|
||||
-- For posting 2, the same but only if posting 1 needs balancing.
|
||||
++ if n==1 || n==2 && not p1IsVirtual then unnumberedfieldnames else []
|
||||
|
||||
-- assignments to any of these field names with non-empty values
|
||||
assignments = [(f,a') | f <- fieldnames
|
||||
, Just v@(_:_) <- [strip . renderTemplate rules record <$> hledgerField rules record f]
|
||||
, Just v <- [T.strip . renderTemplate rules record <$> hledgerField rules record f]
|
||||
, not $ T.null v
|
||||
, let a = parseAmount rules record currency v
|
||||
-- With amount/amount-in/amount-out, in posting 2,
|
||||
-- flip the sign and convert to cost, as they did before 1.17
|
||||
@ -1006,7 +1003,7 @@ getAmount rules record currency p1IsVirtual n =
|
||||
assignments' | any isnumbered assignments = filter isnumbered assignments
|
||||
| otherwise = assignments
|
||||
where
|
||||
isnumbered (f,_) = any (flip elem ['0'..'9']) f
|
||||
isnumbered (f,_) = T.any (flip elem ['0'..'9']) f
|
||||
|
||||
-- if there's more than one value and only some are zeros, discard the zeros
|
||||
assignments''
|
||||
@ -1017,24 +1014,24 @@ getAmount rules record currency p1IsVirtual n =
|
||||
in case -- dbg0 ("amounts for posting "++show n)
|
||||
assignments'' of
|
||||
[] -> Nothing
|
||||
[(f,a)] | "-out" `isSuffixOf` f -> Just (-a) -- for -out fields, flip the sign
|
||||
[(f,a)] | "-out" `T.isSuffixOf` f -> Just (-a) -- for -out fields, flip the sign
|
||||
[(_,a)] -> Just a
|
||||
fs -> error' $ unlines $ [ -- PARTIAL:
|
||||
fs -> error' . T.unpack . T.unlines $ [ -- PARTIAL:
|
||||
"multiple non-zero amounts or multiple zero amounts assigned,"
|
||||
,"please ensure just one. (https://hledger.org/csv.html#amount)"
|
||||
," " ++ showRecord record
|
||||
," for posting: " ++ show n
|
||||
," " <> showRecord record
|
||||
," for posting: " <> T.pack (show n)
|
||||
]
|
||||
++ [" assignment: " ++ f ++ " " ++
|
||||
fromMaybe "" (hledgerField rules record f) ++
|
||||
"\t=> value: " ++ showMixedAmount a -- XXX not sure this is showing all the right info
|
||||
++ [" assignment: " <> f <> " " <>
|
||||
fromMaybe "" (hledgerField rules record f) <>
|
||||
"\t=> value: " <> wbToText (showMixedAmountB noColour a) -- XXX not sure this is showing all the right info
|
||||
| (f,a) <- fs]
|
||||
|
||||
-- | Figure out the expected balance (assertion or assignment) specified for posting N,
|
||||
-- if any (and its parse position).
|
||||
getBalance :: CsvRules -> CsvRecord -> String -> Int -> Maybe (Amount, GenericSourcePos)
|
||||
getBalance :: CsvRules -> CsvRecord -> Text -> Int -> Maybe (Amount, GenericSourcePos)
|
||||
getBalance rules record currency n = do
|
||||
v <- (fieldval ("balance"++show n)
|
||||
v <- (fieldval ("balance"<> T.pack (show n))
|
||||
-- for posting 1, also recognise the old field name
|
||||
<|> if n==1 then fieldval "balance" else Nothing)
|
||||
case v of
|
||||
@ -1043,30 +1040,29 @@ getBalance rules record currency n = do
|
||||
parseBalanceAmount rules record currency n s
|
||||
,nullsourcepos -- parse position to show when assertion fails,
|
||||
) -- XXX the csv record's line number would be good
|
||||
|
||||
where
|
||||
fieldval = fmap strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe String
|
||||
fieldval = fmap T.strip . hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text
|
||||
|
||||
-- | Given a non-empty amount string (from CSV) to parse, along with a
|
||||
-- possibly non-empty currency symbol to prepend,
|
||||
-- parse as a hledger MixedAmount (as in journal format), or raise an error.
|
||||
-- The whole CSV record is provided for the error message.
|
||||
parseAmount :: CsvRules -> CsvRecord -> String -> String -> MixedAmount
|
||||
parseAmount :: CsvRules -> CsvRecord -> Text -> Text -> MixedAmount
|
||||
parseAmount rules record currency s =
|
||||
either mkerror (Mixed . (:[])) $ -- PARTIAL:
|
||||
runParser (evalStateT (amountp <* eof) journalparsestate) "" $
|
||||
T.pack $ (currency++) $ simplifySign s
|
||||
either mkerror (Mixed . (:[])) $ -- PARTIAL:
|
||||
runParser (evalStateT (amountp <* eof) journalparsestate) "" $
|
||||
currency <> simplifySign s
|
||||
where
|
||||
journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}
|
||||
mkerror e = error' $ unlines
|
||||
["error: could not parse \""++s++"\" as an amount"
|
||||
mkerror e = error' . T.unpack $ T.unlines
|
||||
["error: could not parse \"" <> s <> "\" as an amount"
|
||||
,showRecord record
|
||||
,showRules rules record
|
||||
-- ,"the default-currency is: "++fromMaybe "unspecified" (getDirective "default-currency" rules)
|
||||
,"the parse error is: "++customErrorBundlePretty e
|
||||
,"you may need to "
|
||||
++"change your amount*, balance*, or currency* rules, "
|
||||
++"or add or change your skip rule"
|
||||
,"the parse error is: " <> T.pack (customErrorBundlePretty e)
|
||||
,"you may need to \
|
||||
\change your amount*, balance*, or currency* rules, \
|
||||
\or add or change your skip rule"
|
||||
]
|
||||
|
||||
-- XXX unify these ^v
|
||||
@ -1076,30 +1072,30 @@ parseAmount rules record currency s =
|
||||
-- possibly non-empty currency symbol to prepend,
|
||||
-- parse as a hledger Amount (as in journal format), or raise an error.
|
||||
-- The CSV record and the field's numeric suffix are provided for the error message.
|
||||
parseBalanceAmount :: CsvRules -> CsvRecord -> String -> Int -> String -> Amount
|
||||
parseBalanceAmount :: CsvRules -> CsvRecord -> Text -> Int -> Text -> Amount
|
||||
parseBalanceAmount rules record currency n s =
|
||||
either (mkerror n s) id $
|
||||
runParser (evalStateT (amountp <* eof) journalparsestate) "" $
|
||||
T.pack $ (currency++) $ simplifySign s
|
||||
currency <> simplifySign s
|
||||
-- the csv record's line number would be good
|
||||
where
|
||||
journalparsestate = nulljournal{jparsedecimalmark=parseDecimalMark rules}
|
||||
mkerror n s e = error' $ unlines
|
||||
["error: could not parse \""++s++"\" as balance"++show n++" amount"
|
||||
mkerror n s e = error' . T.unpack $ T.unlines
|
||||
["error: could not parse \"" <> s <> "\" as balance"<> T.pack (show n) <> " amount"
|
||||
,showRecord record
|
||||
,showRules rules record
|
||||
-- ,"the default-currency is: "++fromMaybe "unspecified" mdefaultcurrency
|
||||
,"the parse error is: "++customErrorBundlePretty e
|
||||
,"the parse error is: "<> T.pack (customErrorBundlePretty e)
|
||||
]
|
||||
|
||||
-- Read a valid decimal mark from the decimal-mark rule, if any.
|
||||
-- If the rule is present with an invalid argument, raise an error.
|
||||
parseDecimalMark :: CsvRules -> Maybe DecimalMark
|
||||
parseDecimalMark rules =
|
||||
case rules `csvRule` "decimal-mark" of
|
||||
Nothing -> Nothing
|
||||
Just [c] | isDecimalMark c -> Just c
|
||||
Just s -> error' $ "decimal-mark's argument should be \".\" or \",\" (not \""++s++"\")"
|
||||
parseDecimalMark rules = do
|
||||
s <- rules `csvRule` "decimal-mark"
|
||||
case T.uncons s of
|
||||
Just (c, rest) | T.null rest && isDecimalMark c -> return c
|
||||
_ -> error' . T.unpack $ "decimal-mark's argument should be \".\" or \",\" (not \""<>s<>"\")"
|
||||
|
||||
-- | Make a balance assertion for the given amount, with the given parse
|
||||
-- position (to be shown in assertion failures), with the assertion type
|
||||
@ -1116,8 +1112,8 @@ mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}
|
||||
Just "==" -> nullassertion{batotal=True}
|
||||
Just "=*" -> nullassertion{bainclusive=True}
|
||||
Just "==*" -> nullassertion{batotal=True, bainclusive=True}
|
||||
Just x -> error' $ unlines -- PARTIAL:
|
||||
[ "balance-type \"" ++ x ++"\" is invalid. Use =, ==, =* or ==*."
|
||||
Just x -> error' . T.unpack $ T.unlines -- PARTIAL:
|
||||
[ "balance-type \"" <> x <>"\" is invalid. Use =, ==, =* or ==*."
|
||||
, showRecord record
|
||||
, showRules rules record
|
||||
]
|
||||
@ -1128,8 +1124,8 @@ mkBalanceAssertion rules record (amt, pos) = assrt{baamount=amt, baposition=pos}
|
||||
getAccount :: CsvRules -> CsvRecord -> Maybe MixedAmount -> Maybe (Amount, GenericSourcePos) -> Int -> Maybe (AccountName, Bool)
|
||||
getAccount rules record mamount mbalance n =
|
||||
let
|
||||
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe String
|
||||
maccount = T.pack <$> fieldval ("account"++show n)
|
||||
fieldval = hledgerFieldValue rules record :: HledgerFieldName -> Maybe Text
|
||||
maccount = fieldval ("account"<> T.pack (show n))
|
||||
in case maccount of
|
||||
-- accountN is set to the empty string - no posting will be generated
|
||||
Just "" -> Nothing
|
||||
@ -1150,7 +1146,7 @@ getAccount rules record mamount mbalance n =
|
||||
unknownExpenseAccount = "expenses:unknown"
|
||||
unknownIncomeAccount = "income:unknown"
|
||||
|
||||
type CsvAmountString = String
|
||||
type CsvAmountString = Text
|
||||
|
||||
-- | Canonicalise the sign in a CSV amount string.
|
||||
-- Such strings can have a minus sign, negating parentheses,
|
||||
@ -1171,18 +1167,20 @@ type CsvAmountString = String
|
||||
-- >>> simplifySign "((1))"
|
||||
-- "1"
|
||||
simplifySign :: CsvAmountString -> CsvAmountString
|
||||
simplifySign ('(':s) | lastMay s == Just ')' = simplifySign $ negateStr $ init s
|
||||
simplifySign ('-':'(':s) | lastMay s == Just ')' = simplifySign $ init s
|
||||
simplifySign ('-':'-':s) = s
|
||||
simplifySign s = s
|
||||
simplifySign amtstr
|
||||
| Just ('(',t) <- T.uncons amtstr, Just (amt,')') <- T.unsnoc t = simplifySign $ negateStr amt
|
||||
| Just ('-',b) <- T.uncons amtstr, Just ('(',t) <- T.uncons b, Just (amt,')') <- T.unsnoc t = simplifySign amt
|
||||
| Just ('-',m) <- T.uncons amtstr, Just ('-',amt) <- T.uncons m = amt
|
||||
| otherwise = amtstr
|
||||
|
||||
negateStr :: String -> String
|
||||
negateStr ('-':s) = s
|
||||
negateStr s = '-':s
|
||||
negateStr :: Text -> Text
|
||||
negateStr amtstr = case T.uncons amtstr of
|
||||
Just ('-',s) -> s
|
||||
_ -> T.cons '-' amtstr
|
||||
|
||||
-- | Show a (approximate) recreation of the original CSV record.
|
||||
showRecord :: CsvRecord -> String
|
||||
showRecord r = "record values: "++intercalate "," (map show r)
|
||||
showRecord :: CsvRecord -> Text
|
||||
showRecord r = "record values: "<>T.intercalate "," (map (wrap "\"" "\"") r)
|
||||
|
||||
-- | Given the conversion rules, a CSV record and a hledger field name, find
|
||||
-- the value template ultimately assigned to this field, if any, by a field
|
||||
@ -1208,7 +1206,7 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
|
||||
where
|
||||
-- does this individual matcher match the current csv record ?
|
||||
matcherMatches :: Matcher -> Bool
|
||||
matcherMatches (RecordMatcher _ pat) = regexMatch pat' wholecsvline
|
||||
matcherMatches (RecordMatcher _ pat) = regexMatchText pat' wholecsvline
|
||||
where
|
||||
pat' = dbg7 "regex" pat
|
||||
-- A synthetic whole CSV record to match against. Note, this can be
|
||||
@ -1217,47 +1215,48 @@ getEffectiveAssignment rules record f = lastMay $ map snd $ assignments
|
||||
-- - any quotes enclosing field values are removed
|
||||
-- - and the field separator is always comma
|
||||
-- which means that a field containing a comma will look like two fields.
|
||||
wholecsvline = dbg7 "wholecsvline" $ intercalate "," record
|
||||
matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatch pat csvfieldvalue
|
||||
wholecsvline = dbg7 "wholecsvline" $ T.intercalate "," record
|
||||
matcherMatches (FieldMatcher _ csvfieldref pat) = regexMatchText pat csvfieldvalue
|
||||
where
|
||||
-- the value of the referenced CSV field to match against.
|
||||
csvfieldvalue = dbg7 "csvfieldvalue" $ replaceCsvFieldReference rules record csvfieldref
|
||||
|
||||
-- | Render a field assignment's template, possibly interpolating referenced
|
||||
-- CSV field values. Outer whitespace is removed from interpolated values.
|
||||
renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> String
|
||||
renderTemplate rules record t = maybe t concat $ parseMaybe
|
||||
renderTemplate :: CsvRules -> CsvRecord -> FieldTemplate -> Text
|
||||
renderTemplate rules record t = maybe t mconcat $ parseMaybe
|
||||
(many $ takeWhile1P Nothing (/='%')
|
||||
<|> replaceCsvFieldReference rules record <$> referencep)
|
||||
t
|
||||
where
|
||||
referencep = liftA2 (:) (char '%') (takeWhile1P (Just "reference") isDescriptorChar) :: Parsec CustomErr String String
|
||||
referencep = liftA2 T.cons (char '%') (takeWhile1P (Just "reference") isDescriptorChar) :: Parsec CustomErr Text Text
|
||||
isDescriptorChar c = isAscii c && (isAlphaNum c || c == '_' || c == '-')
|
||||
|
||||
-- | Replace something that looks like a reference to a csv field ("%date" or "%1)
|
||||
-- with that field's value. If it doesn't look like a field reference, or if we
|
||||
-- can't find such a field, leave it unchanged.
|
||||
replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> String
|
||||
replaceCsvFieldReference rules record s@('%':fieldname) = fromMaybe s $ csvFieldValue rules record fieldname
|
||||
replaceCsvFieldReference _ _ s = s
|
||||
replaceCsvFieldReference :: CsvRules -> CsvRecord -> CsvFieldReference -> Text
|
||||
replaceCsvFieldReference rules record s = case T.uncons s of
|
||||
Just ('%', fieldname) -> fromMaybe s $ csvFieldValue rules record fieldname
|
||||
_ -> s
|
||||
|
||||
-- | Get the (whitespace-stripped) value of a CSV field, identified by its name or
|
||||
-- column number, ("date" or "1"), from the given CSV record, if such a field exists.
|
||||
csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe String
|
||||
csvFieldValue :: CsvRules -> CsvRecord -> CsvFieldName -> Maybe Text
|
||||
csvFieldValue rules record fieldname = do
|
||||
fieldindex <- if | all isDigit fieldname -> readMay fieldname
|
||||
| otherwise -> lookup (map toLower fieldname) $ rcsvfieldindexes rules
|
||||
fieldvalue <- strip <$> atMay record (fieldindex-1)
|
||||
fieldindex <- if | T.all isDigit fieldname -> readMay $ T.unpack fieldname
|
||||
| otherwise -> lookup (T.toLower fieldname) $ rcsvfieldindexes rules
|
||||
fieldvalue <- T.strip <$> atMay record (fieldindex-1)
|
||||
return fieldvalue
|
||||
|
||||
-- | Parse the date string using the specified date-format, or if unspecified
|
||||
-- the "simple date" formats (YYYY/MM/DD, YYYY-MM-DD, YYYY.MM.DD, leading
|
||||
-- zeroes optional).
|
||||
parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> String -> Maybe Day
|
||||
parseDateWithCustomOrDefaultFormats :: Maybe DateFormat -> Text -> Maybe Day
|
||||
parseDateWithCustomOrDefaultFormats mformat s = asum $ map parsewith formats
|
||||
where
|
||||
parsewith = flip (parseTimeM True defaultTimeLocale) s
|
||||
formats = maybe
|
||||
parsewith = flip (parseTimeM True defaultTimeLocale) (T.unpack s)
|
||||
formats = map T.unpack $ maybe
|
||||
["%Y/%-m/%-d"
|
||||
,"%Y-%-m-%-d"
|
||||
,"%Y.%-m.%-d"
|
||||
|
@ -42,7 +42,7 @@ module Hledger.Read.JournalReader (
|
||||
-- * Reader-finding utils
|
||||
findReader,
|
||||
splitReaderPrefix,
|
||||
|
||||
|
||||
-- * Reader
|
||||
reader,
|
||||
|
||||
@ -380,8 +380,8 @@ parseAccountTypeCode s =
|
||||
"c" -> Right Cash
|
||||
_ -> Left err
|
||||
where
|
||||
err = "invalid account type code "++T.unpack s++", should be one of " ++
|
||||
(intercalate ", " $ ["A","L","E","R","X","C","Asset","Liability","Equity","Revenue","Expense","Cash"])
|
||||
err = T.unpack $ "invalid account type code "<>s<>", should be one of " <>
|
||||
T.intercalate ", " ["A","L","E","R","X","C","Asset","Liability","Equity","Revenue","Expense","Cash"]
|
||||
|
||||
-- Add an account declaration to the journal, auto-numbering it.
|
||||
addAccountDeclaration :: (AccountName,Text,[Tag]) -> JournalParser m ()
|
||||
|
@ -18,6 +18,7 @@ where
|
||||
import Data.List
|
||||
import Data.Ord
|
||||
import Data.Maybe
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Calendar
|
||||
|
||||
@ -64,26 +65,20 @@ import Hledger.Utils
|
||||
-- posts to the current account), most recent first.
|
||||
-- Reporting intervals are currently ignored.
|
||||
--
|
||||
type AccountTransactionsReport =
|
||||
(String -- label for the balance column, eg "balance" or "total"
|
||||
,[AccountTransactionsReportItem] -- line items, one per transaction
|
||||
)
|
||||
type AccountTransactionsReport = [AccountTransactionsReportItem] -- line items, one per transaction
|
||||
|
||||
type AccountTransactionsReportItem =
|
||||
(
|
||||
Transaction -- the transaction, unmodified
|
||||
,Transaction -- the transaction, as seen from the current account
|
||||
,Bool -- is this a split (more than one posting to other accounts) ?
|
||||
,String -- a display string describing the other account(s), if any
|
||||
,Text -- a display string describing the other account(s), if any
|
||||
,MixedAmount -- the amount posted to the current account(s) (or total amount posted)
|
||||
,MixedAmount -- the register's running total or the current account(s)'s historical balance, after this transaction
|
||||
)
|
||||
|
||||
totallabel = "Period Total"
|
||||
balancelabel = "Historical Total"
|
||||
|
||||
accountTransactionsReport :: ReportSpec -> Journal -> Query -> Query -> AccountTransactionsReport
|
||||
accountTransactionsReport rspec@ReportSpec{rsOpts=ropts} j reportq thisacctq = (label, items)
|
||||
accountTransactionsReport rspec@ReportSpec{rsOpts=ropts} j reportq thisacctq = items
|
||||
where
|
||||
-- a depth limit should not affect the account transactions report
|
||||
-- seems unnecessary for some reason XXX
|
||||
@ -129,9 +124,9 @@ accountTransactionsReport rspec@ReportSpec{rsOpts=ropts} j reportq thisacctq = (
|
||||
ptraceAtWith 5 (("ts5:\n"++).pshowTransactions) $
|
||||
sortBy (comparing (transactionRegisterDate reportq' thisacctq)) ts4
|
||||
|
||||
(startbal,label)
|
||||
| balancetype_ ropts == HistoricalBalance = (sumPostings priorps, balancelabel)
|
||||
| otherwise = (nullmixedamt, totallabel)
|
||||
startbal
|
||||
| balancetype_ ropts == HistoricalBalance = sumPostings priorps
|
||||
| otherwise = nullmixedamt
|
||||
where
|
||||
priorps = dbg5 "priorps" $
|
||||
filter (matchesPosting
|
||||
@ -216,9 +211,9 @@ transactionRegisterDate reportq thisacctq t
|
||||
|
||||
-- | Generate a simplified summary of some postings' accounts.
|
||||
-- To reduce noise, if there are both real and virtual postings, show only the real ones.
|
||||
summarisePostingAccounts :: [Posting] -> String
|
||||
summarisePostingAccounts :: [Posting] -> Text
|
||||
summarisePostingAccounts ps =
|
||||
(intercalate ", " . map (T.unpack . accountSummarisedName) . nub . map paccount) displayps -- XXX pack
|
||||
T.intercalate ", " . map accountSummarisedName . nub $ map paccount displayps
|
||||
where
|
||||
realps = filter isReal ps
|
||||
displayps | null realps = ps
|
||||
|
@ -27,27 +27,27 @@ module Hledger.Reports.BudgetReport (
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Decimal
|
||||
import Data.Decimal (roundTo)
|
||||
import Data.Default (def)
|
||||
import Data.HashMap.Strict (HashMap)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List
|
||||
import Data.List (nub, partition, transpose)
|
||||
import Data.List.Extra (nubSort)
|
||||
import Data.Maybe
|
||||
import Data.Maybe (fromMaybe)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Monoid ((<>))
|
||||
#endif
|
||||
import Safe
|
||||
import Safe (headDef)
|
||||
--import Data.List
|
||||
--import Data.Maybe
|
||||
import qualified Data.Map as Map
|
||||
import Data.Map (Map)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
--import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
--import System.Console.CmdArgs.Explicit as C
|
||||
--import Lucid as L
|
||||
|
||||
import Text.Printf (printf)
|
||||
import Text.Tabular as T
|
||||
import Text.Tabular.AsciiWide as T
|
||||
|
||||
@ -68,7 +68,7 @@ type BudgetCell = (Maybe Change, Maybe BudgetGoal)
|
||||
type BudgetReportRow = PeriodicReportRow DisplayName BudgetCell
|
||||
type BudgetReport = PeriodicReport DisplayName BudgetCell
|
||||
|
||||
type BudgetDisplayCell = ((String, Int), Maybe ((String, Int), Maybe (String, Int)))
|
||||
type BudgetDisplayCell = ((Text, Int), Maybe ((Text, Int), Maybe (Text, Int)))
|
||||
|
||||
-- | Calculate per-account, per-period budget (balance change) goals
|
||||
-- from all periodic transactions, calculate actual balance changes
|
||||
@ -219,23 +219,23 @@ combineBudgetAndActual ropts j
|
||||
totActualByPeriod = Map.fromList $ zip actualperiods actualtots :: Map DateSpan Change
|
||||
|
||||
-- | Render a budget report as plain text suitable for console output.
|
||||
budgetReportAsText :: ReportOpts -> BudgetReport -> String
|
||||
budgetReportAsText ropts@ReportOpts{..} budgetr =
|
||||
title ++ "\n\n" ++
|
||||
renderTable def{tableBorders=False,prettyTable=pretty_tables_}
|
||||
budgetReportAsText :: ReportOpts -> BudgetReport -> TL.Text
|
||||
budgetReportAsText ropts@ReportOpts{..} budgetr = TB.toLazyText $
|
||||
TB.fromText title <> TB.fromText "\n\n" <>
|
||||
renderTableB def{tableBorders=False,prettyTable=pretty_tables_}
|
||||
(alignCell TopLeft) (alignCell TopRight) (uncurry showcell) displayTableWithWidths
|
||||
where
|
||||
title = printf "Budget performance in %s%s:"
|
||||
(showDateSpan $ periodicReportSpan budgetr)
|
||||
(case value_ of
|
||||
Just (AtCost _mc) -> ", valued at cost"
|
||||
Just (AtThen _mc) -> error' unsupportedValueThenError -- PARTIAL:
|
||||
Just (AtEnd _mc) -> ", valued at period ends"
|
||||
Just (AtNow _mc) -> ", current value"
|
||||
Just (AtDate d _mc) -> ", valued at "++showDate d
|
||||
Nothing -> "")
|
||||
title = "Budget performance in " <> showDateSpan (periodicReportSpan budgetr)
|
||||
<> (case value_ of
|
||||
Just (AtCost _mc) -> ", valued at cost"
|
||||
Just (AtThen _mc) -> error' unsupportedValueThenError -- PARTIAL:
|
||||
Just (AtEnd _mc) -> ", valued at period ends"
|
||||
Just (AtNow _mc) -> ", current value"
|
||||
Just (AtDate d _mc) -> ", valued at " <> showDate d
|
||||
Nothing -> "")
|
||||
<> ":"
|
||||
|
||||
displayTableWithWidths :: Table String String ((Int, Int, Int), BudgetDisplayCell)
|
||||
displayTableWithWidths :: Table Text Text ((Int, Int, Int), BudgetDisplayCell)
|
||||
displayTableWithWidths = Table rh ch $ map (zipWith (,) widths) displaycells
|
||||
Table rh ch displaycells = case budgetReportAsTable ropts budgetr of
|
||||
Table rh' ch' vals -> maybetranspose . Table rh' ch' $ map (map displayCell) vals
|
||||
@ -244,8 +244,8 @@ budgetReportAsText ropts@ReportOpts{..} budgetr =
|
||||
where
|
||||
actual' = fromMaybe 0 actual
|
||||
budgetAndPerc b = (showamt b, showper <$> percentage actual' b)
|
||||
showamt = showMixedOneLine showAmountWithoutPrice Nothing (Just 32) color_
|
||||
showper p = let str = show (roundTo 0 p) in (str, length str)
|
||||
showamt = (\(WideBuilder b w) -> (TL.toStrict $ TB.toLazyText b, w)) . showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=Just 32}
|
||||
showper p = let str = T.pack (show $ roundTo 0 p) in (str, T.length str)
|
||||
cellWidth ((_,wa), Nothing) = (wa, 0, 0)
|
||||
cellWidth ((_,wa), Just ((_,wb), Nothing)) = (wa, wb, 0)
|
||||
cellWidth ((_,wa), Just ((_,wb), Just (_,wp))) = (wa, wb, wp)
|
||||
@ -259,14 +259,17 @@ budgetReportAsText ropts@ReportOpts{..} budgetr =
|
||||
-- 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 -> Cell
|
||||
showcell (actualwidth, budgetwidth, percentwidth) ((actual,wa), mbudget) =
|
||||
Cell TopRight [(replicate (actualwidth - wa) ' ' ++ actual ++ budgetstr, actualwidth + totalbudgetwidth)]
|
||||
Cell TopRight [WideBuilder ( TB.fromText (T.replicate (actualwidth - wa) " ")
|
||||
<> TB.fromText actual
|
||||
<> budgetstr
|
||||
) (actualwidth + totalbudgetwidth)]
|
||||
where
|
||||
totalpercentwidth = if percentwidth == 0 then 0 else percentwidth + 5
|
||||
totalbudgetwidth = if budgetwidth == 0 then 0 else budgetwidth + totalpercentwidth + 3
|
||||
budgetstr = case mbudget of
|
||||
Nothing -> replicate totalbudgetwidth ' '
|
||||
Just ((budget, wb), Nothing) -> " [" ++ replicate totalpercentwidth ' ' ++ replicate (budgetwidth - wb) ' ' ++ budget ++ "]"
|
||||
Just ((budget, wb), Just (pct, wp)) -> " [" ++ replicate (percentwidth - wp) ' ' ++ pct ++ "% of " ++ replicate (budgetwidth - wb) ' ' ++ budget ++ "]"
|
||||
budgetstr = TB.fromText $ case mbudget of
|
||||
Nothing -> T.replicate totalbudgetwidth " "
|
||||
Just ((budget, wb), Nothing) -> " [" <> T.replicate totalpercentwidth " " <> T.replicate (budgetwidth - wb) " " <> budget <> "]"
|
||||
Just ((budget, wb), Just (pct, wp)) -> " [" <> T.replicate (percentwidth - wp) " " <> pct <> "% of " <> T.replicate (budgetwidth - wb) " " <> budget <> "]"
|
||||
|
||||
-- | Calculate the percentage of actual change to budget goal to show, if any.
|
||||
-- If valuing at cost, both amounts are converted to cost before comparing.
|
||||
@ -289,7 +292,7 @@ budgetReportAsText ropts@ReportOpts{..} budgetr =
|
||||
| otherwise = id
|
||||
|
||||
-- | Build a 'Table' from a multi-column balance report.
|
||||
budgetReportAsTable :: ReportOpts -> BudgetReport -> Table String String (Maybe MixedAmount, Maybe MixedAmount)
|
||||
budgetReportAsTable :: ReportOpts -> BudgetReport -> Table Text Text (Maybe MixedAmount, Maybe MixedAmount)
|
||||
budgetReportAsTable
|
||||
ropts@ReportOpts{balancetype_}
|
||||
(PeriodicReport spans rows (PeriodicReportRow _ coltots grandtot grandavg)) =
|
||||
@ -308,8 +311,8 @@ budgetReportAsTable
|
||||
-- budgetReport sets accountlistmode to ALTree. Find a principled way to do
|
||||
-- this.
|
||||
renderacct row = case accountlistmode_ ropts of
|
||||
ALTree -> replicate ((prrDepth row - 1)*2) ' ' ++ T.unpack (prrDisplayName row)
|
||||
ALFlat -> T.unpack . accountNameDrop (drop_ ropts) $ prrFullName row
|
||||
ALTree -> T.replicate ((prrDepth row - 1)*2) " " <> prrDisplayName row
|
||||
ALFlat -> accountNameDrop (drop_ ropts) $ prrFullName row
|
||||
rowvals (PeriodicReportRow _ as rowtot rowavg) =
|
||||
as ++ [rowtot | row_total_ ropts] ++ [rowavg | average_ ropts]
|
||||
addtotalrow
|
||||
@ -332,7 +335,7 @@ budgetReportAsTable
|
||||
-- - all other balance change reports: a description of the datespan,
|
||||
-- abbreviated to compact form if possible (see showDateSpan).
|
||||
--
|
||||
reportPeriodName :: BalanceType -> [DateSpan] -> DateSpan -> String
|
||||
reportPeriodName :: BalanceType -> [DateSpan] -> DateSpan -> T.Text
|
||||
reportPeriodName balancetype spans =
|
||||
case balancetype of
|
||||
PeriodChange -> if multiyear then showDateSpan else showDateSpanMonthAbbrev
|
||||
@ -344,20 +347,20 @@ reportPeriodName balancetype spans =
|
||||
-- | Render a budget report as CSV. Like multiBalanceReportAsCsv,
|
||||
-- but includes alternating actual and budget amount columns.
|
||||
budgetReportAsCsv :: ReportOpts -> BudgetReport -> CSV
|
||||
budgetReportAsCsv
|
||||
budgetReportAsCsv
|
||||
ReportOpts{average_, row_total_, no_total_, transpose_}
|
||||
(PeriodicReport colspans items (PeriodicReportRow _ abtotals (magrandtot,mbgrandtot) (magrandavg,mbgrandavg)))
|
||||
= (if transpose_ then transpose else id) $
|
||||
|
||||
-- heading row
|
||||
("Account" :
|
||||
("Account" :
|
||||
concatMap (\span -> [showDateSpan span, "budget"]) colspans
|
||||
++ concat [["Total" ,"budget"] | row_total_]
|
||||
++ concat [["Average","budget"] | average_]
|
||||
) :
|
||||
|
||||
-- account rows
|
||||
[T.unpack (displayFull a) :
|
||||
[displayFull a :
|
||||
map showmamt (flattentuples abamts)
|
||||
++ concat [[showmamt mactualrowtot, showmamt mbudgetrowtot] | row_total_]
|
||||
++ concat [[showmamt mactualrowavg, showmamt mbudgetrowavg] | average_]
|
||||
@ -369,7 +372,7 @@ budgetReportAsCsv
|
||||
[
|
||||
"Total:" :
|
||||
map showmamt (flattentuples abtotals)
|
||||
++ concat [[showmamt magrandtot,showmamt mbgrandtot] | row_total_]
|
||||
++ concat [[showmamt magrandtot,showmamt mbgrandtot] | row_total_]
|
||||
++ concat [[showmamt magrandavg,showmamt mbgrandavg] | average_]
|
||||
]
|
||||
| not no_total_
|
||||
@ -377,7 +380,7 @@ budgetReportAsCsv
|
||||
|
||||
where
|
||||
flattentuples abs = concat [[a,b] | (a,b) <- abs]
|
||||
showmamt = maybe "" (showMixedAmountOneLineWithoutPrice False)
|
||||
showmamt = maybe "" (wbToText . showMixedAmountB oneLine)
|
||||
|
||||
-- tests
|
||||
|
||||
|
@ -24,8 +24,7 @@ where
|
||||
import Data.List
|
||||
import Data.List.Extra (nubSort)
|
||||
import Data.Maybe
|
||||
-- import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Text (Text)
|
||||
import Data.Time.Calendar
|
||||
import Safe (headMay, lastMay)
|
||||
|
||||
@ -35,12 +34,10 @@ import Hledger.Utils
|
||||
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.
|
||||
-- | A postings report is a list of postings with a running total, 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
|
||||
,[PostingsReportItem] -- line items, one per posting
|
||||
)
|
||||
type PostingsReport = [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 =
|
||||
(totallabel, items)
|
||||
postingsReport rspec@ReportSpec{rsOpts=ropts@ReportOpts{..}} j = 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 $ snd $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11
|
||||
(length $ snd $ 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 samplejournal) @?= 13
|
||||
(length $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1}} samplejournal) @?= 11
|
||||
(length $ postingsReport defreportspec{rsOpts=defreportopts{interval_=Months 1, empty_=True}} samplejournal) @?= 20
|
||||
(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)
|
||||
|
@ -167,7 +167,7 @@ rawOptsToReportOpts rawopts = do
|
||||
supports_color <- hSupportsANSIColor stdout
|
||||
|
||||
let colorflag = stringopt "color" rawopts
|
||||
formatstring = maybestringopt "format" rawopts
|
||||
formatstring = T.pack <$> maybestringopt "format" rawopts
|
||||
querystring = map T.pack $ listofstringopt "args" rawopts -- doesn't handle an arg like "" right
|
||||
|
||||
format <- case parseStringFormat <$> formatstring of
|
||||
|
@ -32,9 +32,10 @@ module Hledger.Reports.ReportTypes
|
||||
, prrDepth
|
||||
) where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Decimal
|
||||
import Data.Aeson (ToJSON(..))
|
||||
import Data.Decimal (Decimal)
|
||||
import Data.Maybe (mapMaybe)
|
||||
import Data.Text (Text)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup (Semigroup(..))
|
||||
#endif
|
||||
@ -144,16 +145,16 @@ prrMapMaybeName f row = case f $ prrName row of
|
||||
-- It is used in compound balance report commands like balancesheet,
|
||||
-- cashflow and incomestatement.
|
||||
data CompoundPeriodicReport a b = CompoundPeriodicReport
|
||||
{ cbrTitle :: String
|
||||
{ cbrTitle :: Text
|
||||
, cbrDates :: [DateSpan]
|
||||
, cbrSubreports :: [(String, PeriodicReport a b, Bool)]
|
||||
, cbrSubreports :: [(Text, PeriodicReport a b, Bool)]
|
||||
, cbrTotals :: PeriodicReportRow () b
|
||||
} deriving (Show, Functor, Generic, ToJSON)
|
||||
|
||||
-- | Description of one subreport within a compound balance report.
|
||||
-- Part of a "CompoundBalanceCommandSpec", but also used in hledger-lib.
|
||||
data CBCSubreportSpec a = CBCSubreportSpec
|
||||
{ cbcsubreporttitle :: String -- ^ The title to use for the subreport
|
||||
{ cbcsubreporttitle :: Text -- ^ The title to use for the subreport
|
||||
, cbcsubreportquery :: Journal -> Query -- ^ The Query to use for the subreport
|
||||
, cbcsubreportoptions :: ReportOpts -> ReportOpts -- ^ A function to transform the ReportOpts used to produce the subreport
|
||||
, cbcsubreporttransform :: PeriodicReport DisplayName MixedAmount -> PeriodicReport a MixedAmount -- ^ A function to transform the result of the subreport
|
||||
|
@ -23,6 +23,7 @@ where
|
||||
|
||||
import Data.List
|
||||
import Data.List.Extra (nubSort)
|
||||
import Data.Text (Text)
|
||||
import Data.Ord
|
||||
|
||||
import Hledger.Data
|
||||
@ -34,18 +35,14 @@ import Hledger.Utils
|
||||
|
||||
-- | A transactions report includes a list of transactions touching multiple accounts
|
||||
-- (posting-filtered and unfiltered variants), a running balance, and some
|
||||
-- other information helpful for rendering a register view (a flag
|
||||
-- indicating multiple other accounts and a display string describing
|
||||
-- them) with or without a notion of current account(s).
|
||||
-- Two kinds of report use this data structure, see transactionsReport
|
||||
-- other information helpful for rendering a register view with or without a notion
|
||||
-- of current account(s). Two kinds of report use this data structure, see transactionsReport
|
||||
-- and accountTransactionsReport below for details.
|
||||
type TransactionsReport = (String -- label for the balance column, eg "balance" or "total"
|
||||
,[TransactionsReportItem] -- line items, one per transaction
|
||||
)
|
||||
type TransactionsReport = [TransactionsReportItem] -- line items, one per transaction
|
||||
type TransactionsReportItem = (Transaction -- the original journal transaction, unmodified
|
||||
,Transaction -- the transaction as seen from a particular account, with postings maybe filtered
|
||||
,Bool -- is this a split, ie more than one other account posting
|
||||
,String -- a display string describing the other account(s), if any
|
||||
,Text -- a display string describing the other account(s), if any
|
||||
,MixedAmount -- the amount posted to the current account(s) by the filtered postings (or total amount posted)
|
||||
,MixedAmount -- the running total of item amounts, starting from zero;
|
||||
-- or with --historical, the running total including items
|
||||
@ -59,14 +56,12 @@ triBalance (_,_,_,_,_,a) = a
|
||||
triCommodityAmount c = filterMixedAmountByCommodity c . triAmount
|
||||
triCommodityBalance c = filterMixedAmountByCommodity c . triBalance
|
||||
|
||||
totallabel = "Period Total"
|
||||
|
||||
-- | Select transactions from the whole journal. This is similar to a
|
||||
-- "postingsReport" except with transaction-based report items which
|
||||
-- are ordered most recent first. XXX Or an EntriesReport - use that instead ?
|
||||
-- This is used by hledger-web's journal view.
|
||||
transactionsReport :: ReportOpts -> Journal -> Query -> TransactionsReport
|
||||
transactionsReport opts j q = (totallabel, items)
|
||||
transactionsReport opts j q = items
|
||||
where
|
||||
-- XXX items' first element should be the full transaction with all postings
|
||||
items = reverse $ accountTransactionsReportItems q None nullmixedamt id ts
|
||||
@ -79,15 +74,14 @@ transactionsReportByCommodity :: TransactionsReport -> [(CommoditySymbol, Transa
|
||||
transactionsReportByCommodity tr =
|
||||
[(c, filterTransactionsReportByCommodity c tr) | c <- transactionsReportCommodities tr]
|
||||
where
|
||||
transactionsReportCommodities (_,items) =
|
||||
nubSort . map acommodity $ concatMap (amounts . triAmount) items
|
||||
transactionsReportCommodities = nubSort . map acommodity . concatMap (amounts . triAmount)
|
||||
|
||||
-- Remove transaction report items and item amount (and running
|
||||
-- balance amount) components that don't involve the specified
|
||||
-- commodity. Other item fields such as the transaction are left unchanged.
|
||||
filterTransactionsReportByCommodity :: CommoditySymbol -> TransactionsReport -> TransactionsReport
|
||||
filterTransactionsReportByCommodity c (label,items) =
|
||||
(label, fixTransactionsReportItemBalances $ concat [filterTransactionsReportItemByCommodity c i | i <- items])
|
||||
filterTransactionsReportByCommodity c =
|
||||
fixTransactionsReportItemBalances . concatMap (filterTransactionsReportItemByCommodity c)
|
||||
where
|
||||
filterTransactionsReportItemByCommodity c (t,t2,s,o,a,bal)
|
||||
| c `elem` cs = [item']
|
||||
|
@ -1,17 +1,25 @@
|
||||
-- | Basic color helpers for prettifying console output.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Hledger.Utils.Color
|
||||
(
|
||||
color,
|
||||
bgColor,
|
||||
colorB,
|
||||
bgColorB,
|
||||
Color(..),
|
||||
ColorIntensity(..)
|
||||
)
|
||||
where
|
||||
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import System.Console.ANSI
|
||||
import Hledger.Utils.Text (WideBuilder(..))
|
||||
|
||||
|
||||
-- | Wrap a string in ANSI codes to set and reset foreground colour.
|
||||
@ -21,3 +29,13 @@ color int col s = setSGRCode [SetColor Foreground int col] ++ s ++ setSGRCode []
|
||||
-- | Wrap a string in ANSI codes to set and reset background colour.
|
||||
bgColor :: ColorIntensity -> Color -> String -> String
|
||||
bgColor int col s = setSGRCode [SetColor Background int col] ++ s ++ setSGRCode []
|
||||
|
||||
-- | Wrap a WideBuilder in ANSI codes to set and reset foreground colour.
|
||||
colorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
|
||||
colorB int col (WideBuilder s w) =
|
||||
WideBuilder (TB.fromString (setSGRCode [SetColor Foreground int col]) <> s <> TB.fromString (setSGRCode [])) w
|
||||
|
||||
-- | Wrap a WideBuilder in ANSI codes to set and reset background colour.
|
||||
bgColorB :: ColorIntensity -> Color -> WideBuilder -> WideBuilder
|
||||
bgColorB int col (WideBuilder s w) =
|
||||
WideBuilder (TB.fromString (setSGRCode [SetColor Background int col]) <> s <> TB.fromString (setSGRCode [])) w
|
||||
|
@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-|
|
||||
@ -54,6 +56,7 @@ module Hledger.Utils.Regex (
|
||||
,RegexError
|
||||
-- * total regex operations
|
||||
,regexMatch
|
||||
,regexMatchText
|
||||
,regexReplace
|
||||
,regexReplaceUnmemo
|
||||
,regexReplaceAllBy
|
||||
@ -66,6 +69,10 @@ import Data.Array ((!), elems, indices)
|
||||
import Data.Char (isDigit)
|
||||
import Data.List (foldl')
|
||||
import Data.MemoUgly (memo)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Text.Regex.TDFA (
|
||||
Regex, CompOption(..), defaultCompOpt, defaultExecOpt,
|
||||
@ -78,8 +85,8 @@ import Hledger.Utils.UTF8IOCompat (error')
|
||||
|
||||
-- | Regular expression. Extended regular expression-ish syntax ? But does not support eg (?i) syntax.
|
||||
data Regexp
|
||||
= Regexp { reString :: String, reCompiled :: Regex }
|
||||
| RegexpCI { reString :: String, reCompiled :: Regex }
|
||||
= Regexp { reString :: Text, reCompiled :: Regex }
|
||||
| RegexpCI { reString :: Text, reCompiled :: Regex }
|
||||
|
||||
instance Eq Regexp where
|
||||
Regexp s1 _ == Regexp s2 _ = s1 == s2
|
||||
@ -93,7 +100,7 @@ instance Ord Regexp where
|
||||
RegexpCI _ _ `compare` Regexp _ _ = GT
|
||||
|
||||
instance Show Regexp where
|
||||
showsPrec d r = showParen (d > app_prec) $ reCons . showsPrec (app_prec+1) (reString r)
|
||||
showsPrec d r = showParen (d > app_prec) $ reCons . showsPrec (app_prec+1) (T.unpack $ reString r)
|
||||
where app_prec = 10
|
||||
reCons = case r of Regexp _ _ -> showString "Regexp "
|
||||
RegexpCI _ _ -> showString "RegexpCI "
|
||||
@ -108,8 +115,8 @@ instance Read Regexp where
|
||||
where app_prec = 10
|
||||
|
||||
instance ToJSON Regexp where
|
||||
toJSON (Regexp s _) = String . T.pack $ "Regexp " ++ s
|
||||
toJSON (RegexpCI s _) = String . T.pack $ "RegexpCI " ++ s
|
||||
toJSON (Regexp s _) = String $ "Regexp " <> s
|
||||
toJSON (RegexpCI s _) = String $ "RegexpCI " <> s
|
||||
|
||||
instance RegexLike Regexp String where
|
||||
matchOnce = matchOnce . reCompiled
|
||||
@ -124,24 +131,24 @@ instance RegexContext Regexp String String where
|
||||
matchM = matchM . reCompiled
|
||||
|
||||
-- Convert a Regexp string to a compiled Regex, or return an error message.
|
||||
toRegex :: String -> Either RegexError Regexp
|
||||
toRegex = memo $ \s -> mkRegexErr s (Regexp s <$> makeRegexM s)
|
||||
toRegex :: Text -> Either RegexError Regexp
|
||||
toRegex = memo $ \s -> mkRegexErr s (Regexp s <$> makeRegexM (T.unpack s)) -- Have to unpack here because Text instance in regex-tdfa only appears in 1.3.1
|
||||
|
||||
-- Like toRegex, but make a case-insensitive Regex.
|
||||
toRegexCI :: String -> Either RegexError Regexp
|
||||
toRegexCI = memo $ \s -> mkRegexErr s (RegexpCI s <$> makeRegexOptsM defaultCompOpt{caseSensitive=False} defaultExecOpt s)
|
||||
toRegexCI :: Text -> Either RegexError Regexp
|
||||
toRegexCI = memo $ \s -> mkRegexErr s (RegexpCI s <$> makeRegexOptsM defaultCompOpt{caseSensitive=False} defaultExecOpt (T.unpack s)) -- Have to unpack here because Text instance in regex-tdfa only appears in 1.3.1
|
||||
|
||||
-- | Make a nice error message for a regexp error.
|
||||
mkRegexErr :: String -> Maybe a -> Either RegexError a
|
||||
mkRegexErr :: Text -> Maybe a -> Either RegexError a
|
||||
mkRegexErr s = maybe (Left errmsg) Right
|
||||
where errmsg = "this regular expression could not be compiled: " ++ s
|
||||
where errmsg = T.unpack $ "this regular expression could not be compiled: " <> s
|
||||
|
||||
-- Convert a Regexp string to a compiled Regex, throw an error
|
||||
toRegex' :: String -> Regexp
|
||||
toRegex' :: Text -> Regexp
|
||||
toRegex' = either error' id . toRegex
|
||||
|
||||
-- Like toRegex', but make a case-insensitive Regex.
|
||||
toRegexCI' :: String -> Regexp
|
||||
toRegexCI' :: Text -> Regexp
|
||||
toRegexCI' = either error' id . toRegexCI
|
||||
|
||||
-- | A replacement pattern. May include numeric backreferences (\N).
|
||||
@ -159,6 +166,13 @@ type RegexError = String
|
||||
regexMatch :: Regexp -> String -> Bool
|
||||
regexMatch = matchTest
|
||||
|
||||
-- | Tests whether a Regexp matches a Text.
|
||||
--
|
||||
-- This currently unpacks the Text to a String an works on that. This is due to
|
||||
-- a performance bug in regex-tdfa (#9), which may or may not be relevant here.
|
||||
regexMatchText :: Regexp -> Text -> Bool
|
||||
regexMatchText r = matchTest r . T.unpack
|
||||
|
||||
--------------------------------------------------------------------------------
|
||||
-- new total functions
|
||||
|
||||
|
@ -38,8 +38,6 @@ module Hledger.Utils.String (
|
||||
padright,
|
||||
cliptopleft,
|
||||
fitto,
|
||||
linesPrepend,
|
||||
linesPrepend2,
|
||||
-- * wide-character-aware layout
|
||||
charWidth,
|
||||
strWidth,
|
||||
@ -55,6 +53,8 @@ module Hledger.Utils.String (
|
||||
import Data.Char (isSpace, toLower, toUpper)
|
||||
import Data.Default (def)
|
||||
import Data.List (intercalate)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Text.Megaparsec ((<|>), between, many, noneOf, sepBy)
|
||||
import Text.Megaparsec.Char (char)
|
||||
import Text.Printf (printf)
|
||||
@ -62,8 +62,8 @@ import Text.Printf (printf)
|
||||
import Hledger.Utils.Parse
|
||||
import Hledger.Utils.Regex (toRegex', regexReplace)
|
||||
import Text.Tabular (Header(..), Properties(..))
|
||||
import Text.Tabular.AsciiWide (Align(..), Cell(..), TableOpts(..), renderRow)
|
||||
import Text.WideString (strWidth, charWidth)
|
||||
import Text.Tabular.AsciiWide (Align(..), TableOpts(..), alignCell, renderRow)
|
||||
import Text.WideString (charWidth, strWidth)
|
||||
|
||||
|
||||
-- | Take elements from the end of a list.
|
||||
@ -184,16 +184,16 @@ unbracket s
|
||||
-- | Join several multi-line strings as side-by-side rectangular strings of the same height, top-padded.
|
||||
-- Treats wide characters as double width.
|
||||
concatTopPadded :: [String] -> String
|
||||
concatTopPadded = renderRow def{tableBorders=False, borderSpaces=False}
|
||||
concatTopPadded = TL.unpack . renderRow def{tableBorders=False, borderSpaces=False}
|
||||
. Group NoLine . map (Header . cell)
|
||||
where cell = Cell BottomLeft . map (\x -> (x, strWidth x)) . lines
|
||||
where cell = alignCell BottomLeft . T.pack
|
||||
|
||||
-- | Join several multi-line strings as side-by-side rectangular strings of the same height, bottom-padded.
|
||||
-- Treats wide characters as double width.
|
||||
concatBottomPadded :: [String] -> String
|
||||
concatBottomPadded = renderRow def{tableBorders=False, borderSpaces=False}
|
||||
concatBottomPadded = TL.unpack . renderRow def{tableBorders=False, borderSpaces=False}
|
||||
. Group NoLine . map (Header . cell)
|
||||
where cell = Cell TopLeft . map (\x -> (x, strWidth x)) . lines
|
||||
where cell = alignCell TopLeft . T.pack
|
||||
|
||||
|
||||
-- | Join multi-line strings horizontally, after compressing each of
|
||||
@ -349,15 +349,4 @@ stripAnsi :: String -> String
|
||||
stripAnsi s = either err id $ regexReplace ansire "" s
|
||||
where
|
||||
err = error "stripAnsi: invalid replacement pattern" -- PARTIAL, shouldn't happen
|
||||
ansire = toRegex' "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]" -- PARTIAL, should succeed
|
||||
|
||||
-- | Add a prefix to each line of a string.
|
||||
linesPrepend :: String -> String -> String
|
||||
linesPrepend prefix = unlines . map (prefix++) . lines
|
||||
|
||||
-- | Add a prefix to the first line of a string,
|
||||
-- and a different prefix to the remaining lines.
|
||||
linesPrepend2 :: String -> String -> String -> String
|
||||
linesPrepend2 prefix1 prefix2 s =
|
||||
unlines $ (prefix1++l) : map (prefix2++) ls
|
||||
where l:ls = lines s
|
||||
ansire = toRegex' $ T.pack "\ESC\\[([0-9]+;)*([0-9]+)?[ABCDHJKfmsu]" -- PARTIAL, should succeed
|
||||
|
@ -12,6 +12,8 @@ module Hledger.Utils.Text
|
||||
-- underline,
|
||||
-- stripbrackets,
|
||||
textUnbracket,
|
||||
wrap,
|
||||
textChomp,
|
||||
-- -- quoting
|
||||
quoteIfSpaced,
|
||||
textQuoteIfNeeded,
|
||||
@ -29,7 +31,7 @@ module Hledger.Utils.Text
|
||||
-- -- * single-line layout
|
||||
-- elideLeft,
|
||||
textElideRight,
|
||||
-- formatString,
|
||||
formatText,
|
||||
-- -- * multi-line layout
|
||||
textConcatTopPadded,
|
||||
-- concatBottomPadded,
|
||||
@ -43,7 +45,12 @@ module Hledger.Utils.Text
|
||||
-- cliptopleft,
|
||||
-- fitto,
|
||||
fitText,
|
||||
linesPrepend,
|
||||
linesPrepend2,
|
||||
-- -- * wide-character-aware layout
|
||||
WideBuilder(..),
|
||||
wbToText,
|
||||
wbUnpack,
|
||||
textWidth,
|
||||
textTakeWidth,
|
||||
-- fitString,
|
||||
@ -70,7 +77,8 @@ import qualified Data.Text as T
|
||||
-- import Hledger.Utils.Parse
|
||||
-- import Hledger.Utils.Regex
|
||||
import Hledger.Utils.Test
|
||||
import Text.WideString (charWidth, textWidth)
|
||||
import Text.WideString (WideBuilder(..), wbToText, wbUnpack, charWidth, textWidth)
|
||||
|
||||
|
||||
-- lowercase, uppercase :: String -> String
|
||||
-- lowercase = map toLower
|
||||
@ -87,15 +95,23 @@ textElideRight :: Int -> Text -> Text
|
||||
textElideRight width t =
|
||||
if T.length t > width then T.take (width - 2) t <> ".." else t
|
||||
|
||||
-- -- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it.
|
||||
-- -- Works on multi-line strings too (but will rewrite non-unix line endings).
|
||||
-- formatString :: Bool -> Maybe Int -> Maybe Int -> String -> String
|
||||
-- formatString leftJustified minwidth maxwidth s = intercalate "\n" $ map (printf fmt) $ lines s
|
||||
-- where
|
||||
-- justify = if leftJustified then "-" else ""
|
||||
-- minwidth' = maybe "" show minwidth
|
||||
-- maxwidth' = maybe "" (("."++).show) maxwidth
|
||||
-- fmt = "%" ++ justify ++ minwidth' ++ maxwidth' ++ "s"
|
||||
-- | Wrap a Text with the surrounding Text.
|
||||
wrap :: Text -> Text -> Text -> Text
|
||||
wrap start end x = start <> x <> end
|
||||
|
||||
-- | Remove trailing newlines/carriage returns.
|
||||
textChomp :: Text -> Text
|
||||
textChomp = T.dropWhileEnd (`elem` ['\r', '\n'])
|
||||
|
||||
-- | Clip and pad a string to a minimum & maximum width, and/or left/right justify it.
|
||||
-- Works on multi-line strings too (but will rewrite non-unix line endings).
|
||||
formatText :: Bool -> Maybe Int -> Maybe Int -> Text -> Text
|
||||
formatText leftJustified minwidth maxwidth t =
|
||||
T.intercalate "\n" . map (pad . clip) $ if T.null t then [""] else T.lines t
|
||||
where
|
||||
pad = maybe id justify minwidth
|
||||
clip = maybe id T.take maxwidth
|
||||
justify n = if leftJustified then T.justifyLeft n ' ' else T.justifyRight n ' '
|
||||
|
||||
-- underline :: String -> String
|
||||
-- underline s = s' ++ replicate (length s) '-' ++ "\n"
|
||||
@ -108,7 +124,7 @@ textElideRight width t =
|
||||
-- double-quoted.
|
||||
quoteIfSpaced :: T.Text -> T.Text
|
||||
quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
|
||||
| not $ any (`elem` (T.unpack s)) whitespacechars = s
|
||||
| not $ any (\c -> T.any (==c) s) whitespacechars = s
|
||||
| otherwise = textQuoteIfNeeded s
|
||||
|
||||
-- -- | Wrap a string in double quotes, and \-prefix any embedded single
|
||||
@ -122,7 +138,7 @@ quoteIfSpaced s | isSingleQuoted s || isDoubleQuoted s = s
|
||||
-- -- | Double-quote this string if it contains whitespace, single quotes
|
||||
-- -- or double-quotes, escaping the quotes as needed.
|
||||
textQuoteIfNeeded :: T.Text -> T.Text
|
||||
textQuoteIfNeeded s | any (`elem` T.unpack s) (quotechars++whitespacechars) = "\"" <> escapeDoubleQuotes s <> "\""
|
||||
textQuoteIfNeeded s | any (\c -> T.any (==c) s) (quotechars++whitespacechars) = "\"" <> escapeDoubleQuotes s <> "\""
|
||||
| otherwise = s
|
||||
|
||||
-- -- | Single-quote this string if it contains whitespace or double-quotes.
|
||||
@ -344,11 +360,22 @@ textTakeWidth w t | not (T.null t),
|
||||
= T.cons c $ textTakeWidth (w-cw) (T.tail t)
|
||||
| otherwise = ""
|
||||
|
||||
-- | Add a prefix to each line of a string.
|
||||
linesPrepend :: Text -> Text -> Text
|
||||
linesPrepend prefix = T.unlines . map (prefix<>) . T.lines
|
||||
|
||||
-- | Add a prefix to the first line of a string,
|
||||
-- and a different prefix to the remaining lines.
|
||||
linesPrepend2 :: Text -> Text -> Text -> Text
|
||||
linesPrepend2 prefix1 prefix2 s = T.unlines $ case T.lines s of
|
||||
[] -> []
|
||||
l:ls -> (prefix1<>l) : map (prefix2<>) ls
|
||||
|
||||
|
||||
-- | Read a decimal number from a Text. Assumes the input consists only of digit
|
||||
-- characters.
|
||||
readDecimal :: Text -> Integer
|
||||
readDecimal = foldl' step 0 . T.unpack
|
||||
readDecimal = T.foldl' step 0
|
||||
where step a c = a * 10 + toInteger (digitToInt c)
|
||||
|
||||
|
||||
|
@ -1,14 +1,25 @@
|
||||
-- | Text.Tabular.AsciiArt from tabular-0.2.2.7, modified to treat
|
||||
-- wide characters as double width.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Text.Tabular.AsciiWide where
|
||||
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Default (Default(..))
|
||||
import Data.List (intersperse, transpose)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import Data.Semigroup (stimesMonoid)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Data.Text.Lazy.Builder (Builder, fromString, fromText, singleton, toLazyText)
|
||||
import Safe (maximumMay)
|
||||
import Text.Tabular
|
||||
import Text.WideString (strWidth)
|
||||
import Text.WideString (WideBuilder(..), textWidth)
|
||||
|
||||
|
||||
-- | The options to use for rendering a table.
|
||||
@ -25,8 +36,7 @@ instance Default TableOpts where
|
||||
}
|
||||
|
||||
-- | Cell contents along an alignment
|
||||
data Cell = Cell Align [(String, Int)]
|
||||
deriving (Show)
|
||||
data Cell = Cell Align [WideBuilder]
|
||||
|
||||
-- | How to align text in a cell
|
||||
data Align = TopRight | BottomRight | BottomLeft | TopLeft
|
||||
@ -36,31 +46,40 @@ 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)]
|
||||
alignCell :: Align -> Text -> Cell
|
||||
alignCell a x = Cell a . map (\x -> WideBuilder (fromText x) (textWidth x)) $ if T.null x then [""] else T.lines x
|
||||
|
||||
-- | Return the width of a Cell.
|
||||
cellWidth :: Cell -> Int
|
||||
cellWidth (Cell _ xs) = fromMaybe 0 . maximumMay $ map snd xs
|
||||
cellWidth (Cell _ xs) = fromMaybe 0 . maximumMay $ map wbWidth 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 :: Bool -> (rh -> Text) -> (ch -> Text) -> (a -> Text) -> Table rh ch a -> TL.Text
|
||||
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 :: TableOpts -- ^ Options controlling Table rendering
|
||||
-- | Render a table according to various cell specifications>
|
||||
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 topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (Table rh ch cells) =
|
||||
unlines . addBorders $
|
||||
renderColumns topts sizes ch2
|
||||
: bar VM DoubleLine -- +======================================+
|
||||
: renderRs (fmap renderR $ zipHeader [] cellContents rowHeaders)
|
||||
-> TL.Text
|
||||
renderTable topts fr fc f = toLazyText . renderTableB topts fr fc f
|
||||
|
||||
-- | A version of renderTable which returns the underlying Builder.
|
||||
renderTableB :: 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
|
||||
-> Builder
|
||||
renderTableB topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (Table rh ch cells) =
|
||||
unlinesB . addBorders $
|
||||
renderColumns topts sizes ch2
|
||||
: bar VM DoubleLine -- +======================================+
|
||||
: renderRs (fmap renderR $ zipHeader [] cellContents rowHeaders)
|
||||
where
|
||||
renderR (cs,h) = renderColumns topts sizes $ Group DoubleLine
|
||||
[ Header h
|
||||
@ -83,63 +102,68 @@ renderTable topts@TableOpts{prettyTable=pretty, tableBorders=borders} fr fc f (T
|
||||
|
||||
-- borders and bars
|
||||
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
|
||||
bar vpos prop = mconcat $ renderHLine vpos borders pretty sizes ch2 prop
|
||||
unlinesB = (<>singleton '\n') . mconcat . intersperse "\n"
|
||||
|
||||
-- | 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
|
||||
renderRow :: TableOpts -> Header Cell -> TL.Text
|
||||
renderRow topts = toLazyText . renderRowB topts
|
||||
|
||||
-- | A version of renderRow which returns the underlying Builder.
|
||||
renderRowB:: TableOpts -> Header Cell -> Builder
|
||||
renderRowB topts h = renderColumns topts is h
|
||||
where is = map cellWidth $ headerContents h
|
||||
|
||||
|
||||
verticalBar :: Bool -> Char
|
||||
verticalBar pretty = if pretty then '│' else '|'
|
||||
|
||||
leftBar :: Bool -> Bool -> String
|
||||
leftBar pretty True = verticalBar pretty : " "
|
||||
leftBar pretty False = [verticalBar pretty]
|
||||
leftBar :: Bool -> Bool -> Builder
|
||||
leftBar pretty True = fromString $ verticalBar pretty : " "
|
||||
leftBar pretty False = singleton $ verticalBar pretty
|
||||
|
||||
rightBar :: Bool -> Bool -> String
|
||||
rightBar pretty True = ' ' : [verticalBar pretty]
|
||||
rightBar pretty False = [verticalBar pretty]
|
||||
rightBar :: Bool -> Bool -> Builder
|
||||
rightBar pretty True = fromString $ ' ' : [verticalBar pretty]
|
||||
rightBar pretty False = singleton $ verticalBar pretty
|
||||
|
||||
midBar :: Bool -> Bool -> String
|
||||
midBar pretty True = ' ' : verticalBar pretty : " "
|
||||
midBar pretty False = [verticalBar pretty]
|
||||
midBar :: Bool -> Bool -> Builder
|
||||
midBar pretty True = fromString $ ' ' : verticalBar pretty : " "
|
||||
midBar pretty False = singleton $ verticalBar pretty
|
||||
|
||||
doubleMidBar :: Bool -> Bool -> String
|
||||
doubleMidBar pretty True = if pretty then " ║ " else " || "
|
||||
doubleMidBar pretty False = if pretty then "║" else "||"
|
||||
doubleMidBar :: Bool -> Bool -> Builder
|
||||
doubleMidBar pretty True = fromText $ if pretty then " ║ " else " || "
|
||||
doubleMidBar pretty False = fromText $ if pretty then "║" else "||"
|
||||
|
||||
-- | We stop rendering on the shortest list!
|
||||
renderColumns :: TableOpts -- ^ rendering options for the table
|
||||
-> [Int] -- ^ max width for each column
|
||||
-> Header Cell
|
||||
-> String
|
||||
-> Builder
|
||||
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
|
||||
mconcat . intersperse "\n" -- Put each line on its own line
|
||||
. map (addBorders . mconcat) . 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
|
||||
padCell (w, Cell TopLeft ls) = map (\x -> wbBuilder x <> fromText (T.replicate (w - wbWidth x) " ")) ls
|
||||
padCell (w, Cell BottomLeft ls) = map (\x -> wbBuilder x <> fromText (T.replicate (w - wbWidth x) " ")) ls
|
||||
padCell (w, Cell TopRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder x) ls
|
||||
padCell (w, Cell BottomRight ls) = map (\x -> fromText (T.replicate (w - wbWidth x) " ") <> wbBuilder 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
|
||||
padRow (Cell TopLeft ls) = Cell TopLeft $ ls ++ replicate (nLines - length ls) mempty
|
||||
padRow (Cell TopRight ls) = Cell TopRight $ ls ++ replicate (nLines - length ls) mempty
|
||||
padRow (Cell BottomLeft ls) = Cell BottomLeft $ replicate (nLines - length ls) mempty ++ ls
|
||||
padRow (Cell BottomRight ls) = Cell BottomRight $ replicate (nLines - length ls) mempty ++ ls
|
||||
|
||||
hsep :: Properties -> [String]
|
||||
hsep :: Properties -> [Builder]
|
||||
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 ++ " "
|
||||
addBorders xs | borders = leftBar pretty spaces <> xs <> rightBar pretty spaces
|
||||
| spaces = fromText " " <> xs <> fromText " "
|
||||
| otherwise = xs
|
||||
|
||||
nLines = fromMaybe 0 . maximumMay . map (\(Cell _ ls) -> length ls) $ headerContents h
|
||||
@ -150,52 +174,48 @@ renderHLine :: VPos
|
||||
-> [Int] -- ^ width specifications
|
||||
-> Header a
|
||||
-> Properties
|
||||
-> [String]
|
||||
-> [Builder]
|
||||
renderHLine _ _ _ _ _ NoLine = []
|
||||
renderHLine vpos borders pretty w h prop = [renderHLine' vpos borders pretty prop w h]
|
||||
|
||||
renderHLine' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> String
|
||||
renderHLine' vpos borders pretty prop is h = addBorders $ sep ++ coreLine ++ sep
|
||||
renderHLine' :: VPos -> Bool -> Bool -> Properties -> [Int] -> Header a -> Builder
|
||||
renderHLine' vpos borders pretty prop is h = addBorders $ sep <> coreLine <> sep
|
||||
where
|
||||
addBorders xs = if borders then edge HL ++ xs ++ edge HR else xs
|
||||
addBorders xs = if borders then edge HL <> xs <> edge HR else xs
|
||||
edge hpos = boxchar vpos hpos SingleLine prop pretty
|
||||
coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h
|
||||
coreLine = foldMap helper $ flattenHeader $ zipHeader 0 is h
|
||||
helper = either vsep dashes
|
||||
dashes (i,_) = concat (replicate i sep)
|
||||
dashes (i,_) = stimesMonoid i sep
|
||||
sep = boxchar vpos HM NoLine prop pretty
|
||||
vsep v = case v of
|
||||
NoLine -> sep ++ sep
|
||||
_ -> sep ++ cross v prop ++ sep
|
||||
NoLine -> sep <> sep
|
||||
_ -> sep <> cross v prop <> sep
|
||||
cross v h = boxchar vpos HM v h pretty
|
||||
|
||||
data VPos = VT | VM | VB -- top middle bottom
|
||||
data HPos = HL | HM | HR -- left middle right
|
||||
|
||||
boxchar :: VPos -> HPos -> Properties -> Properties -> Bool -> String
|
||||
boxchar :: VPos -> HPos -> Properties -> Properties -> Bool -> Builder
|
||||
boxchar vpos hpos vert horiz = lineart u d l r
|
||||
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
|
||||
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
|
||||
pick :: Text -> Text -> Bool -> Builder
|
||||
pick x _ True = fromText x
|
||||
pick _ x False = fromText x
|
||||
|
||||
lineart :: Properties -> Properties -> Properties -> Properties -> Bool -> String
|
||||
lineart :: Properties -> Properties -> Properties -> Properties -> Bool -> Builder
|
||||
-- up down left right
|
||||
lineart SingleLine SingleLine SingleLine SingleLine = pick "┼" "+"
|
||||
lineart SingleLine SingleLine SingleLine NoLine = pick "┤" "+"
|
||||
@ -244,6 +264,4 @@ lineart NoLine SingleLine DoubleLine DoubleLine = pick "╤" "+"
|
||||
lineart SingleLine SingleLine DoubleLine DoubleLine = pick "╪" "+"
|
||||
lineart DoubleLine DoubleLine SingleLine SingleLine = pick "╫" "++"
|
||||
|
||||
lineart _ _ _ _ = const ""
|
||||
|
||||
--
|
||||
lineart _ _ _ _ = const mempty
|
||||
|
@ -1,14 +1,49 @@
|
||||
-- | Calculate the width of String and Text, being aware of wide characters.
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Text.WideString (
|
||||
-- * wide-character-aware layout
|
||||
strWidth,
|
||||
textWidth,
|
||||
charWidth
|
||||
charWidth,
|
||||
-- * Text Builders which keep track of length
|
||||
WideBuilder(..),
|
||||
wbUnpack,
|
||||
wbToText
|
||||
) where
|
||||
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup (Semigroup(..))
|
||||
#endif
|
||||
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
|
||||
|
||||
|
||||
-- | Helper for constructing Builders while keeping track of text width.
|
||||
data WideBuilder = WideBuilder
|
||||
{ wbBuilder :: !TB.Builder
|
||||
, wbWidth :: !Int
|
||||
}
|
||||
|
||||
instance Semigroup WideBuilder where
|
||||
WideBuilder x i <> WideBuilder y j = WideBuilder (x <> y) (i + j)
|
||||
|
||||
instance Monoid WideBuilder where
|
||||
mempty = WideBuilder mempty 0
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
mappend = (<>)
|
||||
#endif
|
||||
|
||||
-- | Convert a WideBuilder to a strict Text.
|
||||
wbToText :: WideBuilder -> Text
|
||||
wbToText = TL.toStrict . TB.toLazyText . wbBuilder
|
||||
|
||||
-- | Convert a WideBuilder to a String.
|
||||
wbUnpack :: WideBuilder -> String
|
||||
wbUnpack = TL.unpack . TB.toLazyText . wbBuilder
|
||||
|
||||
|
||||
-- | Calculate the render width of a string, considering
|
||||
|
@ -1,6 +1,6 @@
|
||||
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
|
||||
--
|
||||
@ -125,7 +125,6 @@ library
|
||||
, pretty-simple >4 && <5
|
||||
, regex-tdfa
|
||||
, safe >=0.2
|
||||
, split >=0.1
|
||||
, tabular >=0.2
|
||||
, tasty >=1.2.3
|
||||
, tasty-hunit >=0.10.0.2
|
||||
@ -176,7 +175,6 @@ test-suite doctest
|
||||
, pretty-simple >4 && <5
|
||||
, regex-tdfa
|
||||
, safe >=0.2
|
||||
, split >=0.1
|
||||
, tabular >=0.2
|
||||
, tasty >=1.2.3
|
||||
, tasty-hunit >=0.10.0.2
|
||||
@ -229,7 +227,6 @@ test-suite unittest
|
||||
, pretty-simple >4 && <5
|
||||
, regex-tdfa
|
||||
, safe >=0.2
|
||||
, split >=0.1
|
||||
, tabular >=0.2
|
||||
, tasty >=1.2.3
|
||||
, tasty-hunit >=0.10.0.2
|
||||
|
@ -58,7 +58,6 @@ dependencies:
|
||||
- pretty-simple >4 && <5
|
||||
- regex-tdfa
|
||||
- safe >=0.2
|
||||
- split >=0.1
|
||||
- tabular >=0.2
|
||||
- tasty >=1.2.3
|
||||
- tasty-hunit >=0.10.0.2
|
||||
|
@ -175,7 +175,7 @@ asDraw UIState{aopts=_uopts@UIOpts{cliopts_=copts@CliOpts{reportspec_=rspec}}
|
||||
<+> toggles
|
||||
<+> str (" account " ++ if ishistorical then "balances" else "changes")
|
||||
<+> borderPeriodStr (if ishistorical then "at end of" else "in") (period_ ropts)
|
||||
<+> borderQueryStr (unwords . map (quoteIfNeeded . T.unpack) $ querystring_ ropts)
|
||||
<+> borderQueryStr (T.unpack . T.unwords . map textQuoteIfNeeded $ querystring_ ropts)
|
||||
<+> borderDepthStr mdepth
|
||||
<+> str (" ("++curidx++"/"++totidx++")")
|
||||
<+> (if ignore_assertions_ $ inputopts_ copts
|
||||
|
@ -141,8 +141,8 @@ runBrickUi uopts@UIOpts{cliopts_=copts@CliOpts{inputopts_=_iopts,reportspec_=rsp
|
||||
where
|
||||
acct = headDef (error' $ "--register "++apat++" did not match any account") -- PARTIAL:
|
||||
. filterAccts $ journalAccountNames j
|
||||
filterAccts = case toRegexCI apat of
|
||||
Right re -> filter (regexMatch re . T.unpack)
|
||||
filterAccts = case toRegexCI $ T.pack apat of
|
||||
Right re -> filter (regexMatchText re)
|
||||
Left _ -> const []
|
||||
-- Initialising the accounts screen is awkward, requiring
|
||||
-- another temporary UIState value..
|
||||
|
@ -14,7 +14,6 @@ where
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.List
|
||||
import Data.List.Split (splitOn)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Monoid ((<>))
|
||||
#endif
|
||||
@ -80,7 +79,7 @@ rsInit d reset ui@UIState{aopts=_uopts@UIOpts{cliopts_=CliOpts{reportspec_=rspec
|
||||
,Not generatedTransactionTag
|
||||
]
|
||||
|
||||
(_label,items) = accountTransactionsReport rspec' j q thisacctq
|
||||
items = accountTransactionsReport rspec' j q thisacctq
|
||||
items' = (if empty_ ropts then id else filter (not . mixedAmountLooksZero . fifth6)) $ -- without --empty, exclude no-change txns
|
||||
reverse -- most recent last
|
||||
items
|
||||
@ -89,17 +88,17 @@ rsInit d reset ui@UIState{aopts=_uopts@UIOpts{cliopts_=CliOpts{reportspec_=rspec
|
||||
displayitems = map displayitem items'
|
||||
where
|
||||
displayitem (t, _, _issplit, otheracctsstr, change, bal) =
|
||||
RegisterScreenItem{rsItemDate = showDate $ transactionRegisterDate q thisacctq t
|
||||
RegisterScreenItem{rsItemDate = T.unpack . showDate $ transactionRegisterDate q thisacctq t
|
||||
,rsItemStatus = tstatus t
|
||||
,rsItemDescription = T.unpack $ tdescription t
|
||||
,rsItemOtherAccounts = case splitOn ", " otheracctsstr of
|
||||
[s] -> s
|
||||
ss -> intercalate ", " ss
|
||||
,rsItemOtherAccounts = T.unpack otheracctsstr
|
||||
-- _ -> "<split>" -- should do this if accounts field width < 30
|
||||
,rsItemChangeAmount = showMixedOneLine showAmountWithoutPrice Nothing (Just 32) False change
|
||||
,rsItemBalanceAmount = showMixedOneLine showAmountWithoutPrice Nothing (Just 32) False bal
|
||||
,rsItemChangeAmount = showamt change
|
||||
,rsItemBalanceAmount = showamt bal
|
||||
,rsItemTransaction = t
|
||||
}
|
||||
where showamt = (\wb -> (wbUnpack wb, wbWidth wb))
|
||||
. showMixedAmountB oneLine{displayMaxWidth=Just 32}
|
||||
-- blank items are added to allow more control of scroll position; we won't allow movement over these.
|
||||
-- XXX Ugly. Changing to 0 helps when debugging.
|
||||
blankitems = replicate 100 -- "100 ought to be enough for anyone"
|
||||
@ -204,7 +203,7 @@ rsDraw UIState{aopts=_uopts@UIOpts{cliopts_=copts@CliOpts{reportspec_=rspec}}
|
||||
<+> togglefilters
|
||||
<+> str " transactions"
|
||||
-- <+> str (if ishistorical then " historical total" else " period total")
|
||||
<+> borderQueryStr (unwords . map (quoteIfNeeded . T.unpack) $ querystring_ ropts)
|
||||
<+> borderQueryStr (T.unpack . T.unwords . map textQuoteIfNeeded $ querystring_ ropts)
|
||||
-- <+> str " and subs"
|
||||
<+> borderPeriodStr "in" (period_ ropts)
|
||||
<+> str " ("
|
||||
|
@ -79,9 +79,10 @@ tsDraw UIState{aopts=UIOpts{cliopts_=copts@CliOpts{reportspec_=rspec@ReportSpec{
|
||||
fromMaybe (error' "TransactionScreen: expected a non-empty journal") $ -- PARTIAL: shouldn't happen
|
||||
reportPeriodOrJournalLastDay rspec j
|
||||
|
||||
render $ defaultLayout toplabel bottomlabel $ str $
|
||||
showTransactionOneLineAmounts $
|
||||
maybe t (transactionApplyValuation prices styles periodlast (rsToday rspec) t) $ value_ ropts
|
||||
render . defaultLayout toplabel bottomlabel . str
|
||||
. T.unpack . showTransactionOneLineAmounts
|
||||
. maybe t (transactionApplyValuation prices styles periodlast (rsToday rspec) t)
|
||||
$ value_ ropts
|
||||
-- (if real_ ropts then filterTransactionPostings (Real True) else id) -- filter postings by --real
|
||||
where
|
||||
toplabel =
|
||||
@ -208,7 +209,7 @@ regenerateTransactions rspec j s acct i ui =
|
||||
let
|
||||
q = filterQuery (not . queryIsDepth) $ rsQuery rspec
|
||||
thisacctq = Acct $ accountNameToAccountRegex acct -- includes subs
|
||||
items = reverse $ snd $ accountTransactionsReport rspec j q thisacctq
|
||||
items = reverse $ accountTransactionsReport rspec j q thisacctq
|
||||
ts = map first6 items
|
||||
numberedts = zip [1..] ts
|
||||
-- select the best current transaction from the new list
|
||||
|
@ -308,7 +308,7 @@ showMinibuffer :: UIState -> UIState
|
||||
showMinibuffer ui = setMode (Minibuffer e) ui
|
||||
where
|
||||
e = applyEdit gotoEOL $ editor MinibufferEditor (Just 1) oldq
|
||||
oldq = unwords . map (quoteIfNeeded . T.unpack)
|
||||
oldq = T.unpack . T.unwords . map textQuoteIfNeeded
|
||||
. querystring_ . rsOpts . reportspec_ . cliopts_ $ aopts ui
|
||||
|
||||
-- | Close the minibuffer, discarding any edit in progress.
|
||||
|
@ -38,6 +38,7 @@ import Data.List
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Monoid
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import Graphics.Vty
|
||||
(Event(..),Key(..),Modifier(..),Vty(..),Color,Attr,currentAttr,refresh
|
||||
-- ,Output(displayBounds,mkDisplayContext),DisplayContext(..)
|
||||
@ -189,7 +190,7 @@ borderDepthStr (Just d) = str " to depth " <+> withAttr ("border" <> "query") (s
|
||||
|
||||
borderPeriodStr :: String -> Period -> Widget Name
|
||||
borderPeriodStr _ PeriodAll = str ""
|
||||
borderPeriodStr preposition p = str (" "++preposition++" ") <+> withAttr ("border" <> "query") (str $ showPeriod p)
|
||||
borderPeriodStr preposition p = str (" "++preposition++" ") <+> withAttr ("border" <> "query") (str . T.unpack $ showPeriod p)
|
||||
|
||||
borderKeysStr :: [(String,String)] -> Widget Name
|
||||
borderKeysStr = borderKeysStr' . map (\(a,b) -> (a, str b))
|
||||
|
@ -27,7 +27,7 @@ getJournalR = do
|
||||
Just (a, inclsubs) -> "Transactions in " <> a <> if inclsubs then "" else " (excluding subaccounts)"
|
||||
title' = title <> if m /= Any then ", filtered" else ""
|
||||
acctlink a = (RegisterR, [("q", replaceInacct q $ accountQuery a)])
|
||||
(_, items) = transactionsReport (rsOpts . reportspec_ $ cliopts_ opts) j m
|
||||
items = transactionsReport (rsOpts . reportspec_ $ cliopts_ opts) j m
|
||||
transactionFrag = transactionFragment j
|
||||
|
||||
defaultLayout $ do
|
||||
|
@ -44,8 +44,11 @@ getRegisterR = do
|
||||
zip xs $
|
||||
zip (map (T.unpack . accountSummarisedName . paccount) xs) $
|
||||
tail $ (", "<$xs) ++ [""]
|
||||
r@(balancelabel,items) = accountTransactionsReport rspec j m acctQuery
|
||||
balancelabel' = if isJust (inAccount qopts) then balancelabel else "Total"
|
||||
items = accountTransactionsReport rspec j m acctQuery
|
||||
balancelabel
|
||||
| isJust (inAccount qopts), balancetype_ (rsOpts rspec) == HistoricalBalance = "Historical Total"
|
||||
| isJust (inAccount qopts) = "Period Total"
|
||||
| otherwise = "Total"
|
||||
transactionFrag = transactionFragment j
|
||||
defaultLayout $ do
|
||||
setTitle "register - hledger-web"
|
||||
@ -96,14 +99,12 @@ decorateLinks =
|
||||
|
||||
-- | Generate javascript/html for a register balance line chart based on
|
||||
-- the provided "TransactionsReportItem"s.
|
||||
registerChartHtml :: [(CommoditySymbol, (String, [TransactionsReportItem]))] -> HtmlUrl AppRoute
|
||||
registerChartHtml percommoditytxnreports = $(hamletFile "templates/chart.hamlet")
|
||||
registerChartHtml :: String -> [(CommoditySymbol, [TransactionsReportItem])] -> HtmlUrl AppRoute
|
||||
registerChartHtml title percommoditytxnreports = $(hamletFile "templates/chart.hamlet")
|
||||
-- have to make sure plot is not called when our container (maincontent)
|
||||
-- is hidden, eg with add form toggled
|
||||
where
|
||||
charttitle = case maybe "" (fst . snd) $ listToMaybe percommoditytxnreports of
|
||||
"" -> ""
|
||||
s -> s <> ":"
|
||||
charttitle = if null title then "" else title ++ ":"
|
||||
colorForCommodity = fromMaybe 0 . flip lookup commoditiesIndex
|
||||
commoditiesIndex = zip (map fst percommoditytxnreports) [0..] :: [(CommoditySymbol,Int)]
|
||||
simpleMixedAmountQuantity = maybe 0 aquantity . listToMaybe . amounts
|
||||
|
@ -6,7 +6,7 @@
|
||||
if ($chartdiv.is(':visible')) {
|
||||
\$('#register-chart-label').text('#{charttitle}');
|
||||
var seriesData = [
|
||||
$forall (c,(_,items)) <- percommoditytxnreports
|
||||
$forall (c,items) <- percommoditytxnreports
|
||||
/* we render each commodity using two series:
|
||||
* one with extra data points added to show a stepped balance line */
|
||||
{
|
||||
@ -38,7 +38,7 @@
|
||||
#{simpleMixedAmountQuantity $ triCommodityBalance c i},
|
||||
'#{showMixedAmountWithZeroCommodity $ triCommodityAmount c i}',
|
||||
'#{showMixedAmountWithZeroCommodity $ triCommodityBalance c i}',
|
||||
'#{concat $ intersperse "\\n" $ lines $ showTransaction $ triOrigTransaction i}',
|
||||
'#{concat $ intersperse "\\n" $ lines $ T.unpack $ showTransaction $ triOrigTransaction i}',
|
||||
#{tindex $ triOrigTransaction i}
|
||||
],
|
||||
/* [] */
|
||||
|
@ -2,7 +2,7 @@
|
||||
#{header}
|
||||
|
||||
<div .hidden-xs>
|
||||
^{registerChartHtml $ transactionsReportByCommodity r}
|
||||
^{registerChartHtml balancelabel $ transactionsReportByCommodity items}
|
||||
|
||||
<div.table-responsive>
|
||||
<table .table.table-striped.table-condensed>
|
||||
@ -15,7 +15,7 @@
|
||||
<th style="text-align:left;">To/From Account(s)
|
||||
<th style="text-align:right; white-space:normal;">Amount Out/In
|
||||
<th style="text-align:right; white-space:normal;">
|
||||
#{balancelabel'}
|
||||
#{balancelabel}
|
||||
|
||||
<tbody>
|
||||
$forall (torig, tacct, split, _acct, amt, bal) <- items
|
||||
|
@ -27,16 +27,19 @@ import Data.Either (isRight)
|
||||
import Data.Functor.Identity (Identity(..))
|
||||
import "base-compat-batteries" Data.List.Compat
|
||||
import qualified Data.Set as S
|
||||
import Data.Maybe
|
||||
import Data.Maybe (fromJust, fromMaybe, isJust)
|
||||
import Data.Text (Text)
|
||||
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.Calendar (Day)
|
||||
import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat)
|
||||
import Safe (headDef, headMay, atMay)
|
||||
import System.Console.CmdArgs.Explicit
|
||||
import System.Console.CmdArgs.Explicit (flagNone)
|
||||
import System.Console.Haskeline (runInputT, defaultSettings, setComplete)
|
||||
import System.Console.Haskeline.Completion
|
||||
import System.Console.Wizard
|
||||
import System.Console.Haskeline.Completion (CompletionFunc, completeWord, isFinished, noCompletion, simpleCompletion)
|
||||
import System.Console.Wizard (Wizard, defaultTo, line, output, retryMsg, linePrewritten, nonEmpty, parser, run)
|
||||
import System.Console.Wizard.Haskeline
|
||||
import System.IO ( stderr, hPutStr, hPutStrLn )
|
||||
import Text.Megaparsec
|
||||
@ -89,7 +92,7 @@ add :: CliOpts -> Journal -> IO ()
|
||||
add opts j
|
||||
| journalFilePath j == "-" = return ()
|
||||
| otherwise = do
|
||||
hPrintf stderr "Adding transactions to journal file %s\n" (journalFilePath j)
|
||||
hPutStrLn stderr $ "Adding transactions to journal file " <> journalFilePath j
|
||||
showHelp
|
||||
today <- getCurrentDay
|
||||
let es = defEntryState{esOpts=opts
|
||||
@ -123,16 +126,16 @@ getAndAddTransactions es@EntryState{..} = (do
|
||||
Nothing -> error "Could not interpret the input, restarting" -- caught below causing a restart, I believe -- PARTIAL:
|
||||
Just t -> do
|
||||
j <- if debug_ esOpts > 0
|
||||
then do hPrintf stderr "Skipping journal add due to debug mode.\n"
|
||||
then do hPutStrLn stderr "Skipping journal add due to debug mode."
|
||||
return esJournal
|
||||
else do j' <- journalAddTransaction esJournal esOpts t
|
||||
hPrintf stderr "Saved.\n"
|
||||
hPutStrLn stderr "Saved."
|
||||
return j'
|
||||
hPrintf stderr "Starting the next transaction (. or ctrl-D/ctrl-C to quit)\n"
|
||||
hPutStrLn stderr "Starting the next transaction (. or ctrl-D/ctrl-C to quit)"
|
||||
getAndAddTransactions es{esJournal=j, esDefDate=tdate t}
|
||||
)
|
||||
`E.catch` (\(_::RestartTransactionException) ->
|
||||
hPrintf stderr "Restarting this transaction.\n" >> getAndAddTransactions es)
|
||||
hPutStrLn stderr "Restarting this transaction." >> getAndAddTransactions es)
|
||||
|
||||
data TxnParams = TxnParams
|
||||
{ txnDate :: Day
|
||||
@ -164,7 +167,8 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
|
||||
{ esArgs = drop 1 esArgs
|
||||
, esDefDate = date
|
||||
}
|
||||
dateAndCodeString = formatTime defaultTimeLocale yyyymmddFormat date ++ (if T.null code then "" else " (" ++ T.unpack code ++ ")")
|
||||
dateAndCodeString = formatTime defaultTimeLocale yyyymmddFormat date
|
||||
++ T.unpack (if T.null code then "" else " (" <> code <> ")")
|
||||
yyyymmddFormat = iso8601DateFormat Nothing
|
||||
confirmedTransactionWizard prevInput{prevDateAndCode=Just dateAndCodeString} es' (EnterDescAndComment (date, code) : stack)
|
||||
Nothing ->
|
||||
@ -180,7 +184,9 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
|
||||
}
|
||||
descAndCommentString = T.unpack $ desc <> (if T.null comment then "" else " ; " <> comment)
|
||||
prevInput' = prevInput{prevDescAndCmnt=Just descAndCommentString}
|
||||
when (isJust mbaset) $ liftIO $ hPrintf stderr "Using this similar transaction for defaults:\n%s" (showTransaction $ fromJust mbaset)
|
||||
when (isJust mbaset) . liftIO $ do
|
||||
hPutStrLn stderr "Using this similar transaction for defaults:"
|
||||
T.hPutStr stderr $ showTransaction (fromJust mbaset)
|
||||
confirmedTransactionWizard prevInput' es' ((EnterNewPosting TxnParams{txnDate=date, txnCode=code, txnDesc=desc, txnCmnt=comment} Nothing) : stack)
|
||||
Nothing ->
|
||||
confirmedTransactionWizard prevInput es (drop 1 stack)
|
||||
@ -232,14 +238,14 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
|
||||
,pcomment=comment
|
||||
,ptype=accountNamePostingType $ T.pack account
|
||||
}
|
||||
amountAndCommentString = showAmount amount ++ (if T.null comment then "" else " ;" ++ T.unpack comment)
|
||||
amountAndCommentString = showAmount amount ++ T.unpack (if T.null comment then "" else " ;" <> comment)
|
||||
prevAmountAndCmnt' = replaceNthOrAppend (length esPostings) amountAndCommentString (prevAmountAndCmnt prevInput)
|
||||
es' = es{esPostings=esPostings++[posting], esArgs=drop 2 esArgs}
|
||||
confirmedTransactionWizard prevInput{prevAmountAndCmnt=prevAmountAndCmnt'} es' (EnterNewPosting txnParams (Just posting) : stack)
|
||||
Nothing -> confirmedTransactionWizard prevInput es (drop 1 stack)
|
||||
|
||||
EndStage t -> do
|
||||
output $ showTransaction t
|
||||
output . T.unpack $ showTransaction t
|
||||
y <- let def = "y" in
|
||||
retryMsg "Please enter y or n." $
|
||||
parser ((fmap (\c -> if c == '<' then Nothing else Just c)) . headMay . map toLower . strip) $
|
||||
@ -262,7 +268,7 @@ similarTransaction EntryState{..} desc =
|
||||
in bestmatch
|
||||
|
||||
dateAndCodeWizard PrevInput{..} EntryState{..} = do
|
||||
let def = headDef (showDate esDefDate) esArgs
|
||||
let def = headDef (T.unpack $ showDate esDefDate) esArgs
|
||||
retryMsg "A valid hledger smart date is required. Eg: 2014/2/14, 14, yesterday." $
|
||||
parser (parseSmartDateAndCode esToday) $
|
||||
withCompletion (dateCompleter def) $
|
||||
@ -303,7 +309,7 @@ accountWizard PrevInput{..} EntryState{..} = do
|
||||
historicalp = fmap ((!! (pnum - 1)) . (++ (repeat nullposting)) . tpostings) esSimilarTransaction
|
||||
historicalacct = case historicalp of Just p -> showAccountName Nothing (ptype p) (paccount p)
|
||||
Nothing -> ""
|
||||
def = headDef historicalacct esArgs
|
||||
def = headDef (T.unpack historicalacct) esArgs
|
||||
endmsg | canfinish && null def = " (or . or enter to finish this transaction)"
|
||||
| canfinish = " (or . to finish this transaction)"
|
||||
| otherwise = ""
|
||||
@ -367,7 +373,7 @@ amountAndCommentWizard PrevInput{..} EntryState{..} = do
|
||||
balancingamt = negate $ sum $ map pamount realps where realps = filter isReal esPostings
|
||||
balancingamtfirstcommodity = Mixed $ take 1 $ amounts balancingamt
|
||||
showamt =
|
||||
showMixedAmountWithPrecision
|
||||
showMixedAmount . setMixedAmountPrecision
|
||||
-- what should this be ?
|
||||
-- 1 maxprecision (show all decimal places or none) ?
|
||||
-- 2 maxprecisionwithpoint (show all decimal places or .0 - avoids some but not all confusion with thousands separators) ?
|
||||
@ -442,7 +448,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 (showTransaction t)
|
||||
return j{jtxns=ts++[t]}
|
||||
|
||||
-- | Append a string, typically one or more transactions, to a journal
|
||||
@ -453,20 +459,20 @@ journalAddTransaction j@Journal{jtxns=ts} opts t = do
|
||||
-- even if the file uses dos line endings (\r\n), which could leave
|
||||
-- mixed line endings in the file. See also writeFileWithBackupIfChanged.
|
||||
--
|
||||
appendToJournalFileOrStdout :: FilePath -> String -> IO ()
|
||||
appendToJournalFileOrStdout :: FilePath -> Text -> IO ()
|
||||
appendToJournalFileOrStdout f s
|
||||
| f == "-" = putStr s'
|
||||
| otherwise = appendFile f s'
|
||||
where s' = "\n" ++ ensureOneNewlineTerminated s
|
||||
| f == "-" = T.putStr s'
|
||||
| otherwise = appendFile f $ T.unpack s'
|
||||
where s' = "\n" <> ensureOneNewlineTerminated s
|
||||
|
||||
-- | Replace a string's 0 or more terminating newlines with exactly one.
|
||||
ensureOneNewlineTerminated :: String -> String
|
||||
ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse
|
||||
ensureOneNewlineTerminated :: Text -> Text
|
||||
ensureOneNewlineTerminated = (<>"\n") . T.dropWhileEnd (=='\n')
|
||||
|
||||
-- | Convert a string of journal data into a register report.
|
||||
registerFromString :: String -> IO String
|
||||
registerFromString :: T.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}
|
||||
|
@ -19,18 +19,14 @@ module Hledger.Cli.Commands.Aregister (
|
||||
,tests_Aregister
|
||||
) where
|
||||
|
||||
import Data.Aeson (toJSON)
|
||||
import Data.Aeson.Text (encodeToLazyText)
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import Data.List (intersperse)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import Data.Time (addDays)
|
||||
import Safe (headDef)
|
||||
import System.Console.CmdArgs.Explicit
|
||||
import System.Console.CmdArgs.Explicit (flagNone, flagReq)
|
||||
import Hledger.Read.CsvReader (CSV, CsvRecord, printCSV)
|
||||
|
||||
import Hledger
|
||||
@ -81,8 +77,8 @@ aregister opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
|
||||
let
|
||||
acct = headDef (error' $ show apat++" did not match any account") -- PARTIAL:
|
||||
. filterAccts $ journalAccountNames j
|
||||
filterAccts = case toRegexCI apat of
|
||||
Right re -> filter (regexMatch re . T.unpack)
|
||||
filterAccts = case toRegexCI $ T.pack apat of
|
||||
Right re -> filter (regexMatchText re)
|
||||
Left _ -> const []
|
||||
-- gather report options
|
||||
inclusive = True -- tree_ ropts
|
||||
@ -109,21 +105,21 @@ aregister opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
|
||||
]
|
||||
-- run the report
|
||||
-- TODO: need to also pass the queries so we can choose which date to render - move them into the report ?
|
||||
(balancelabel,items) = accountTransactionsReport rspec' j reportq thisacctq
|
||||
items = accountTransactionsReport rspec' j reportq thisacctq
|
||||
items' = (if empty_ ropts then id else filter (not . mixedAmountLooksZero . fifth6)) $
|
||||
reverse items
|
||||
-- select renderer
|
||||
render | fmt=="json" = (++"\n") . T.unpack . TL.toStrict . encodeToLazyText . toJSON
|
||||
| fmt=="csv" = (++"\n") . printCSV . accountTransactionsReportAsCsv reportq thisacctq
|
||||
| fmt=="txt" = accountTransactionsReportAsText opts reportq thisacctq
|
||||
| otherwise = const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
||||
render | fmt=="txt" = accountTransactionsReportAsText opts reportq thisacctq
|
||||
| fmt=="csv" = printCSV . accountTransactionsReportAsCsv reportq thisacctq
|
||||
| fmt=="json" = toJsonText
|
||||
| otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
||||
where
|
||||
fmt = outputFormatFromOpts opts
|
||||
|
||||
writeOutput opts $ render (balancelabel,items')
|
||||
writeOutputLazyText opts $ render items'
|
||||
|
||||
accountTransactionsReportAsCsv :: Query -> Query -> AccountTransactionsReport -> CSV
|
||||
accountTransactionsReportAsCsv reportq thisacctq (_,is) =
|
||||
accountTransactionsReportAsCsv reportq thisacctq is =
|
||||
["txnidx","date","code","description","otheraccounts","change","balance"]
|
||||
: map (accountTransactionsReportItemAsCsvRecord reportq thisacctq) is
|
||||
|
||||
@ -131,34 +127,32 @@ accountTransactionsReportItemAsCsvRecord :: Query -> Query -> AccountTransaction
|
||||
accountTransactionsReportItemAsCsvRecord
|
||||
reportq thisacctq
|
||||
(t@Transaction{tindex,tcode,tdescription}, _, _issplit, otheracctsstr, change, balance)
|
||||
= [idx,date,code,desc,otheracctsstr,amt,bal]
|
||||
= [idx,date,tcode,tdescription,otheracctsstr,amt,bal]
|
||||
where
|
||||
idx = show tindex
|
||||
idx = T.pack $ show tindex
|
||||
date = showDate $ transactionRegisterDate reportq thisacctq t
|
||||
code = T.unpack tcode
|
||||
desc = T.unpack tdescription
|
||||
amt = showMixedAmountOneLineWithoutPrice False change
|
||||
bal = showMixedAmountOneLineWithoutPrice False balance
|
||||
amt = wbToText $ showMixedAmountB oneLine change
|
||||
bal = wbToText $ showMixedAmountB oneLine balance
|
||||
|
||||
-- | Render a register report as plain text suitable for console output.
|
||||
accountTransactionsReportAsText :: CliOpts -> Query -> Query -> AccountTransactionsReport -> String
|
||||
accountTransactionsReportAsText
|
||||
copts@CliOpts{reportspec_=ReportSpec{rsOpts=ReportOpts{no_elide_}}} reportq thisacctq (_balancelabel,items)
|
||||
= unlines $ title :
|
||||
accountTransactionsReportAsText :: CliOpts -> Query -> Query -> AccountTransactionsReport -> TL.Text
|
||||
accountTransactionsReportAsText copts reportq thisacctq items
|
||||
= TB.toLazyText . mconcat . intersperse (TB.fromText "\n") $
|
||||
title :
|
||||
map (accountTransactionsReportItemAsText copts reportq thisacctq amtwidth balwidth) items
|
||||
where
|
||||
amtwidth = maximumStrict $ 12 : map (snd . showamt . itemamt) items
|
||||
balwidth = maximumStrict $ 12 : map (snd . showamt . itembal) items
|
||||
showamt = showMixedOneLine showAmountWithoutPrice (Just 12) mmax False -- color_
|
||||
where mmax = if no_elide_ then Nothing else Just 32
|
||||
amtwidth = maximumStrict $ 12 : map (wbWidth . showamt . itemamt) items
|
||||
balwidth = maximumStrict $ 12 : map (wbWidth . showamt . itembal) items
|
||||
showamt = showMixedAmountB oneLine{displayMinWidth=Just 12, displayMaxWidth=mmax} -- color_
|
||||
where mmax = if no_elide_ . rsOpts . reportspec_ $ copts then Nothing else Just 32
|
||||
itemamt (_,_,_,_,a,_) = a
|
||||
itembal (_,_,_,_,_,a) = a
|
||||
-- show a title indicating which account was picked, which can be confusing otherwise
|
||||
title = T.unpack $ maybe "" (("Transactions in "<>).(<>" and subaccounts:")) macct
|
||||
title = maybe mempty (\s -> foldMap TB.fromText ["Transactions in ", s, " and subaccounts:"]) macct
|
||||
where
|
||||
-- XXX temporary hack ? recover the account name from the query
|
||||
macct = case filterQuery queryIsAcct thisacctq of
|
||||
Acct r -> Just . T.drop 1 . T.dropEnd 5 . T.pack $ reString r -- Acct "^JS:expenses(:|$)"
|
||||
Acct r -> Just . T.drop 1 . T.dropEnd 5 $ reString r -- Acct "^JS:expenses(:|$)"
|
||||
_ -> Nothing -- shouldn't happen
|
||||
|
||||
-- | Render one account register report line item as plain text. Layout is like so:
|
||||
@ -173,72 +167,64 @@ accountTransactionsReportAsText
|
||||
-- Returns a string which can be multi-line, eg if the running balance
|
||||
-- has multiple commodities.
|
||||
--
|
||||
accountTransactionsReportItemAsText :: CliOpts -> Query -> Query -> Int -> Int -> AccountTransactionsReportItem -> String
|
||||
accountTransactionsReportItemAsText :: CliOpts -> Query -> Query -> Int -> Int -> AccountTransactionsReportItem -> TB.Builder
|
||||
accountTransactionsReportItemAsText
|
||||
copts@CliOpts{reportspec_=ReportSpec{rsOpts=ReportOpts{color_}}}
|
||||
reportq thisacctq preferredamtwidth preferredbalwidth
|
||||
(t@Transaction{tdescription}, _, _issplit, otheracctsstr, change, balance)
|
||||
(t@Transaction{tdescription}, _, _issplit, otheracctsstr, change, balance) =
|
||||
-- Transaction -- the transaction, unmodified
|
||||
-- Transaction -- the transaction, as seen from the current account
|
||||
-- Bool -- is this a split (more than one posting to other accounts) ?
|
||||
-- String -- a display string describing the other account(s), if any
|
||||
-- MixedAmount -- the amount posted to the current account(s) (or total amount posted)
|
||||
-- MixedAmount -- the register's running total or the current account(s)'s historical balance, after this transaction
|
||||
foldMap TB.fromText . concat . intersperse (["\n"]) $
|
||||
[ fitText (Just datewidth) (Just datewidth) True True date
|
||||
, " "
|
||||
, fitText (Just descwidth) (Just descwidth) True True tdescription
|
||||
, " "
|
||||
, fitText (Just acctwidth) (Just acctwidth) True True accts
|
||||
, " "
|
||||
, amtfirstline
|
||||
, " "
|
||||
, balfirstline
|
||||
]
|
||||
:
|
||||
[ [ spacer, a, " ", b ] | (a,b) <- zip amtrest balrest ]
|
||||
where
|
||||
-- calculate widths
|
||||
(totalwidth,mdescwidth) = registerWidthsFromOpts copts
|
||||
(datewidth, date) = (10, showDate $ transactionRegisterDate reportq thisacctq t)
|
||||
(amtwidth, balwidth)
|
||||
| shortfall <= 0 = (preferredamtwidth, preferredbalwidth)
|
||||
| otherwise = (adjustedamtwidth, adjustedbalwidth)
|
||||
where
|
||||
mincolwidth = 2 -- columns always show at least an ellipsis
|
||||
maxamtswidth = max 0 (totalwidth - (datewidth + 1 + mincolwidth + 2 + mincolwidth + 2 + 2))
|
||||
shortfall = (preferredamtwidth + preferredbalwidth) - maxamtswidth
|
||||
amtwidthproportion = fromIntegral preferredamtwidth / fromIntegral (preferredamtwidth + preferredbalwidth)
|
||||
adjustedamtwidth = round $ amtwidthproportion * fromIntegral maxamtswidth
|
||||
adjustedbalwidth = maxamtswidth - adjustedamtwidth
|
||||
|
||||
= intercalate "\n" $
|
||||
concat [fitString (Just datewidth) (Just datewidth) True True date
|
||||
," "
|
||||
,fitString (Just descwidth) (Just descwidth) True True desc
|
||||
," "
|
||||
,fitString (Just acctwidth) (Just acctwidth) True True accts
|
||||
," "
|
||||
,amtfirstline
|
||||
," "
|
||||
,balfirstline
|
||||
]
|
||||
:
|
||||
[concat [spacer
|
||||
,a
|
||||
," "
|
||||
,b
|
||||
]
|
||||
| (a,b) <- zip amtrest balrest
|
||||
]
|
||||
where
|
||||
-- calculate widths
|
||||
(totalwidth,mdescwidth) = registerWidthsFromOpts copts
|
||||
(datewidth, date) = (10, showDate $ transactionRegisterDate reportq thisacctq t)
|
||||
(amtwidth, balwidth)
|
||||
| shortfall <= 0 = (preferredamtwidth, preferredbalwidth)
|
||||
| otherwise = (adjustedamtwidth, adjustedbalwidth)
|
||||
where
|
||||
mincolwidth = 2 -- columns always show at least an ellipsis
|
||||
maxamtswidth = max 0 (totalwidth - (datewidth + 1 + mincolwidth + 2 + mincolwidth + 2 + 2))
|
||||
shortfall = (preferredamtwidth + preferredbalwidth) - maxamtswidth
|
||||
amtwidthproportion = fromIntegral preferredamtwidth / fromIntegral (preferredamtwidth + preferredbalwidth)
|
||||
adjustedamtwidth = round $ amtwidthproportion * fromIntegral maxamtswidth
|
||||
adjustedbalwidth = maxamtswidth - adjustedamtwidth
|
||||
remaining = totalwidth - (datewidth + 1 + 2 + amtwidth + 2 + balwidth)
|
||||
(descwidth, acctwidth) = (w, remaining - 2 - w)
|
||||
where w = fromMaybe ((remaining - 2) `div` 2) mdescwidth
|
||||
|
||||
remaining = totalwidth - (datewidth + 1 + 2 + amtwidth + 2 + balwidth)
|
||||
(descwidth, acctwidth) = (w, remaining - 2 - w)
|
||||
where
|
||||
w = fromMaybe ((remaining - 2) `div` 2) mdescwidth
|
||||
|
||||
-- gather content
|
||||
desc = T.unpack tdescription
|
||||
accts = -- T.unpack $ elideAccountName acctwidth $ T.pack
|
||||
otheracctsstr
|
||||
amt = fst $ showMixed showAmountWithoutPrice (Just amtwidth) (Just balwidth) color_ change
|
||||
bal = fst $ showMixed showAmountWithoutPrice (Just balwidth) (Just balwidth) color_ balance
|
||||
-- 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)
|
||||
(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
|
||||
(balfirstline:balrest) = take numlines $ replicate (numlines - ballen) (replicate balwidth ' ') ++ ballines -- balance amount is bottom-aligned
|
||||
spacer = replicate (totalwidth - (amtwidth + 2 + balwidth)) ' '
|
||||
-- gather content
|
||||
accts = -- T.unpack $ elideAccountName acctwidth $ T.pack
|
||||
otheracctsstr
|
||||
amt = TL.toStrict . TB.toLazyText . wbBuilder $ showamt amtwidth change
|
||||
bal = TL.toStrict . TB.toLazyText . wbBuilder $ showamt balwidth balance
|
||||
showamt w = showMixedAmountB noPrice{displayColour=color_, displayMinWidth=Just w, displayMaxWidth=Just w}
|
||||
-- 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) = (T.lines amt, T.lines bal)
|
||||
(amtlen, ballen) = (length amtlines, length ballines)
|
||||
numlines = max 1 (max amtlen ballen)
|
||||
(amtfirstline:amtrest) = take numlines $ amtlines ++ repeat "" -- posting amount is top-aligned
|
||||
(balfirstline:balrest) = take numlines $ replicate (numlines - ballen) "" ++ ballines -- balance amount is bottom-aligned
|
||||
spacer = T.replicate (totalwidth - (amtwidth + 2 + balwidth)) " "
|
||||
|
||||
-- tests
|
||||
|
||||
|
@ -255,7 +255,7 @@ module Hledger.Cli.Commands.Balance (
|
||||
) where
|
||||
|
||||
import Data.Default (def)
|
||||
import Data.List (intercalate, transpose)
|
||||
import Data.List (intersperse, transpose)
|
||||
import Data.Maybe (fromMaybe, maybeToList)
|
||||
--import qualified Data.Map as Map
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
@ -263,11 +263,12 @@ import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import Data.Time (fromGregorian)
|
||||
import System.Console.CmdArgs.Explicit as C
|
||||
import Lucid as L
|
||||
import Text.Tabular as T
|
||||
import Text.Tabular.AsciiWide as T
|
||||
import Text.Tabular as Tab
|
||||
import Text.Tabular.AsciiWide as Tab
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli.CliOptions
|
||||
@ -321,30 +322,30 @@ balance opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
|
||||
assrt = not $ ignore_assertions_ $ inputopts_ opts
|
||||
render = case fmt of
|
||||
"txt" -> budgetReportAsText ropts
|
||||
"json" -> (++"\n") . TL.unpack . toJsonText
|
||||
"csv" -> (++"\n") . printCSV . budgetReportAsCsv ropts
|
||||
_ -> const $ error' $ unsupportedOutputFormatError fmt
|
||||
writeOutput opts $ render budgetreport
|
||||
"json" -> (<>"\n") . toJsonText
|
||||
"csv" -> printCSV . budgetReportAsCsv ropts
|
||||
_ -> error' $ unsupportedOutputFormatError fmt
|
||||
writeOutputLazyText opts $ render budgetreport
|
||||
|
||||
else
|
||||
if multiperiod then do -- multi period balance report
|
||||
let report = multiBalanceReport rspec j
|
||||
render = case fmt of
|
||||
"txt" -> multiBalanceReportAsText ropts
|
||||
"csv" -> (++"\n") . printCSV . multiBalanceReportAsCsv ropts
|
||||
"html" -> (++"\n") . TL.unpack . L.renderText . multiBalanceReportAsHtml ropts
|
||||
"json" -> (++"\n") . TL.unpack . toJsonText
|
||||
"csv" -> printCSV . multiBalanceReportAsCsv ropts
|
||||
"html" -> (<>"\n") . L.renderText . multiBalanceReportAsHtml ropts
|
||||
"json" -> (<>"\n") . toJsonText
|
||||
_ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
||||
writeOutput opts $ render report
|
||||
writeOutputLazyText opts $ render report
|
||||
|
||||
else do -- single period simple balance report
|
||||
let report = balanceReport rspec j -- simple Ledger-style balance report
|
||||
render = case fmt of
|
||||
"txt" -> balanceReportAsText
|
||||
"csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r
|
||||
"json" -> const $ (++"\n") . TL.unpack . toJsonText
|
||||
_ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
||||
writeOutput opts $ render ropts report
|
||||
"txt" -> \ropts -> TB.toLazyText . balanceReportAsText ropts
|
||||
"csv" -> \ropts -> printCSV . balanceReportAsCsv ropts
|
||||
"json" -> const $ (<>"\n") . toJsonText
|
||||
_ -> error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
||||
writeOutputLazyText opts $ render ropts report
|
||||
|
||||
|
||||
-- XXX should all the per-report, per-format rendering code live in the command module,
|
||||
@ -356,25 +357,32 @@ balance opts@CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
|
||||
balanceReportAsCsv :: ReportOpts -> BalanceReport -> CSV
|
||||
balanceReportAsCsv opts (items, total) =
|
||||
["account","balance"] :
|
||||
[[T.unpack a, showMixedAmountOneLineWithoutPrice False b] | (a, _, _, b) <- items]
|
||||
[[a, wbToText $ showMixedAmountB oneLine b] | (a, _, _, b) <- items]
|
||||
++
|
||||
if no_total_ opts
|
||||
then []
|
||||
else [["total", showMixedAmountOneLineWithoutPrice False total]]
|
||||
else [["total", wbToText $ showMixedAmountB oneLine total]]
|
||||
|
||||
-- | Render a single-column balance report as plain text.
|
||||
balanceReportAsText :: ReportOpts -> BalanceReport -> String
|
||||
balanceReportAsText opts ((items, total)) = unlines $
|
||||
concat lines ++ if no_total_ opts then [] else overline : totallines
|
||||
balanceReportAsText :: ReportOpts -> BalanceReport -> TB.Builder
|
||||
balanceReportAsText opts ((items, total)) =
|
||||
unlinesB lines
|
||||
<> unlinesB (if no_total_ opts then [] else [overline, totalLines])
|
||||
where
|
||||
lines = map (balanceReportItemAsText opts) items
|
||||
unlinesB [] = mempty
|
||||
unlinesB xs = mconcat (intersperse (TB.singleton '\n') xs) <> TB.singleton '\n'
|
||||
|
||||
(lines, sizes) = unzip $ map (balanceReportItemAsText opts) items
|
||||
-- abuse renderBalanceReportItem to render the total with similar format
|
||||
acctcolwidth = maximum' [T.length fullname | (fullname, _, _, _) <- items]
|
||||
totallines = map rstrip $ renderBalanceReportItem opts (T.replicate (acctcolwidth+1) " ", 0, total)
|
||||
(totalLines, _) = renderBalanceReportItem opts ("",0,total)
|
||||
-- with a custom format, extend the line to the full report width;
|
||||
-- otherwise show the usual 20-char line for compatibility
|
||||
overlinewidth = fromMaybe (maximum' . map length $ concat lines) . overlineWidth $ format_ opts
|
||||
overline = replicate overlinewidth '-'
|
||||
overlinewidth = case format_ opts of
|
||||
OneLine ((FormatField _ _ _ TotalField):_) -> 20
|
||||
TopAligned ((FormatField _ _ _ TotalField):_) -> 20
|
||||
BottomAligned ((FormatField _ _ _ TotalField):_) -> 20
|
||||
_ -> sum (map maximum' $ transpose sizes)
|
||||
overline = TB.fromText $ T.replicate overlinewidth "-"
|
||||
|
||||
{-
|
||||
:r
|
||||
@ -391,7 +399,7 @@ This implementation turned out to be a bit convoluted but implements the followi
|
||||
-- whatever string format is specified). Note, prices will not be rendered, and
|
||||
-- differently-priced quantities of the same commodity will appear merged.
|
||||
-- The output will be one or more lines depending on the format and number of commodities.
|
||||
balanceReportItemAsText :: ReportOpts -> BalanceReportItem -> [String]
|
||||
balanceReportItemAsText :: ReportOpts -> BalanceReportItem -> (TB.Builder, [Int])
|
||||
balanceReportItemAsText opts (_, accountName, depth, amt) =
|
||||
renderBalanceReportItem opts (
|
||||
accountName,
|
||||
@ -400,42 +408,37 @@ balanceReportItemAsText opts (_, accountName, depth, amt) =
|
||||
)
|
||||
|
||||
-- | Render a balance report item using the given StringFormat, generating one or more lines of text.
|
||||
renderBalanceReportItem :: ReportOpts -> (AccountName, Int, MixedAmount) -> [String]
|
||||
renderBalanceReportItem :: ReportOpts -> (AccountName, Int, MixedAmount) -> (TB.Builder, [Int])
|
||||
renderBalanceReportItem opts (acctname, depth, total) =
|
||||
lines $ case format_ opts of
|
||||
OneLine _ comps -> concatOneLine $ render1 comps
|
||||
TopAligned _ comps -> concatBottomPadded $ render comps
|
||||
BottomAligned _ comps -> concatTopPadded $ render comps
|
||||
case format_ opts of
|
||||
OneLine comps -> renderRow' $ render True True comps
|
||||
TopAligned comps -> renderRow' $ render True False comps
|
||||
BottomAligned comps -> renderRow' $ render False False comps
|
||||
where
|
||||
render1 = map (renderComponent1 opts (acctname, depth, total))
|
||||
render = map (renderComponent opts (acctname, depth, total))
|
||||
renderRow' is = ( renderRowB def{tableBorders=False, borderSpaces=False}
|
||||
. Tab.Group NoLine $ map Header is
|
||||
, map cellWidth is )
|
||||
|
||||
render topaligned oneline = map (maybeConcat . renderComponent topaligned opts (acctname, depth, total))
|
||||
where maybeConcat (Cell a xs) =
|
||||
if oneline then Cell a [WideBuilder (mconcat . intersperse (TB.fromText ", ") $ map wbBuilder xs) width]
|
||||
else Cell a xs
|
||||
where width = sumStrict (map ((+2) . wbWidth) xs) -2
|
||||
|
||||
|
||||
-- | Render one StringFormat component for a balance report item.
|
||||
renderComponent :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
|
||||
renderComponent _ _ (FormatLiteral s) = s
|
||||
renderComponent opts (acctname, depth, total) (FormatField ljust min max field) = case field of
|
||||
DepthSpacerField -> formatString ljust Nothing max $ replicate d ' '
|
||||
where d = case min of
|
||||
Just m -> depth * m
|
||||
Nothing -> depth
|
||||
AccountField -> formatString ljust min max (T.unpack acctname)
|
||||
TotalField -> fst $ showMixed showAmountWithoutPrice min max (color_ opts) total
|
||||
_ -> ""
|
||||
|
||||
-- | Render one StringFormat component for a balance report item.
|
||||
-- This variant is for use with OneLine string formats; it squashes
|
||||
-- any multi-line rendered values onto one line, comma-and-space separated,
|
||||
-- while still complying with the width spec.
|
||||
renderComponent1 :: ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> String
|
||||
renderComponent1 _ _ (FormatLiteral s) = s
|
||||
renderComponent1 opts (acctname, depth, total) (FormatField ljust min max field) = case field of
|
||||
AccountField -> formatString ljust min max ((intercalate ", " . lines) (indented (T.unpack acctname)))
|
||||
where
|
||||
-- better to indent the account name here rather than use a DepthField component
|
||||
-- so that it complies with width spec. Uses a fixed indent step size.
|
||||
indented = ((replicate (depth*2) ' ')++)
|
||||
TotalField -> fst $ showMixedOneLine showAmountWithoutPrice min max (color_ opts) total
|
||||
_ -> ""
|
||||
renderComponent :: Bool -> ReportOpts -> (AccountName, Int, MixedAmount) -> StringFormatComponent -> Cell
|
||||
renderComponent _ _ _ (FormatLiteral s) = alignCell TopLeft s
|
||||
renderComponent topaligned opts (acctname, depth, total) (FormatField ljust mmin mmax field) = case field of
|
||||
DepthSpacerField -> Cell align [WideBuilder (TB.fromText $ T.replicate d " ") d]
|
||||
where d = maybe id min mmax $ depth * fromMaybe 1 mmin
|
||||
AccountField -> alignCell align $ formatText ljust mmin mmax acctname
|
||||
TotalField -> Cell align . pure $ showamt total
|
||||
_ -> Cell align [mempty]
|
||||
where
|
||||
align = if topaligned then (if ljust then TopLeft else TopRight)
|
||||
else (if ljust then BottomLeft else BottomRight)
|
||||
showamt = showMixedAmountB noPrice{displayColour=color_ opts, displayMinWidth=mmin, displayMaxWidth=mmax}
|
||||
|
||||
-- rendering multi-column balance reports
|
||||
|
||||
@ -450,8 +453,8 @@ multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_}
|
||||
++ ["Total" | row_total_]
|
||||
++ ["Average" | average_]
|
||||
) :
|
||||
[T.unpack (displayFull a) :
|
||||
map (showMixedAmountOneLineWithoutPrice False)
|
||||
[displayFull a :
|
||||
map (wbToText . showMixedAmountB oneLine)
|
||||
(amts
|
||||
++ [rowtot | row_total_]
|
||||
++ [rowavg | average_])
|
||||
@ -460,7 +463,7 @@ multiBalanceReportAsCsv opts@ReportOpts{average_, row_total_}
|
||||
if no_total_ opts
|
||||
then []
|
||||
else ["Total:" :
|
||||
map (showMixedAmountOneLineWithoutPrice False) (
|
||||
map (wbToText . showMixedAmountB oneLine) (
|
||||
coltotals
|
||||
++ [tot | row_total_]
|
||||
++ [avg | average_]
|
||||
@ -496,7 +499,7 @@ multiBalanceReportHtmlRows ropts mbr =
|
||||
)
|
||||
|
||||
-- | Render one MultiBalanceReport heading row as a HTML table row.
|
||||
multiBalanceReportHtmlHeadRow :: ReportOpts -> [String] -> Html ()
|
||||
multiBalanceReportHtmlHeadRow :: ReportOpts -> [T.Text] -> Html ()
|
||||
multiBalanceReportHtmlHeadRow _ [] = mempty -- shouldn't happen
|
||||
multiBalanceReportHtmlHeadRow ropts (acct:rest) =
|
||||
let
|
||||
@ -514,7 +517,7 @@ multiBalanceReportHtmlHeadRow ropts (acct:rest) =
|
||||
++ [td_ [class_ "rowaverage", defstyle] (toHtml a) | a <- avg]
|
||||
|
||||
-- | Render one MultiBalanceReport data row as a HTML table row.
|
||||
multiBalanceReportHtmlBodyRow :: ReportOpts -> [String] -> Html ()
|
||||
multiBalanceReportHtmlBodyRow :: ReportOpts -> [T.Text] -> Html ()
|
||||
multiBalanceReportHtmlBodyRow _ [] = mempty -- shouldn't happen
|
||||
multiBalanceReportHtmlBodyRow ropts (label:rest) =
|
||||
let
|
||||
@ -532,7 +535,7 @@ multiBalanceReportHtmlBodyRow ropts (label:rest) =
|
||||
++ [td_ [class_ "amount rowaverage", defstyle] (toHtml a) | a <- avg]
|
||||
|
||||
-- | Render one MultiBalanceReport totals row as a HTML table row.
|
||||
multiBalanceReportHtmlFootRow :: ReportOpts -> [String] -> Html ()
|
||||
multiBalanceReportHtmlFootRow :: ReportOpts -> [T.Text] -> Html ()
|
||||
multiBalanceReportHtmlFootRow _ropts [] = mempty
|
||||
-- TODO pad totals row with zeros when subreport is empty
|
||||
-- multiBalanceReportHtmlFootRow ropts $
|
||||
@ -559,9 +562,11 @@ multiBalanceReportHtmlFootRow ropts (acct:rest) =
|
||||
--thRow = tr_ . mconcat . map (th_ . toHtml)
|
||||
|
||||
-- | Render a multi-column balance report as plain text suitable for console output.
|
||||
multiBalanceReportAsText :: ReportOpts -> MultiBalanceReport -> String
|
||||
multiBalanceReportAsText ropts@ReportOpts{..} r =
|
||||
title ++ "\n\n" ++ (balanceReportTableAsText ropts $ balanceReportAsTable ropts r)
|
||||
multiBalanceReportAsText :: ReportOpts -> MultiBalanceReport -> TL.Text
|
||||
multiBalanceReportAsText ropts@ReportOpts{..} r = TB.toLazyText $
|
||||
TB.fromText title
|
||||
<> TB.fromText "\n\n"
|
||||
<> balanceReportTableAsText ropts (balanceReportAsTable ropts r)
|
||||
where
|
||||
title = mtitle <> " in " <> showDateSpan (periodicReportSpan r) <> valuationdesc <> ":"
|
||||
|
||||
@ -576,7 +581,7 @@ multiBalanceReportAsText ropts@ReportOpts{..} r =
|
||||
Just (AtEnd _mc) | changingValuation -> ""
|
||||
Just (AtEnd _mc) -> ", valued at period ends"
|
||||
Just (AtNow _mc) -> ", current value"
|
||||
Just (AtDate d _mc) -> ", valued at "++showDate d
|
||||
Just (AtDate d _mc) -> ", valued at " <> showDate d
|
||||
Nothing -> ""
|
||||
|
||||
changingValuation = case (balancetype_, value_) of
|
||||
@ -584,14 +589,14 @@ multiBalanceReportAsText ropts@ReportOpts{..} r =
|
||||
_ -> False
|
||||
|
||||
-- | Build a 'Table' from a multi-column balance report.
|
||||
balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table String String MixedAmount
|
||||
balanceReportAsTable :: ReportOpts -> MultiBalanceReport -> Table T.Text T.Text MixedAmount
|
||||
balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_}
|
||||
(PeriodicReport spans items (PeriodicReportRow _ coltotals tot avg)) =
|
||||
maybetranspose $
|
||||
addtotalrow $
|
||||
Table
|
||||
(T.Group NoLine $ map Header accts)
|
||||
(T.Group NoLine $ map Header colheadings)
|
||||
(Tab.Group NoLine $ map Header accts)
|
||||
(Tab.Group NoLine $ map Header colheadings)
|
||||
(map rowvals items)
|
||||
where
|
||||
totalscolumn = row_total_ && balancetype_ `notElem` [CumulativeChange, HistoricalBalance]
|
||||
@ -600,7 +605,7 @@ balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_}
|
||||
++ ["Average" | average_]
|
||||
accts = map renderacct items
|
||||
renderacct row =
|
||||
replicate ((prrDepth row - 1) * 2) ' ' ++ T.unpack (prrDisplayName row)
|
||||
T.replicate ((prrDepth row - 1) * 2) " " <> prrDisplayName row
|
||||
rowvals (PeriodicReportRow _ as rowtot rowavg) = as
|
||||
++ [rowtot | totalscolumn]
|
||||
++ [rowavg | average_]
|
||||
@ -617,12 +622,12 @@ balanceReportAsTable opts@ReportOpts{average_, row_total_, balancetype_}
|
||||
-- made using 'balanceReportAsTable'), render it in a format suitable for
|
||||
-- console output. Amounts with more than two commodities will be elided
|
||||
-- unless --no-elide is used.
|
||||
balanceReportTableAsText :: ReportOpts -> Table String String MixedAmount -> String
|
||||
balanceReportTableAsText :: ReportOpts -> Table T.Text T.Text MixedAmount -> TB.Builder
|
||||
balanceReportTableAsText ReportOpts{..} =
|
||||
T.renderTable def{tableBorders=False, prettyTable=pretty_tables_}
|
||||
(T.alignCell TopLeft) (T.alignCell TopRight) showamt
|
||||
Tab.renderTableB def{tableBorders=False, prettyTable=pretty_tables_}
|
||||
(Tab.alignCell TopLeft) (Tab.alignCell TopRight) showamt
|
||||
where
|
||||
showamt = Cell TopRight . pure . showMixedOneLine showAmountWithoutPrice Nothing mmax color_
|
||||
showamt = Cell TopRight . pure . showMixedAmountB oneLine{displayColour=color_, displayMaxWidth=mmax}
|
||||
mmax = if no_elide_ then Nothing else Just 32
|
||||
|
||||
|
||||
@ -631,14 +636,12 @@ tests_Balance = tests "Balance" [
|
||||
tests "balanceReportAsText" [
|
||||
test "unicode in balance layout" $ do
|
||||
j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
|
||||
let rspec = defreportspec
|
||||
balanceReportAsText (rsOpts rspec) (balanceReport rspec{rsToday=fromGregorian 2008 11 26} j)
|
||||
let rspec = defreportspec{rsOpts=defreportopts{no_total_=True}}
|
||||
TB.toLazyText (balanceReportAsText (rsOpts rspec) (balanceReport rspec{rsToday=fromGregorian 2008 11 26} j))
|
||||
@?=
|
||||
unlines
|
||||
TL.unlines
|
||||
[" -100 актив:наличные"
|
||||
," 100 расходы:покупки"
|
||||
,"--------------------"
|
||||
," 0"
|
||||
]
|
||||
]
|
||||
|
||||
|
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-|
|
||||
|
||||
The @balancesheet@ command prints a simple balance sheet.
|
||||
|
@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE QuasiQuotes, RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-|
|
||||
|
||||
The @balancesheetequity@ command prints a simple balance sheet.
|
||||
|
@ -1,5 +1,7 @@
|
||||
{-# LANGUAGE QuasiQuotes, RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-|
|
||||
|
||||
The @cashflow@ command prints a simplified cashflow statement. It just
|
||||
|
@ -1,11 +1,16 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
|
||||
module Hledger.Cli.Commands.Check.Ordereddates (
|
||||
journalCheckOrdereddates
|
||||
)
|
||||
where
|
||||
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import Hledger
|
||||
import Hledger.Cli.CliOptions
|
||||
import Text.Printf
|
||||
|
||||
journalCheckOrdereddates :: CliOpts -> Journal -> Either String ()
|
||||
journalCheckOrdereddates CliOpts{reportspec_=rspec} j = do
|
||||
@ -22,16 +27,16 @@ journalCheckOrdereddates CliOpts{reportspec_=rspec} j = do
|
||||
FoldAcc{fa_previous=Nothing} -> return ()
|
||||
FoldAcc{fa_error=Nothing} -> return ()
|
||||
FoldAcc{fa_error=Just error, fa_previous=Just previous} -> do
|
||||
let
|
||||
let
|
||||
datestr = if date2_ ropts then "2" else ""
|
||||
uniquestr = if checkunique then " and/or not unique" else ""
|
||||
positionstr = showGenericSourcePos $ tsourcepos error
|
||||
txn1str = linesPrepend " " $ showTransaction previous
|
||||
txn2str = linesPrepend2 "> " " " $ showTransaction error
|
||||
Left $ printf "transaction date%s is out of order%s\nat %s:\n\n%s"
|
||||
(if date2_ ropts then "2" else "")
|
||||
uniquestr
|
||||
positionstr
|
||||
(txn1str ++ txn2str)
|
||||
txn1str = T.unpack . linesPrepend (T.pack " ") $ showTransaction previous
|
||||
txn2str = T.unpack . linesPrepend2 (T.pack "> ") (T.pack " ") $ showTransaction error
|
||||
Left $
|
||||
"Error: transaction date" <> datestr <> " is out of order"
|
||||
<> uniquestr <> "\nat " <> positionstr <> ":\n\n"
|
||||
<> txn1str <> txn2str
|
||||
|
||||
data FoldAcc a b = FoldAcc
|
||||
{ fa_error :: Maybe a
|
||||
|
@ -1,26 +1,32 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Hledger.Cli.Commands.Check.Uniqueleafnames (
|
||||
journalCheckUniqueleafnames
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Function
|
||||
import Data.List
|
||||
import Data.Function (on)
|
||||
import Data.List (groupBy, sortBy)
|
||||
import Data.List.Extra (nubSort)
|
||||
import Data.Text (Text)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import Hledger
|
||||
import Text.Printf
|
||||
|
||||
journalCheckUniqueleafnames :: Journal -> Either String ()
|
||||
journalCheckUniqueleafnames j = do
|
||||
let dupes = checkdupes' $ accountsNames j
|
||||
if null dupes
|
||||
then Right ()
|
||||
else Left $
|
||||
else Left . T.unpack $
|
||||
-- XXX make output more like Checkdates.hs, Check.hs etc.
|
||||
concatMap render dupes
|
||||
foldMap render dupes
|
||||
where
|
||||
render (leafName, accountNameL) =
|
||||
printf "%s as %s\n" leafName (intercalate ", " (map T.unpack accountNameL))
|
||||
render (leafName, accountNameL) =
|
||||
leafName <> " as " <> T.intercalate ", " accountNameL
|
||||
|
||||
checkdupes' :: (Ord k, Eq k) => [(k, v)] -> [(k, [v])]
|
||||
checkdupes' l = zip dupLeafs dupAccountNames
|
||||
@ -31,8 +37,8 @@ checkdupes' l = zip dupLeafs dupAccountNames
|
||||
. groupBy ((==) `on` fst)
|
||||
. sortBy (compare `on` fst)
|
||||
|
||||
accountsNames :: Journal -> [(String, AccountName)]
|
||||
accountsNames :: Journal -> [(Text, AccountName)]
|
||||
accountsNames j = map leafAndAccountName as
|
||||
where leafAndAccountName a = (T.unpack $ accountLeafName a, a)
|
||||
where leafAndAccountName a = (accountLeafName a, a)
|
||||
ps = journalPostings j
|
||||
as = nubSort $ map paccount ps
|
||||
|
76
hledger/Hledger/Cli/Commands/Checkdates.hs
Executable file
76
hledger/Hledger/Cli/Commands/Checkdates.hs
Executable file
@ -0,0 +1,76 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE NoOverloadedStrings #-} -- prevent trouble if turned on in ghci
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Hledger.Cli.Commands.Checkdates (
|
||||
checkdatesmode
|
||||
,checkdates
|
||||
) where
|
||||
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Hledger
|
||||
import Hledger.Cli.CliOptions
|
||||
import System.Console.CmdArgs.Explicit
|
||||
import System.Exit
|
||||
|
||||
checkdatesmode :: Mode RawOpts
|
||||
checkdatesmode = hledgerCommandMode
|
||||
$(embedFileRelative "Hledger/Cli/Commands/Checkdates.txt")
|
||||
[flagNone ["unique"] (setboolopt "unique") "require that dates are unique"]
|
||||
[generalflagsgroup1]
|
||||
hiddenflags
|
||||
([], Just $ argsFlag "[QUERY]")
|
||||
|
||||
checkdates :: CliOpts -> Journal -> IO ()
|
||||
checkdates CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
|
||||
let ropts = (rsOpts rspec){accountlistmode_=ALFlat}
|
||||
let ts = filter (rsQuery rspec `matchesTransaction`) $
|
||||
jtxns $ journalSelectingAmountFromOpts ropts j
|
||||
-- pprint rawopts
|
||||
let unique = boolopt "--unique" rawopts -- TEMP: it's this for hledger check dates
|
||||
|| boolopt "unique" rawopts -- and this for hledger check-dates (for some reason)
|
||||
let date = transactionDateFn ropts
|
||||
let compare a b =
|
||||
if unique
|
||||
then date a < date b
|
||||
else date a <= date b
|
||||
case checkTransactions compare ts of
|
||||
FoldAcc{fa_previous=Nothing} -> return ()
|
||||
FoldAcc{fa_error=Nothing} -> return ()
|
||||
FoldAcc{fa_error=Just error, fa_previous=Just previous} -> do
|
||||
let
|
||||
uniquestr = T.pack $ if unique then " and/or not unique" else ""
|
||||
positionstr = T.pack . showGenericSourcePos $ tsourcepos error
|
||||
txn1str = linesPrepend (T.pack " ") $ showTransaction previous
|
||||
txn2str = linesPrepend2 (T.pack "> ") (T.pack " ") $ showTransaction error
|
||||
T.putStrLn $
|
||||
T.pack "Error: transaction date is out of order"
|
||||
<> uniquestr <> T.pack "\nat " <> positionstr <> T.pack ":\n\n"
|
||||
<> txn1str <> txn2str
|
||||
exitFailure
|
||||
|
||||
data FoldAcc a b = FoldAcc
|
||||
{ fa_error :: Maybe a
|
||||
, fa_previous :: Maybe b
|
||||
}
|
||||
|
||||
foldWhile :: (a -> FoldAcc a b -> FoldAcc a b) -> FoldAcc a b -> [a] -> FoldAcc a b
|
||||
foldWhile _ acc [] = acc
|
||||
foldWhile fold acc (a:as) =
|
||||
case fold a acc of
|
||||
acc@FoldAcc{fa_error=Just _} -> acc
|
||||
acc -> foldWhile fold acc as
|
||||
|
||||
checkTransactions :: (Transaction -> Transaction -> Bool)
|
||||
-> [Transaction] -> FoldAcc Transaction Transaction
|
||||
checkTransactions compare = foldWhile f FoldAcc{fa_error=Nothing, fa_previous=Nothing}
|
||||
where
|
||||
f current acc@FoldAcc{fa_previous=Nothing} = acc{fa_previous=Just current}
|
||||
f current acc@FoldAcc{fa_previous=Just previous} =
|
||||
if compare previous current
|
||||
then acc{fa_previous=Just current}
|
||||
else acc{fa_error=Just current}
|
@ -10,9 +10,10 @@ where
|
||||
import Control.Monad (when)
|
||||
import Data.Function (on)
|
||||
import Data.List (groupBy)
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T (pack)
|
||||
import Data.Time.Calendar
|
||||
import Data.Maybe (fromMaybe)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Time.Calendar (addDays)
|
||||
import System.Console.CmdArgs.Explicit as C
|
||||
|
||||
import Hledger
|
||||
@ -152,6 +153,5 @@ close CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do
|
||||
++ [posting{paccount=openingacct, pamount=if explicit then mapMixedAmount precise (negate totalamt) else missingmixedamt} | not interleaved]
|
||||
|
||||
-- print them
|
||||
when closing $ putStr $ showTransaction closingtxn
|
||||
when opening $ putStr $ showTransaction openingtxn
|
||||
|
||||
when closing . T.putStr $ showTransaction closingtxn
|
||||
when opening . T.putStr $ showTransaction openingtxn
|
||||
|
@ -12,14 +12,14 @@ module Hledger.Cli.Commands.Diff (
|
||||
,diff
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import Data.Function
|
||||
import Data.Ord
|
||||
import Data.Maybe
|
||||
import Data.Time
|
||||
import Data.Either
|
||||
import qualified Data.Text as T
|
||||
import System.Exit
|
||||
import Data.List ((\\), groupBy, nubBy, sortBy)
|
||||
import Data.Function (on)
|
||||
import Data.Ord (comparing)
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.Time (diffDays)
|
||||
import Data.Either (partitionEithers)
|
||||
import qualified Data.Text.IO as T
|
||||
import System.Exit (exitFailure)
|
||||
|
||||
import Hledger
|
||||
import Prelude hiding (putStrLn)
|
||||
@ -106,7 +106,7 @@ diff CliOpts{file_=[f1, f2], reportspec_=ReportSpec{rsQuery=Acct acctRe}} _ = do
|
||||
j1 <- readJournalFile' f1
|
||||
j2 <- readJournalFile' f2
|
||||
|
||||
let acct = T.pack $ reString acctRe
|
||||
let acct = reString acctRe
|
||||
let pp1 = matchingPostings acct j1
|
||||
let pp2 = matchingPostings acct j2
|
||||
|
||||
@ -116,10 +116,10 @@ diff CliOpts{file_=[f1, f2], reportspec_=ReportSpec{rsQuery=Acct acctRe}} _ = do
|
||||
let unmatchedtxn2 = unmatchedtxns R pp2 m
|
||||
|
||||
putStrLn "These transactions are in the first file only:\n"
|
||||
mapM_ (putStr . showTransaction) unmatchedtxn1
|
||||
mapM_ (T.putStr . showTransaction) unmatchedtxn1
|
||||
|
||||
putStrLn "These transactions are in the second file only:\n"
|
||||
mapM_ (putStr . showTransaction) unmatchedtxn2
|
||||
mapM_ (T.putStr . showTransaction) unmatchedtxn2
|
||||
|
||||
diff _ _ = do
|
||||
putStrLn "Please specify two input files. Usage: hledger diff -f FILE1 -f FILE2 FULLACCOUNTNAME"
|
||||
|
@ -4,7 +4,6 @@ The @files@ command lists included files.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Hledger.Cli.Commands.Files (
|
||||
@ -12,8 +11,8 @@ module Hledger.Cli.Commands.Files (
|
||||
,files
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import Safe
|
||||
import qualified Data.Text as T
|
||||
import Safe (headMay)
|
||||
|
||||
import Hledger
|
||||
import Prelude hiding (putStrLn)
|
||||
@ -33,7 +32,7 @@ filesmode = hledgerCommandMode
|
||||
files :: CliOpts -> Journal -> IO ()
|
||||
files CliOpts{rawopts_=rawopts} j = do
|
||||
let args = listofstringopt "args" rawopts
|
||||
regex <- mapM (either fail pure . toRegex) $ headMay args
|
||||
regex <- mapM (either fail pure . toRegex . T.pack) $ headMay args
|
||||
let files = maybe id (filter . regexMatch) regex
|
||||
$ map fst
|
||||
$ jfiles j
|
||||
|
@ -9,6 +9,7 @@ where
|
||||
|
||||
import Control.Monad
|
||||
import Data.List
|
||||
import qualified Data.Text.IO as T
|
||||
import Hledger
|
||||
import Hledger.Cli.CliOptions
|
||||
import Hledger.Cli.Commands.Add (journalAddTransaction)
|
||||
@ -50,7 +51,7 @@ importcmd opts@CliOpts{rawopts_=rawopts,inputopts_=iopts} j = do
|
||||
printf "; would import %d new transactions from %s:\n\n" (length newts) inputstr
|
||||
-- TODO how to force output here ?
|
||||
-- length (jtxns newj) `seq` print' opts{rawopts_=("explicit",""):rawopts} newj
|
||||
mapM_ (putStr . showTransaction) newts
|
||||
mapM_ (T.putStr . showTransaction) newts
|
||||
newts | catchup -> do
|
||||
printf "marked %s as caught up, skipping %d unimported transactions\n\n" inputstr (length newts)
|
||||
newts -> do
|
||||
|
@ -1,4 +1,5 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Hledger.Cli.Commands.Prices (
|
||||
pricesmode
|
||||
@ -10,6 +11,7 @@ import qualified Data.Map as M
|
||||
import Data.Maybe
|
||||
import Data.List
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Data.Time
|
||||
import Hledger
|
||||
import Hledger.Cli.CliOptions
|
||||
@ -33,7 +35,7 @@ prices opts j = do
|
||||
cprices = map (stylePriceDirectiveExceptPrecision styles) $ concatMap postingsPriceDirectivesFromCosts ps
|
||||
icprices = map (stylePriceDirectiveExceptPrecision styles) $ concatMap postingsPriceDirectivesFromCosts $ mapAmount invertPrice ps
|
||||
allprices = mprices ++ ifBoolOpt "costs" cprices ++ ifBoolOpt "inverted-costs" icprices
|
||||
mapM_ (putStrLn . showPriceDirective) $
|
||||
mapM_ (T.putStrLn . showPriceDirective) $
|
||||
sortOn pddate $
|
||||
filter (matchesPriceDirective q) $
|
||||
allprices
|
||||
@ -41,8 +43,8 @@ prices opts j = do
|
||||
ifBoolOpt opt | boolopt opt $ rawopts_ opts = id
|
||||
| otherwise = const []
|
||||
|
||||
showPriceDirective :: PriceDirective -> String
|
||||
showPriceDirective mp = unwords ["P", show $ pddate mp, T.unpack . quoteCommoditySymbolIfNeeded $ pdcommodity mp, showAmountWithZeroCommodity $ pdamount mp]
|
||||
showPriceDirective :: PriceDirective -> T.Text
|
||||
showPriceDirective mp = T.unwords ["P", T.pack . show $ pddate mp, quoteCommoditySymbolIfNeeded $ pdcommodity mp, wbToText . showAmountB noColour{displayZeroCommodity=True} $ pdamount mp]
|
||||
|
||||
divideAmount' :: Quantity -> Amount -> Amount
|
||||
divideAmount' n a = a' where
|
||||
|
@ -4,8 +4,9 @@ A ledger-compatible @print@ command.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Hledger.Cli.Commands.Print (
|
||||
printmode
|
||||
@ -17,9 +18,14 @@ where
|
||||
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Text (Text)
|
||||
import Data.List (intercalate)
|
||||
import Data.List (intersperse)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
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.Builder as TB
|
||||
import System.Console.CmdArgs.Explicit
|
||||
import Hledger.Read.CsvReader (CSV, printCSV)
|
||||
|
||||
@ -53,18 +59,18 @@ print' opts j = do
|
||||
Just desc -> printMatch opts j $ T.pack desc
|
||||
|
||||
printEntries :: CliOpts -> Journal -> IO ()
|
||||
printEntries opts@CliOpts{reportspec_=rspec} j = do
|
||||
let fmt = outputFormatFromOpts opts
|
||||
render = case fmt of
|
||||
"txt" -> entriesReportAsText opts
|
||||
"csv" -> (++"\n") . printCSV . entriesReportAsCsv
|
||||
"json" -> (++"\n") . TL.unpack . toJsonText
|
||||
"sql" -> entriesReportAsSql
|
||||
_ -> const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
||||
writeOutput opts $ render $ entriesReport rspec j
|
||||
printEntries opts@CliOpts{reportspec_=rspec} j =
|
||||
writeOutputLazyText opts . render $ entriesReport rspec j
|
||||
where
|
||||
fmt = outputFormatFromOpts opts
|
||||
render | fmt=="txt" = entriesReportAsText opts
|
||||
| fmt=="csv" = printCSV . entriesReportAsCsv
|
||||
| fmt=="json" = toJsonText
|
||||
| fmt=="sql" = entriesReportAsSql
|
||||
| otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
||||
|
||||
entriesReportAsText :: CliOpts -> EntriesReport -> String
|
||||
entriesReportAsText opts = concatMap (showTransaction . whichtxn)
|
||||
entriesReportAsText :: CliOpts -> EntriesReport -> TL.Text
|
||||
entriesReportAsText opts = TB.toLazyText . foldMap (TB.fromText . showTransaction . whichtxn)
|
||||
where
|
||||
whichtxn
|
||||
-- With -x, use the fully-inferred txn with all amounts & txn prices explicit.
|
||||
@ -125,18 +131,17 @@ originalPostingPreservingAccount p = (originalPosting p) { paccount = paccount p
|
||||
-- ]
|
||||
-- ]
|
||||
|
||||
entriesReportAsSql :: EntriesReport -> String
|
||||
entriesReportAsSql txns =
|
||||
"create table if not exists postings(id serial,txnidx int,date1 date,date2 date,status text,code text,description text,comment text,account text,amount numeric,commodity text,credit numeric,debit numeric,posting_status text,posting_comment text);\n"++
|
||||
"insert into postings(txnidx,date1,date2,status,code,description,comment,account,amount,commodity,credit,debit,posting_status,posting_comment) values\n"++
|
||||
(intercalate "," (map values csv))
|
||||
++";\n"
|
||||
entriesReportAsSql :: EntriesReport -> TL.Text
|
||||
entriesReportAsSql txns = TB.toLazyText $ mconcat
|
||||
[ TB.fromText "create table if not exists postings(id serial,txnidx int,date1 date,date2 date,status text,code text,description text,comment text,account text,amount numeric,commodity text,credit numeric,debit numeric,posting_status text,posting_comment text);\n"
|
||||
, TB.fromText "insert into postings(txnidx,date1,date2,status,code,description,comment,account,amount,commodity,credit,debit,posting_status,posting_comment) values\n"
|
||||
, mconcat . intersperse (TB.fromText ",") $ map values csv
|
||||
, TB.fromText ";\n"
|
||||
]
|
||||
where
|
||||
values vs = "(" ++ (intercalate "," $ map toSql vs) ++ ")\n"
|
||||
toSql "" = "NULL"
|
||||
toSql s = "'" ++ (concatMap quoteChar s) ++ "'"
|
||||
quoteChar '\'' = "''"
|
||||
quoteChar c = [c]
|
||||
values vs = TB.fromText "(" <> mconcat (intersperse (TB.fromText ",") $ map toSql vs) <> TB.fromText ")\n"
|
||||
toSql "" = TB.fromText "NULL"
|
||||
toSql s = TB.fromText "'" <> TB.fromText (T.replace "'" "''" s) <> TB.fromText "'"
|
||||
csv = concatMap transactionToCSV txns
|
||||
|
||||
entriesReportAsCsv :: EntriesReport -> CSV
|
||||
@ -148,16 +153,16 @@ entriesReportAsCsv txns =
|
||||
-- The txnidx field (transaction index) allows postings to be grouped back into transactions.
|
||||
transactionToCSV :: Transaction -> CSV
|
||||
transactionToCSV t =
|
||||
map (\p -> show idx:date:date2:status:code:description:comment:p)
|
||||
map (\p -> T.pack (show idx):date:date2:status:code:description:comment:p)
|
||||
(concatMap postingToCSV $ tpostings t)
|
||||
where
|
||||
idx = tindex t
|
||||
description = T.unpack $ tdescription t
|
||||
description = tdescription t
|
||||
date = showDate (tdate t)
|
||||
date2 = maybe "" showDate (tdate2 t)
|
||||
status = show $ tstatus t
|
||||
code = T.unpack $ tcode t
|
||||
comment = chomp $ strip $ T.unpack $ tcomment t
|
||||
date2 = maybe "" showDate $ tdate2 t
|
||||
status = T.pack . show $ tstatus t
|
||||
code = tcode t
|
||||
comment = T.strip $ tcomment t
|
||||
|
||||
postingToCSV :: Posting -> CSV
|
||||
postingToCSV p =
|
||||
@ -165,17 +170,17 @@ postingToCSV p =
|
||||
-- commodity goes into separate column, so we suppress it, along with digit group
|
||||
-- separators and prices
|
||||
let a_ = a{acommodity="",astyle=(astyle a){asdigitgroups=Nothing},aprice=Nothing} in
|
||||
let amount = showAmount a_ in
|
||||
let commodity = T.unpack c in
|
||||
let credit = if q < 0 then showAmount $ negate a_ else "" in
|
||||
let debit = if q >= 0 then showAmount a_ else "" in
|
||||
[account, amount, commodity, credit, debit, status, comment])
|
||||
let showamt = TL.toStrict . TB.toLazyText . wbBuilder . showAmountB noColour in
|
||||
let amount = showamt a_ in
|
||||
let credit = if q < 0 then showamt $ negate a_ else "" in
|
||||
let debit = if q >= 0 then showamt a_ else "" in
|
||||
[account, amount, c, credit, debit, status, comment])
|
||||
amounts
|
||||
where
|
||||
Mixed amounts = pamount p
|
||||
status = show $ pstatus p
|
||||
status = T.pack . show $ pstatus p
|
||||
account = showAccountName Nothing (ptype p) (paccount p)
|
||||
comment = chomp $ strip $ T.unpack $ pcomment p
|
||||
comment = T.strip $ pcomment p
|
||||
|
||||
-- --match
|
||||
|
||||
@ -185,7 +190,7 @@ printMatch :: CliOpts -> Journal -> Text -> IO ()
|
||||
printMatch CliOpts{reportspec_=rspec} j desc = do
|
||||
case similarTransaction' j (rsQuery rspec) desc of
|
||||
Nothing -> putStrLn "no matches found."
|
||||
Just t -> putStr $ showTransaction t
|
||||
Just t -> T.putStr $ showTransaction t
|
||||
|
||||
where
|
||||
-- Identify the closest recent match for this description in past transactions.
|
||||
|
@ -4,10 +4,10 @@ A ledger-compatible @register@ command.
|
||||
|
||||
-}
|
||||
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Hledger.Cli.Commands.Register (
|
||||
registermode
|
||||
@ -18,11 +18,15 @@ module Hledger.Cli.Commands.Register (
|
||||
,tests_Register
|
||||
) where
|
||||
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import Data.List (intersperse)
|
||||
import Data.Maybe (fromMaybe, isJust)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
-- 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 +62,17 @@ registermode = hledgerCommandMode
|
||||
|
||||
-- | Print a (posting) register report.
|
||||
register :: CliOpts -> Journal -> IO ()
|
||||
register opts@CliOpts{reportspec_=rspec} j = do
|
||||
let fmt = outputFormatFromOpts opts
|
||||
render | fmt=="txt" = postingsReportAsText
|
||||
| fmt=="csv" = const ((++"\n") . printCSV . postingsReportAsCsv)
|
||||
| fmt=="json" = const ((++"\n") . TL.unpack . toJsonText)
|
||||
| otherwise = const $ error' $ unsupportedOutputFormatError fmt -- PARTIAL:
|
||||
writeOutput opts . render opts $ postingsReport rspec j
|
||||
register opts@CliOpts{reportspec_=rspec} j =
|
||||
writeOutputLazyText opts . render $ postingsReport rspec j
|
||||
where
|
||||
fmt = outputFormatFromOpts opts
|
||||
render | fmt=="txt" = postingsReportAsText opts
|
||||
| fmt=="csv" = printCSV . postingsReportAsCsv
|
||||
| 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
|
||||
@ -75,27 +80,32 @@ postingsReportAsCsv (_,is) =
|
||||
postingsReportItemAsCsvRecord :: PostingsReportItem -> CsvRecord
|
||||
postingsReportItemAsCsvRecord (_, _, _, p, b) = [idx,date,code,desc,acct,amt,bal]
|
||||
where
|
||||
idx = show $ maybe 0 tindex $ ptransaction p
|
||||
idx = T.pack . show . maybe 0 tindex $ ptransaction p
|
||||
date = showDate $ postingDate p -- XXX csv should show date2 with --date2
|
||||
code = maybe "" (T.unpack . tcode) $ ptransaction p
|
||||
desc = T.unpack $ maybe "" tdescription $ ptransaction p
|
||||
acct = bracket $ T.unpack $ paccount p
|
||||
code = maybe "" tcode $ ptransaction p
|
||||
desc = maybe "" tdescription $ ptransaction p
|
||||
acct = bracket $ paccount p
|
||||
where
|
||||
bracket = case ptype p of
|
||||
BalancedVirtualPosting -> (\s -> "["++s++"]")
|
||||
VirtualPosting -> (\s -> "("++s++")")
|
||||
BalancedVirtualPosting -> wrap "[" "]"
|
||||
VirtualPosting -> wrap "(" ")"
|
||||
_ -> id
|
||||
amt = showMixedAmountOneLineWithoutPrice False $ pamount p
|
||||
bal = showMixedAmountOneLineWithoutPrice False b
|
||||
amt = wbToText . showMixedAmountB oneLine $ pamount p
|
||||
bal = wbToText $ showMixedAmountB oneLine b
|
||||
|
||||
-- | Render a register report as plain text suitable for console output.
|
||||
postingsReportAsText :: CliOpts -> PostingsReport -> String
|
||||
postingsReportAsText opts (_,items) = unlines $ map (postingsReportItemAsText opts amtwidth balwidth) items
|
||||
postingsReportAsText :: CliOpts -> PostingsReport -> TL.Text
|
||||
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
|
||||
amtwidth = maximumStrict $ map (wbWidth . showAmt . itemamt) items
|
||||
balwidth = maximumStrict $ map (wbWidth . showAmt . itembal) items
|
||||
itemamt (_,_,_,Posting{pamount=a},_) = a
|
||||
itembal (_,_,_,_,a) = a
|
||||
unlinesB [] = mempty
|
||||
unlinesB xs = mconcat (intersperse (TB.fromText "\n") xs) <> TB.fromText "\n"
|
||||
showAmt = showMixedAmountB noColour{displayMinWidth=Just 12}
|
||||
|
||||
-- | Render one register report line item as plain text. Layout is like so:
|
||||
-- @
|
||||
@ -119,29 +129,23 @@ 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" $
|
||||
concat [fitString (Just datewidth) (Just datewidth) True True date
|
||||
," "
|
||||
,fitString (Just descwidth) (Just descwidth) True True desc
|
||||
," "
|
||||
,fitString (Just acctwidth) (Just acctwidth) True True acct
|
||||
," "
|
||||
,amtfirstline
|
||||
," "
|
||||
,balfirstline
|
||||
]
|
||||
foldMap TB.fromText . concat . intersperse (["\n"]) $
|
||||
[ fitText (Just datewidth) (Just datewidth) True True date
|
||||
, " "
|
||||
, fitText (Just descwidth) (Just descwidth) True True desc
|
||||
, " "
|
||||
, fitText (Just acctwidth) (Just acctwidth) True True acct
|
||||
, " "
|
||||
, amtfirstline
|
||||
, " "
|
||||
, balfirstline
|
||||
]
|
||||
:
|
||||
[concat [spacer
|
||||
,a
|
||||
," "
|
||||
,b
|
||||
]
|
||||
| (a,b) <- zip amtrest balrest
|
||||
]
|
||||
[ [ spacer, a, " ", b ] | (a,b) <- zip amtrest balrest ]
|
||||
where
|
||||
-- calculate widths
|
||||
(totalwidth,mdescwidth) = registerWidthsFromOpts opts
|
||||
@ -171,24 +175,26 @@ 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)
|
||||
VirtualPosting -> (\s -> "("++s++")", acctwidth-2)
|
||||
BalancedVirtualPosting -> (\s -> wrap "[" "]" 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
|
||||
bal = fst $ showMixed showAmountWithoutPrice (Just balwidth) (Just balwidth) (color_ . rsOpts $ reportspec_ opts) b
|
||||
wrap a b x = a <> x <> b
|
||||
amt = TL.toStrict . TB.toLazyText . wbBuilder . showamt amtwidth $ pamount p
|
||||
bal = TL.toStrict . TB.toLazyText . wbBuilder $ showamt balwidth b
|
||||
showamt w = showMixedAmountB noPrice{displayColour=color_ . rsOpts $ reportspec_ opts, displayMinWidth=Just w, displayMaxWidth=Just w}
|
||||
-- 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
|
||||
(balfirstline:balrest) = take numlines $ replicate (numlines - ballen) (replicate balwidth ' ') ++ ballines -- balance amount is bottom-aligned
|
||||
spacer = replicate (totalwidth - (amtwidth + 2 + balwidth)) ' '
|
||||
(amtfirstline:amtrest) = take numlines $ amtlines ++ repeat (T.replicate amtwidth " ") -- posting amount is top-aligned
|
||||
(balfirstline:balrest) = take numlines $ replicate (numlines - ballen) (T.replicate balwidth " ") ++ ballines -- balance amount is bottom-aligned
|
||||
spacer = T.replicate (totalwidth - (amtwidth + 2 + balwidth)) " "
|
||||
|
||||
-- tests
|
||||
|
||||
@ -198,7 +204,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"
|
||||
|
@ -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
|
||||
ps = [p | (_,_,_,p,_) <- pris]
|
||||
let ps = [p | (_,_,_,p,_) <- postingsReport rspec j]
|
||||
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."
|
||||
|
@ -13,7 +13,9 @@ import Control.Monad.Writer hiding (Any)
|
||||
#endif
|
||||
import Data.Functor.Identity
|
||||
import Data.List (sortOn, foldl')
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.IO as T
|
||||
import Hledger
|
||||
import Hledger.Cli.CliOptions
|
||||
import Hledger.Cli.Commands.Print
|
||||
@ -65,9 +67,9 @@ printOrDiff opts
|
||||
diffOutput :: Journal -> Journal -> IO ()
|
||||
diffOutput j j' = do
|
||||
let changed = [(originalTransaction t, originalTransaction t') | (t, t') <- zip (jtxns j) (jtxns j'), t /= t']
|
||||
putStr $ renderPatch $ map (uncurry $ diffTxn j) changed
|
||||
T.putStr $ renderPatch $ map (uncurry $ diffTxn j) changed
|
||||
|
||||
type Chunk = (GenericSourcePos, [DiffLine String])
|
||||
type Chunk = (GenericSourcePos, [DiffLine Text])
|
||||
|
||||
-- XXX doctests, update needed:
|
||||
-- >>> putStr $ renderPatch [(GenericSourcePos "a" 1 1, [D.First "x", D.Second "y"])]
|
||||
@ -95,17 +97,17 @@ type Chunk = (GenericSourcePos, [DiffLine String])
|
||||
-- @@ -5,0 +5,1 @@
|
||||
-- +z
|
||||
-- | Render list of changed lines as a unified diff
|
||||
renderPatch :: [Chunk] -> String
|
||||
renderPatch :: [Chunk] -> Text
|
||||
renderPatch = go Nothing . sortOn fst where
|
||||
go _ [] = ""
|
||||
go Nothing cs@((sourceFilePath -> fp, _):_) = fileHeader fp ++ go (Just (fp, 0)) cs
|
||||
go Nothing cs@((sourceFilePath -> fp, _):_) = fileHeader fp <> go (Just (fp, 0)) cs
|
||||
go (Just (fp, _)) cs@((sourceFilePath -> fp', _):_) | fp /= fp' = go Nothing cs
|
||||
go (Just (fp, offs)) ((sourceFirstLine -> lineno, diffs):cs) = chunkHeader ++ chunk ++ go (Just (fp, offs + adds - dels)) cs
|
||||
go (Just (fp, offs)) ((sourceFirstLine -> lineno, diffs):cs) = chunkHeader <> chunk <> go (Just (fp, offs + adds - dels)) cs
|
||||
where
|
||||
chunkHeader = printf "@@ -%d,%d +%d,%d @@\n" lineno dels (lineno+offs) adds where
|
||||
chunkHeader = T.pack $ printf "@@ -%d,%d +%d,%d @@\n" lineno dels (lineno+offs) adds where
|
||||
(dels, adds) = foldl' countDiff (0, 0) diffs
|
||||
chunk = concatMap renderLine diffs
|
||||
fileHeader fp = printf "--- %s\n+++ %s\n" fp fp
|
||||
chunk = foldMap renderLine diffs
|
||||
fileHeader fp = "--- " <> T.pack fp <> "\n+++ " <> T.pack fp <> "\n"
|
||||
|
||||
countDiff (dels, adds) = \case
|
||||
Del _ -> (dels + 1, adds)
|
||||
@ -113,9 +115,9 @@ renderPatch = go Nothing . sortOn fst where
|
||||
Ctx _ -> (dels + 1, adds + 1)
|
||||
|
||||
renderLine = \case
|
||||
Del s -> '-' : s ++ "\n"
|
||||
Add s -> '+' : s ++ "\n"
|
||||
Ctx s -> ' ' : s ++ "\n"
|
||||
Del s -> "-" <> s <> "\n"
|
||||
Add s -> "+" <> s <> "\n"
|
||||
Ctx s -> " " <> s <> "\n"
|
||||
|
||||
diffTxn :: Journal -> Transaction -> Transaction -> Chunk
|
||||
diffTxn j t t' =
|
||||
@ -124,18 +126,18 @@ diffTxn j t t' =
|
||||
-- TODO: use range and produce two chunks: one removes part of
|
||||
-- original file, other adds transaction to new file with
|
||||
-- suffix .ledger (generated). I.e. move transaction from one file to another.
|
||||
diffs :: [DiffLine String]
|
||||
diffs :: [DiffLine Text]
|
||||
diffs = concat . map (traverse showPostingLines . mapDiff) $ D.getDiff (tpostings t) (tpostings t')
|
||||
pos@(JournalSourcePos fp (line, line')) -> (pos, diffs) where
|
||||
-- We do diff for original lines vs generated ones. Often leads
|
||||
-- to big diff because of re-format effect.
|
||||
diffs :: [DiffLine String]
|
||||
diffs :: [DiffLine Text]
|
||||
diffs = map mapDiff $ D.getDiff source changed'
|
||||
source | Just contents <- lookup fp $ jfiles j = map T.unpack . drop (line-1) . take line' $ T.lines contents
|
||||
source | Just contents <- lookup fp $ jfiles j = drop (line-1) . take line' $ T.lines contents
|
||||
| otherwise = []
|
||||
changed = lines $ showTransaction t'
|
||||
changed = T.lines $ showTransaction t'
|
||||
changed' | null changed = changed
|
||||
| null $ last changed = init changed
|
||||
| T.null $ last changed = init changed
|
||||
| otherwise = changed
|
||||
|
||||
data DiffLine a = Del a | Add a | Ctx a
|
||||
|
@ -1,5 +1,6 @@
|
||||
{-# LANGUAGE ParallelListComp #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ParallelListComp #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-|
|
||||
|
||||
The @roi@ command prints internal rate of return and time-weighted rate of return for and investment.
|
||||
@ -20,6 +21,7 @@ import Data.List
|
||||
import Numeric.RootFinding
|
||||
import Data.Decimal
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy.IO as TL
|
||||
import System.Console.CmdArgs.Explicit as CmdArgs
|
||||
|
||||
import Text.Tabular as Tbl
|
||||
@ -118,22 +120,22 @@ roi CliOpts{rawopts_=rawopts, reportspec_=rspec} j = do
|
||||
let smallIsZero x = if abs x < 0.01 then 0.0 else x
|
||||
return [ showDate spanBegin
|
||||
, showDate (addDays (-1) spanEnd)
|
||||
, show valueBefore
|
||||
, show cashFlowAmt
|
||||
, show valueAfter
|
||||
, show (valueAfter - (valueBefore + cashFlowAmt))
|
||||
, printf "%0.2f%%" $ smallIsZero irr
|
||||
, printf "%0.2f%%" $ smallIsZero twr ]
|
||||
, T.pack $ show valueBefore
|
||||
, T.pack $ show cashFlowAmt
|
||||
, T.pack $ show valueAfter
|
||||
, T.pack $ show (valueAfter - (valueBefore + cashFlowAmt))
|
||||
, T.pack $ printf "%0.2f%%" $ smallIsZero irr
|
||||
, T.pack $ printf "%0.2f%%" $ smallIsZero twr ]
|
||||
|
||||
let table = Table
|
||||
(Tbl.Group NoLine (map (Header . show) (take (length tableBody) [1..])))
|
||||
(Tbl.Group NoLine (map (Header . T.pack . show) (take (length tableBody) [1..])))
|
||||
(Tbl.Group DoubleLine
|
||||
[ Tbl.Group SingleLine [Header "Begin", Header "End"]
|
||||
, Tbl.Group SingleLine [Header "Value (begin)", Header "Cashflow", Header "Value (end)", Header "PnL"]
|
||||
, Tbl.Group SingleLine [Header "IRR", Header "TWR"]])
|
||||
tableBody
|
||||
|
||||
putStrLn $ Ascii.render prettyTables id id id table
|
||||
TL.putStrLn $ Ascii.render prettyTables id id id table
|
||||
|
||||
timeWeightedReturn showCashFlow prettyTables investmentsQuery trans (OneSpan spanBegin spanEnd valueBefore valueAfter cashFlow pnl) = do
|
||||
let initialUnitPrice = 100
|
||||
@ -196,7 +198,7 @@ timeWeightedReturn showCashFlow prettyTables investmentsQuery trans (OneSpan spa
|
||||
unitBalances = add initialUnits unitBalances'
|
||||
valuesOnDate = add 0 valuesOnDate'
|
||||
|
||||
putStr $ Ascii.render prettyTables id id id
|
||||
TL.putStr $ Ascii.render prettyTables id id T.pack
|
||||
(Table
|
||||
(Tbl.Group NoLine (map (Header . showDate) dates))
|
||||
(Tbl.Group DoubleLine [ Tbl.Group SingleLine [Header "Portfolio value", Header "Unit balance"]
|
||||
@ -226,11 +228,11 @@ internalRateOfReturn showCashFlow prettyTables (OneSpan spanBegin spanEnd valueB
|
||||
when showCashFlow $ do
|
||||
printf "\nIRR cash flow for %s - %s\n" (showDate spanBegin) (showDate (addDays (-1) spanEnd))
|
||||
let (dates, amounts) = unzip totalCF
|
||||
putStrLn $ Ascii.render prettyTables id id id
|
||||
TL.putStrLn $ Ascii.render prettyTables id id id
|
||||
(Table
|
||||
(Tbl.Group NoLine (map (Header . showDate) dates))
|
||||
(Tbl.Group SingleLine [Header "Amount"])
|
||||
(map ((:[]) . show) amounts))
|
||||
(map ((:[]) . T.pack . show) amounts))
|
||||
|
||||
-- 0% is always a solution, so require at least something here
|
||||
case totalCF of
|
||||
|
@ -29,7 +29,7 @@ tags :: CliOpts -> Journal -> IO ()
|
||||
tags CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
|
||||
d <- getCurrentDay
|
||||
let args = listofstringopt "args" rawopts
|
||||
mtagpat <- mapM (either Fail.fail pure . toRegexCI) $ headMay args
|
||||
mtagpat <- mapM (either Fail.fail pure . toRegexCI . T.pack) $ headMay args
|
||||
let
|
||||
querystring = map T.pack $ drop 1 args
|
||||
values = boolopt "values" rawopts
|
||||
@ -44,7 +44,7 @@ tags CliOpts{rawopts_=rawopts,reportspec_=rspec} j = do
|
||||
(if parsed then id else nubSort)
|
||||
[ r
|
||||
| (t,v) <- concatMap transactionAllTags txns
|
||||
, maybe True (`regexMatch` T.unpack t) mtagpat
|
||||
, maybe True (`regexMatchText` t) mtagpat
|
||||
, let r = if values then v else t
|
||||
, not (values && T.null v && not empty)
|
||||
]
|
||||
|
@ -1,4 +1,7 @@
|
||||
{-# LANGUAGE OverloadedStrings, RecordWildCards, LambdaCase #-}
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-|
|
||||
|
||||
Common helpers for making multi-section balance report commands
|
||||
@ -13,19 +16,23 @@ module Hledger.Cli.CompoundBalanceCommand (
|
||||
) where
|
||||
|
||||
import Data.List (foldl')
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as TS
|
||||
import Data.Maybe (fromMaybe, mapMaybe)
|
||||
#if !(MIN_VERSION_base(4,11,0))
|
||||
import Data.Semigroup ((<>))
|
||||
#endif
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as TL
|
||||
import Data.Time.Calendar
|
||||
import qualified Data.Text.Lazy.Builder as TB
|
||||
import Data.Time.Calendar (Day, addDays)
|
||||
import System.Console.CmdArgs.Explicit as C
|
||||
import Hledger.Read.CsvReader (CSV, printCSV)
|
||||
import Lucid as L hiding (value_)
|
||||
import Text.Tabular as T
|
||||
import Text.Tabular as Tab
|
||||
|
||||
import Hledger
|
||||
import Hledger.Cli.Commands.Balance
|
||||
import Hledger.Cli.CliOptions
|
||||
import Hledger.Cli.Utils (unsupportedOutputFormatError, writeOutput)
|
||||
import Hledger.Cli.Utils (unsupportedOutputFormatError, writeOutputLazyText)
|
||||
|
||||
-- | Description of a compound balance report command,
|
||||
-- from which we generate the command's cmdargs mode and IO action.
|
||||
@ -89,84 +96,83 @@ compoundBalanceCommandMode CompoundBalanceCommandSpec{..} =
|
||||
-- | Generate a runnable command from a compound balance command specification.
|
||||
compoundBalanceCommand :: CompoundBalanceCommandSpec -> (CliOpts -> Journal -> IO ())
|
||||
compoundBalanceCommand CompoundBalanceCommandSpec{..} opts@CliOpts{reportspec_=rspec, rawopts_=rawopts} j = do
|
||||
let
|
||||
ropts@ReportOpts{..} = rsOpts rspec
|
||||
-- use the default balance type for this report, unless the user overrides
|
||||
mBalanceTypeOverride =
|
||||
choiceopt parse rawopts where
|
||||
parse = \case
|
||||
"historical" -> Just HistoricalBalance
|
||||
"cumulative" -> Just CumulativeChange
|
||||
"change" -> Just PeriodChange
|
||||
_ -> Nothing
|
||||
balancetype = fromMaybe cbctype mBalanceTypeOverride
|
||||
-- Set balance type in the report options.
|
||||
ropts' = ropts{balancetype_=balancetype}
|
||||
writeOutputLazyText opts $ render cbr
|
||||
where
|
||||
ropts@ReportOpts{..} = rsOpts rspec
|
||||
-- use the default balance type for this report, unless the user overrides
|
||||
mBalanceTypeOverride =
|
||||
choiceopt parse rawopts where
|
||||
parse = \case
|
||||
"historical" -> Just HistoricalBalance
|
||||
"cumulative" -> Just CumulativeChange
|
||||
"change" -> Just PeriodChange
|
||||
_ -> Nothing
|
||||
balancetype = fromMaybe cbctype mBalanceTypeOverride
|
||||
-- Set balance type in the report options.
|
||||
ropts' = ropts{balancetype_=balancetype}
|
||||
|
||||
title =
|
||||
cbctitle
|
||||
++ " "
|
||||
++ titledatestr
|
||||
++ maybe "" (' ':) mtitleclarification
|
||||
++ valuationdesc
|
||||
where
|
||||
title =
|
||||
T.pack cbctitle
|
||||
<> " "
|
||||
<> titledatestr
|
||||
<> maybe "" (" "<>) mtitleclarification
|
||||
<> valuationdesc
|
||||
where
|
||||
|
||||
-- XXX #1078 the title of ending balance reports
|
||||
-- (HistoricalBalance) should mention the end date(s) shown as
|
||||
-- column heading(s) (not the date span of the transactions).
|
||||
-- Also the dates should not be simplified (it should show
|
||||
-- "2008/01/01-2008/12/31", not "2008").
|
||||
titledatestr = case balancetype of
|
||||
HistoricalBalance -> showEndDates enddates
|
||||
_ -> showDateSpan requestedspan
|
||||
where
|
||||
enddates = map (addDays (-1)) . mapMaybe spanEnd $ cbrDates cbr -- these spans will always have a definite end date
|
||||
requestedspan = queryDateSpan date2_ (rsQuery rspec)
|
||||
`spanDefaultsFrom` journalDateSpan date2_ j
|
||||
-- XXX #1078 the title of ending balance reports
|
||||
-- (HistoricalBalance) should mention the end date(s) shown as
|
||||
-- column heading(s) (not the date span of the transactions).
|
||||
-- Also the dates should not be simplified (it should show
|
||||
-- "2008/01/01-2008/12/31", not "2008").
|
||||
titledatestr = case balancetype of
|
||||
HistoricalBalance -> showEndDates enddates
|
||||
_ -> showDateSpan requestedspan
|
||||
where
|
||||
enddates = map (addDays (-1)) . mapMaybe spanEnd $ cbrDates cbr -- these spans will always have a definite end date
|
||||
requestedspan = queryDateSpan date2_ (rsQuery rspec)
|
||||
`spanDefaultsFrom` journalDateSpan date2_ j
|
||||
|
||||
-- when user overrides, add an indication to the report title
|
||||
mtitleclarification = flip fmap mBalanceTypeOverride $ \case
|
||||
PeriodChange | changingValuation -> "(Period-End Value Changes)"
|
||||
PeriodChange -> "(Balance Changes)"
|
||||
CumulativeChange -> "(Cumulative Ending Balances)"
|
||||
HistoricalBalance -> "(Historical Ending Balances)"
|
||||
-- when user overrides, add an indication to the report title
|
||||
mtitleclarification = flip fmap mBalanceTypeOverride $ \case
|
||||
PeriodChange | changingValuation -> "(Period-End Value Changes)"
|
||||
PeriodChange -> "(Balance Changes)"
|
||||
CumulativeChange -> "(Cumulative Ending Balances)"
|
||||
HistoricalBalance -> "(Historical Ending Balances)"
|
||||
|
||||
valuationdesc = case value_ of
|
||||
Just (AtCost _mc) -> ", valued at cost"
|
||||
Just (AtThen _mc) -> error' unsupportedValueThenError -- TODO
|
||||
Just (AtEnd _mc) | changingValuation -> ""
|
||||
Just (AtEnd _mc) -> ", valued at period ends"
|
||||
Just (AtNow _mc) -> ", current value"
|
||||
Just (AtDate today _mc) -> ", valued at "++showDate today
|
||||
Nothing -> ""
|
||||
valuationdesc = case value_ of
|
||||
Just (AtCost _mc) -> ", valued at cost"
|
||||
Just (AtThen _mc) -> error' unsupportedValueThenError -- TODO
|
||||
Just (AtEnd _mc) | changingValuation -> ""
|
||||
Just (AtEnd _mc) -> ", valued at period ends"
|
||||
Just (AtNow _mc) -> ", current value"
|
||||
Just (AtDate today _mc) -> ", valued at " <> showDate today
|
||||
Nothing -> ""
|
||||
|
||||
changingValuation = case (balancetype_, value_) of
|
||||
(PeriodChange, Just (AtEnd _)) -> interval_ /= NoInterval
|
||||
_ -> False
|
||||
changingValuation = case (balancetype_, value_) of
|
||||
(PeriodChange, Just (AtEnd _)) -> interval_ /= NoInterval
|
||||
_ -> False
|
||||
|
||||
-- make a CompoundBalanceReport.
|
||||
cbr' = compoundBalanceReport rspec{rsOpts=ropts'} j cbcqueries
|
||||
cbr = cbr'{cbrTitle=title}
|
||||
-- make a CompoundBalanceReport.
|
||||
cbr' = compoundBalanceReport rspec{rsOpts=ropts'} j cbcqueries
|
||||
cbr = cbr'{cbrTitle=title}
|
||||
|
||||
-- render appropriately
|
||||
writeOutput opts $ case outputFormatFromOpts opts of
|
||||
"txt" -> compoundBalanceReportAsText ropts' cbr
|
||||
"csv" -> printCSV (compoundBalanceReportAsCsv ropts cbr) ++ "\n"
|
||||
"html" -> (++"\n") $ TL.unpack $ L.renderText $ compoundBalanceReportAsHtml ropts cbr
|
||||
"json" -> (++"\n") $ TL.unpack $ toJsonText cbr
|
||||
render = case outputFormatFromOpts opts of
|
||||
"txt" -> compoundBalanceReportAsText ropts'
|
||||
"csv" -> printCSV . compoundBalanceReportAsCsv ropts'
|
||||
"html" -> L.renderText . compoundBalanceReportAsHtml ropts'
|
||||
"json" -> toJsonText
|
||||
x -> error' $ unsupportedOutputFormatError x
|
||||
|
||||
-- | Summarise one or more (inclusive) end dates, in a way that's
|
||||
-- visually different from showDateSpan, suggesting discrete end dates
|
||||
-- rather than a continuous span.
|
||||
showEndDates :: [Day] -> String
|
||||
showEndDates :: [Day] -> T.Text
|
||||
showEndDates es = case es of
|
||||
-- cf showPeriod
|
||||
(e:_:_) -> showdate e ++ ".." ++ showdate (last es)
|
||||
[e] -> showdate e
|
||||
(e:_:_) -> showDate e <> ".." <> showDate (last es)
|
||||
[e] -> showDate e
|
||||
[] -> ""
|
||||
where
|
||||
showdate = show
|
||||
|
||||
-- | Render a compound balance report as plain text suitable for console output.
|
||||
{- Eg:
|
||||
@ -188,15 +194,16 @@ Balance Sheet
|
||||
Total || 1 1 1
|
||||
|
||||
-}
|
||||
compoundBalanceReportAsText :: ReportOpts -> CompoundPeriodicReport DisplayName MixedAmount -> String
|
||||
compoundBalanceReportAsText :: ReportOpts -> CompoundPeriodicReport DisplayName MixedAmount -> TL.Text
|
||||
compoundBalanceReportAsText ropts
|
||||
(CompoundPeriodicReport title _colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg)) =
|
||||
title ++ "\n\n" ++
|
||||
balanceReportTableAsText ropts bigtable'
|
||||
TB.toLazyText $
|
||||
TB.fromText title <> TB.fromText "\n\n" <>
|
||||
balanceReportTableAsText ropts bigtable'
|
||||
where
|
||||
bigtable =
|
||||
case map (subreportAsTable ropts) subreports of
|
||||
[] -> T.empty
|
||||
[] -> Tab.empty
|
||||
r:rs -> foldl' concatTables r rs
|
||||
bigtable'
|
||||
| no_total_ ropts || length subreports == 1 =
|
||||
@ -217,11 +224,11 @@ compoundBalanceReportAsText ropts
|
||||
-- convert to table
|
||||
Table lefthdrs tophdrs cells = balanceReportAsTable ropts r
|
||||
-- tweak the layout
|
||||
t = Table (T.Group SingleLine [Header title, lefthdrs]) tophdrs ([]:cells)
|
||||
t = Table (Tab.Group SingleLine [Header title, lefthdrs]) tophdrs ([]:cells)
|
||||
|
||||
-- | Add the second table below the first, discarding its column headings.
|
||||
concatTables (Table hLeft hTop dat) (Table hLeft' _ dat') =
|
||||
Table (T.Group DoubleLine [hLeft, hLeft']) hTop (dat ++ dat')
|
||||
Table (Tab.Group DoubleLine [hLeft, hLeft']) hTop (dat ++ dat')
|
||||
|
||||
-- | Render a compound balance report as CSV.
|
||||
-- Subreports' CSV is concatenated, with the headings rows replaced by a
|
||||
@ -229,14 +236,14 @@ concatTables (Table hLeft hTop dat) (Table hLeft' _ dat') =
|
||||
-- optional overall totals row is added.
|
||||
compoundBalanceReportAsCsv :: ReportOpts -> CompoundPeriodicReport DisplayName MixedAmount -> CSV
|
||||
compoundBalanceReportAsCsv ropts (CompoundPeriodicReport title colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg)) =
|
||||
addtotals $
|
||||
padRow title :
|
||||
("Account" :
|
||||
map showDateSpanMonthAbbrev colspans
|
||||
++ (if row_total_ ropts then ["Total"] else [])
|
||||
++ (if average_ ropts then ["Average"] else [])
|
||||
) :
|
||||
concatMap (subreportAsCsv ropts) subreports
|
||||
addtotals $
|
||||
padRow title
|
||||
: ( "Account"
|
||||
: map showDateSpanMonthAbbrev colspans
|
||||
++ (if row_total_ ropts then ["Total"] else [])
|
||||
++ (if average_ ropts then ["Average"] else [])
|
||||
)
|
||||
: concatMap (subreportAsCsv ropts) subreports
|
||||
where
|
||||
-- | Add a subreport title row and drop the heading row.
|
||||
subreportAsCsv ropts (subreporttitle, multibalreport, _) =
|
||||
@ -256,7 +263,7 @@ compoundBalanceReportAsCsv ropts (CompoundPeriodicReport title colspans subrepor
|
||||
| no_total_ ropts || length subreports == 1 = id
|
||||
| otherwise = (++
|
||||
["Net:" :
|
||||
map (showMixedAmountOneLineWithoutPrice False) (
|
||||
map (wbToText . showMixedAmountB oneLine) (
|
||||
coltotals
|
||||
++ (if row_total_ ropts then [grandtotal] else [])
|
||||
++ (if average_ ropts then [grandavg] else [])
|
||||
@ -268,7 +275,7 @@ compoundBalanceReportAsHtml :: ReportOpts -> CompoundPeriodicReport DisplayName
|
||||
compoundBalanceReportAsHtml ropts cbr =
|
||||
let
|
||||
CompoundPeriodicReport title colspans subreports (PeriodicReportRow _ coltotals grandtotal grandavg) = cbr
|
||||
colspanattr = colspan_ $ TS.pack $ show $
|
||||
colspanattr = colspan_ $ T.pack $ show $
|
||||
1 + length colspans + (if row_total_ ropts then 1 else 0) + (if average_ ropts then 1 else 0)
|
||||
leftattr = style_ "text-align:left"
|
||||
blankrow = tr_ $ td_ [colspanattr] $ toHtmlRaw (" "::String)
|
||||
@ -282,12 +289,12 @@ compoundBalanceReportAsHtml ropts cbr =
|
||||
++ (if average_ ropts then ["Average"] else [])
|
||||
]
|
||||
|
||||
thRow :: [String] -> Html ()
|
||||
thRow :: [T.Text] -> Html ()
|
||||
thRow = tr_ . mconcat . map (th_ . toHtml)
|
||||
|
||||
-- Make rows for a subreport: its title row, not the headings row,
|
||||
-- the data rows, any totals row, and a blank row for whitespace.
|
||||
subreportrows :: (String, MultiBalanceReport, Bool) -> [Html ()]
|
||||
subreportrows :: (T.Text, MultiBalanceReport, Bool) -> [Html ()]
|
||||
subreportrows (subreporttitle, mbr, _increasestotal) =
|
||||
let
|
||||
(_,bodyrows,mtotalsrow) = multiBalanceReportHtmlRows ropts mbr
|
||||
@ -300,16 +307,14 @@ compoundBalanceReportAsHtml ropts cbr =
|
||||
totalrows | no_total_ ropts || length subreports == 1 = []
|
||||
| otherwise =
|
||||
let defstyle = style_ "text-align:right"
|
||||
in
|
||||
[tr_ $ mconcat $
|
||||
th_ [class_ "", style_ "text-align:left"] "Net:"
|
||||
: [th_ [class_ "amount coltotal", defstyle] (toHtml $ showMixedAmountOneLineWithoutPrice False a) | a <- coltotals]
|
||||
++ (if row_total_ ropts then [th_ [class_ "amount coltotal", defstyle] $ toHtml $ showMixedAmountOneLineWithoutPrice False grandtotal] else [])
|
||||
++ (if average_ ropts then [th_ [class_ "amount colaverage", defstyle] $ toHtml $ showMixedAmountOneLineWithoutPrice False grandavg] else [])
|
||||
orEmpty b x = if b then x else mempty
|
||||
in [tr_ $ th_ [class_ "", style_ "text-align:left"] "Net:"
|
||||
<> foldMap (th_ [class_ "amount coltotal", defstyle] . toHtml . wbUnpack . showMixedAmountB oneLine) coltotals
|
||||
<> orEmpty (row_total_ ropts) (th_ [class_ "amount coltotal", defstyle] . toHtml . wbUnpack $ showMixedAmountB oneLine grandtotal)
|
||||
<> orEmpty (average_ ropts) (th_ [class_ "amount colaverage", defstyle] . toHtml . wbUnpack $ showMixedAmountB oneLine grandavg)
|
||||
]
|
||||
|
||||
in do
|
||||
style_ (TS.unlines [""
|
||||
style_ (T.unlines [""
|
||||
,"td { padding:0 0.5em; }"
|
||||
,"td:nth-child(1) { white-space:nowrap; }"
|
||||
,"tr:nth-child(even) td { background-color:#eee; }"
|
||||
|
@ -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
|
||||
|
@ -135,7 +135,7 @@ $ hledger -f- balance --alias=cc=credit-card --alias=b=bank
|
||||
75 bank
|
||||
15 expenses
|
||||
--------------------
|
||||
90
|
||||
90
|
||||
|
||||
# 9. query will search both origin and substitution in alias
|
||||
<
|
||||
|
@ -31,7 +31,7 @@ hledger -f - register
|
||||
>>>=0
|
||||
|
||||
# 3. balance
|
||||
hledger -f - balance
|
||||
hledger -f - balance -N
|
||||
<<<
|
||||
2010/1/1
|
||||
a EUR 1 ; a euro
|
||||
@ -40,10 +40,8 @@ hledger -f - balance
|
||||
>>>
|
||||
EUR 1 a
|
||||
USD 1 b
|
||||
EUR -1
|
||||
EUR -1
|
||||
USD -1 c
|
||||
--------------------
|
||||
0
|
||||
>>>=0
|
||||
|
||||
# 4. a single-commodity zero amount's commodity/decimal places/price is preserved, when possible
|
||||
@ -63,7 +61,7 @@ hledger -f- print --explicit --empty
|
||||
# When preserving a zero amount's commodity, we should also preserve
|
||||
# the amount style, such as where to place the symbol.
|
||||
# https://github.com/simonmichael/hledger/issues/230
|
||||
hledger -f- balance --tree
|
||||
hledger -f- balance --tree -N
|
||||
<<<
|
||||
D 1000,00€
|
||||
|
||||
@ -79,8 +77,6 @@ D 1000,00€
|
||||
4000,58€ 1
|
||||
-1000,58€ D
|
||||
-3000,00€ e
|
||||
--------------------
|
||||
0
|
||||
>>>= 0
|
||||
|
||||
|
||||
|
@ -16,22 +16,18 @@
|
||||
1 -1
|
||||
|
||||
# 1. simple balance report in tree mode with zero/boring parents
|
||||
$ hledger -f - bal --tree
|
||||
$ hledger -f - bal --tree -N
|
||||
0 1:2
|
||||
1 3
|
||||
0 4
|
||||
1 5
|
||||
--------------------
|
||||
0
|
||||
|
||||
# 2. simple balance report in flat mode
|
||||
$ hledger -f - bal --flat
|
||||
$ hledger -f - bal --flat -N
|
||||
-1 1:2
|
||||
1 1:2:3
|
||||
-1 1:2:3:4
|
||||
1 1:2:3:4:5
|
||||
--------------------
|
||||
0
|
||||
|
||||
# 3. tabular balance report in flat mode
|
||||
$ hledger -f - bal -Y
|
||||
|
@ -12,7 +12,7 @@ hledger -f sample.journal balance --tree
|
||||
$-1 salary
|
||||
$1 liabilities:debts
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>=0
|
||||
|
||||
# 2.
|
||||
@ -23,11 +23,11 @@ hledger -f sample.journal balance --tree o
|
||||
$-1 gifts
|
||||
$-1 salary
|
||||
--------------------
|
||||
$-1
|
||||
$-1
|
||||
>>>=0
|
||||
|
||||
# 3. Period reporting works for a specific year
|
||||
hledger -f - balance -b 2016 -e 2017
|
||||
hledger -f - balance -b 2016 -e 2017 -N
|
||||
<<<
|
||||
2015/10/10 Client A | Invoice #1
|
||||
assets:receivables $10,000.00
|
||||
@ -52,13 +52,11 @@ hledger -f - balance -b 2016 -e 2017
|
||||
$-40.00 assets:checking
|
||||
$50.00 expense:hosting
|
||||
$-10.00 revenue:clients:B
|
||||
--------------------
|
||||
0
|
||||
>>>2
|
||||
>>>= 0
|
||||
|
||||
# 4. Period reporting works for two years
|
||||
hledger -f - balance --tree -b 2015 -e 2017
|
||||
hledger -f - balance --tree -b 2015 -e 2017 -N
|
||||
<<<
|
||||
2015/10/10 Client A | Invoice #1
|
||||
assets:receivables $10,000.00
|
||||
@ -85,13 +83,11 @@ hledger -f - balance --tree -b 2015 -e 2017
|
||||
$-10,010.00 revenue:clients
|
||||
$-10,000.00 A
|
||||
$-10.00 B
|
||||
--------------------
|
||||
0
|
||||
>>>2
|
||||
>>>= 0
|
||||
|
||||
# 5. Period reporting works for one month
|
||||
hledger -f - balance --tree -b 2015/11 -e 2015/12
|
||||
hledger -f - balance --tree -b 2015/11 -e 2015/12 -N
|
||||
<<<
|
||||
2015/10/10 Client A | Invoice #1
|
||||
assets:receivables $10,000.00
|
||||
@ -116,8 +112,6 @@ hledger -f - balance --tree -b 2015/11 -e 2015/12
|
||||
0 assets
|
||||
$10,000.00 checking
|
||||
$-10,000.00 receivables
|
||||
--------------------
|
||||
0
|
||||
>>>2
|
||||
>>>= 0
|
||||
|
||||
@ -145,7 +139,7 @@ hledger -f - balance -b 2016/10 -e 2016/11
|
||||
assets:receivables -$10.00
|
||||
>>>
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>2
|
||||
>>>= 0
|
||||
|
||||
|
@ -3,19 +3,19 @@
|
||||
|
||||
$ hledger -f bcexample.hledger bal -t -1 --color=always
|
||||
>
|
||||
70.00 GLD
|
||||
17.00 ITOT
|
||||
489.957000000000 RGAGX
|
||||
5716.53 USD
|
||||
337.26 VACHR
|
||||
309.950000000000 VBMPX
|
||||
36.00 VEA
|
||||
70.00 GLD
|
||||
17.00 ITOT
|
||||
489.957000000000 RGAGX
|
||||
5716.53 USD
|
||||
337.26 VACHR
|
||||
309.950000000000 VBMPX
|
||||
36.00 VEA
|
||||
294.00 VHT Assets
|
||||
[31m-3077.70 USD[m Equity
|
||||
52000.00 IRAUSD
|
||||
52000.00 IRAUSD
|
||||
260911.70 USD Expenses
|
||||
[31m-52000.00 IRAUSD[m
|
||||
[31m-365071.44 USD[m
|
||||
[31m-52000.00 IRAUSD[m
|
||||
[31m-365071.44 USD[m
|
||||
[31m-337.26 VACHR[m Income
|
||||
[31m-2891.85 USD[m Liabilities
|
||||
--------------------
|
||||
@ -25,5 +25,5 @@ $ hledger -f bcexample.hledger bal -t -1 --color=always
|
||||
[31m-104412.76 USD[m
|
||||
309.950000000000 VBMPX
|
||||
36.00 VEA
|
||||
294.00 VHT
|
||||
294.00 VHT
|
||||
>=0
|
||||
|
@ -1,4 +1,4 @@
|
||||
hledger -f - balance -p 'in 2009' --date2
|
||||
hledger -f - balance -p 'in 2009' --date2 -N
|
||||
<<<
|
||||
2009/1/1 x
|
||||
a 1
|
||||
@ -10,6 +10,4 @@ hledger -f - balance -p 'in 2009' --date2
|
||||
>>>
|
||||
1 a
|
||||
-1 b
|
||||
--------------------
|
||||
0
|
||||
>>>=0
|
||||
|
@ -29,7 +29,7 @@ hledger -f - balance --flat
|
||||
1 b
|
||||
1 b:bb:bbb
|
||||
--------------------
|
||||
5
|
||||
5
|
||||
>>>= 0
|
||||
|
||||
# --flat --depth shows the same accounts, but clipped and aggregated at the depth limit
|
||||
@ -47,5 +47,5 @@ hledger -f - balance --flat --depth 2
|
||||
1 b
|
||||
1 b:bb
|
||||
--------------------
|
||||
5
|
||||
5
|
||||
>>>= 0
|
||||
|
@ -13,7 +13,7 @@
|
||||
$ hledger -f - balance
|
||||
>
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>=0
|
||||
|
||||
<
|
||||
@ -48,7 +48,7 @@ $ hledger -f - balance --tree --no-total
|
||||
>=0
|
||||
|
||||
<
|
||||
1/1
|
||||
2020/1/1
|
||||
(a) 1
|
||||
(a:aa) 1
|
||||
(a:aa) -1
|
||||
|
@ -6,7 +6,7 @@ hledger -f sample.journal balance expenses -% --tree
|
||||
50.0 % food
|
||||
50.0 % supplies
|
||||
--------------------
|
||||
100.0 %
|
||||
100.0 %
|
||||
>>>= 0
|
||||
|
||||
# 2. Multi column percent
|
||||
|
@ -8,5 +8,5 @@ hledger -f- balance
|
||||
1.00 a
|
||||
-1.00 b
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>=0
|
||||
|
@ -7,5 +7,5 @@ hledger -f - balance
|
||||
10 руб τράπεζα
|
||||
-10 руб नकद
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>=0
|
||||
|
@ -54,7 +54,7 @@ hledger -f chinese.journal balance --tree
|
||||
0 㐃
|
||||
1 A 㐄
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
|
@ -43,7 +43,7 @@ $ hledger -f- balance
|
||||
10 "DE 0002 635307" a
|
||||
-10 "DE 0002 635307" b
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
|
||||
# 5. autobalance with prices
|
||||
<
|
||||
@ -163,7 +163,7 @@ $ hledger -f- print
|
||||
a 1 EUR
|
||||
$ hledger -f- bal a
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>=
|
||||
|
||||
# 12. Example of surprising decimal mark parsing behaviour.
|
||||
|
@ -47,7 +47,7 @@ $ hledger balance -f- --auto --tree
|
||||
$-100 remuneration
|
||||
$-38 liabilities:tax
|
||||
--------------------
|
||||
$-38
|
||||
$-38
|
||||
>=
|
||||
|
||||
# Balance assertions see postings generated by transaction modifier rules.
|
||||
|
@ -60,7 +60,7 @@ $ hledger -f- print
|
||||
# including limiting the display precision, like a commodity directive (#1187).
|
||||
<
|
||||
D 1,000.0 A
|
||||
1/1
|
||||
2020/1/1
|
||||
(a) 1000.123
|
||||
|
||||
$ hledger -f- print
|
||||
|
@ -81,7 +81,7 @@ D 1,000.00 EUR
|
||||
1,000.00 EUR a
|
||||
-1,000.00 EUR b
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
@ -106,7 +106,7 @@ commodity 1,000.00 EUR
|
||||
1,000.00 EUR a
|
||||
-1,000.00 EUR b
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
@ -122,7 +122,7 @@ commodity €1,000.00
|
||||
€1,000.00 a
|
||||
€-1,000.00 b
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
@ -145,7 +145,7 @@ commodity 100. EUR
|
||||
1000 EUR a
|
||||
-1000 EUR b
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
@ -209,7 +209,7 @@ hledger bal -f -
|
||||
0.1 EUR a
|
||||
-0.1 EUR b
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
||||
|
@ -61,7 +61,7 @@ hledger -f - balance --cost
|
||||
$3266.32 assets:investment:ACME
|
||||
$-3266.32 equity:opening balances
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>=0
|
||||
|
||||
# hledger 0.14pre: precision=2, presumably from price
|
||||
@ -91,7 +91,7 @@ D $1000.0
|
||||
$3266.3 assets:investment:ACME
|
||||
$-3266.3 equity:opening balances
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>=0
|
||||
### hledger 0.14pre: precision=2, presumably from price, ignores D
|
||||
### $3266.32 assets:investment:ACME
|
||||
|
@ -68,7 +68,7 @@ hledger -f - bal --no-total
|
||||
(a) 1.00005e
|
||||
(a) 2.00003E
|
||||
>>>
|
||||
2.00003E
|
||||
2.00003E
|
||||
1.00005e a
|
||||
>>>=0
|
||||
|
||||
|
@ -94,7 +94,7 @@ hledger -f - balance -B
|
||||
$-135 assets
|
||||
$135 expenses:foreign currency
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>=0
|
||||
|
||||
# 8. transaction in two commodities should balance out properly
|
||||
@ -107,7 +107,7 @@ hledger -f - balance --cost
|
||||
16$ a
|
||||
-16$ b
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>=0
|
||||
|
||||
# 9. When commodity price is specified implicitly, transaction should
|
||||
@ -123,7 +123,7 @@ hledger -f - balance
|
||||
16$ b
|
||||
--------------------
|
||||
16$
|
||||
-10£
|
||||
-10£
|
||||
>>>=0
|
||||
|
||||
# 10. When commodity price is specified implicitly, transaction should
|
||||
@ -147,7 +147,7 @@ hledger -f - balance
|
||||
>>>
|
||||
£2 a
|
||||
--------------------
|
||||
£2
|
||||
£2
|
||||
>>>=0
|
||||
|
||||
# 12. this should balance
|
||||
@ -188,7 +188,7 @@ hledger -f - balance --no-total
|
||||
-1X a
|
||||
>>>= 0
|
||||
|
||||
# 16.
|
||||
# 16.
|
||||
hledger -f - balance --no-total -B
|
||||
<<<
|
||||
1/1
|
||||
|
@ -90,7 +90,7 @@ $ hledger -f- balance -V
|
||||
150.48 H a
|
||||
-150.00 H b
|
||||
--------------------
|
||||
0.48 H
|
||||
0.48 H
|
||||
|
||||
|
||||
# 7. register -V affects posting amounts and total.
|
||||
|
@ -50,6 +50,6 @@ hledger -f- balance --tree
|
||||
10 e
|
||||
-10 f
|
||||
--------------------
|
||||
0
|
||||
0
|
||||
>>>2
|
||||
>>>=0
|
||||
|
Loading…
Reference in New Issue
Block a user