slaesvuo/hledger
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

lib,cli: Make showTransaction return Text rather than String.

Browse Source
This commit is contained in:
Stephen Morgan 2020-10-28 12:53:37 +11:00
parent dbe7015502
commit 74b296f865
14 changed files with 132 additions and 121 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
hledger-lib/Hledger/Data/Journal.hs
View File

@ -895,7 +895,7 @@ checkBalanceAssertionOneCommodityB p@Posting{paccount=assertedacct} assertedamt
Nothing -> "?" -- shouldn't happen Nothing -> "?" -- shouldn't happen
Just t -> printf "%s\ntransaction:\n%s" Just t -> printf "%s\ntransaction:\n%s"
(showGenericSourcePos pos) (showGenericSourcePos pos)
(chomp $ showTransaction t) (textChomp $ showTransaction t)
:: String :: String
where where
pos = baposition $ fromJust $ pbalanceassertion p pos = baposition $ fromJust $ pbalanceassertion p
@ -926,11 +926,11 @@ checkIllegalBalanceAssignmentB p = do
checkBalanceAssignmentPostingDateB :: Posting -> Balancing s () checkBalanceAssignmentPostingDateB :: Posting -> Balancing s ()
checkBalanceAssignmentPostingDateB p = checkBalanceAssignmentPostingDateB p =
when (hasBalanceAssignment p && isJust (pdate 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." ["postings which are balance assignments may not have a custom date."
,"Please write the posting amount explicitly, or remove the posting 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 -- | 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 checkBalanceAssignmentUnassignableAccountB p = do
unassignable <- R.asks bsUnassignable unassignable <- R.asks bsUnassignable
when (hasBalanceAssignment p && paccount p `S.member` unassignable) $ when (hasBalanceAssignment p && paccount p `S.member` unassignable) $
throwError $ unlines $ throwError . T.unpack $ T.unlines
["balance assignments cannot be used with accounts which are" ["balance assignments cannot be used with accounts which are"
,"posted to by transaction modifier rules (auto postings)." ,"posted to by transaction modifier rules (auto postings)."
,"Please write the posting amount explicitly, or remove the rule." ,"Please write the posting amount explicitly, or remove the rule."
,"" ,""
,"account: "++T.unpack (paccount p) ,"account: " <> paccount p
,"" ,""
,"transaction:" ,"transaction:"
,"" ,""
,maybe (unlines $ showPostingLines p) showTransaction $ ptransaction p ,maybe (T.unlines $ showPostingLines p) showTransaction $ ptransaction p
] ]
-- --

5
hledger-lib/Hledger/Data/PeriodicTransaction.hs
View File

@ -16,6 +16,7 @@ where
import Data.Semigroup ((<>)) import Data.Semigroup ((<>))
#endif #endif
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T
import Text.Printf import Text.Printf
import Hledger.Data.Types import Hledger.Data.Types
@ -40,7 +41,7 @@ _ptgen str = do
case checkPeriodicTransactionStartDate i s t of case checkPeriodicTransactionStartDate i s t of
Just e -> error' e -- PARTIAL: Just e -> error' e -- PARTIAL:
Nothing -> Nothing ->
mapM_ (putStr . showTransaction) $ mapM_ (T.putStr . showTransaction) $
runPeriodicTransaction runPeriodicTransaction
nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }
nulldatespan nulldatespan
@ -52,7 +53,7 @@ _ptgenspan str span = do
case checkPeriodicTransactionStartDate i s t of case checkPeriodicTransactionStartDate i s t of
Just e -> error' e -- PARTIAL: Just e -> error' e -- PARTIAL:
Nothing -> Nothing ->
mapM_ (putStr . showTransaction) $ mapM_ (T.putStr . showTransaction) $
runPeriodicTransaction runPeriodicTransaction
nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] } nullperiodictransaction{ ptperiodexpr=t , ptspan=s, ptinterval=i, ptpostings=["a" `post` usd 1] }
span span

4
hledger-lib/Hledger/Data/Timeclock.hs
View File

@ -90,8 +90,8 @@ errorWithSourceLine line msg = error $ "line " ++ show line ++ ": " ++ msg
entryFromTimeclockInOut :: TimeclockEntry -> TimeclockEntry -> Transaction entryFromTimeclockInOut :: TimeclockEntry -> TimeclockEntry -> Transaction
entryFromTimeclockInOut i o entryFromTimeclockInOut i o
| otime >= itime = t | otime >= itime = t
| otherwise = | otherwise = error' . T.unpack $
error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t -- PARTIAL: "clock-out time less than clock-in time in:\n" <> showTransaction t -- PARTIAL:
where where
t = Transaction { t = Transaction {
tindex = 0, tindex = 0,

116
hledger-lib/Hledger/Data/Transaction.hs
View File

@ -63,7 +63,6 @@ import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import Data.Time.Calendar import Data.Time.Calendar
import Text.Printf
import qualified Data.Map as M import qualified Data.Map as M
import Hledger.Utils import Hledger.Utils
@ -148,53 +147,54 @@ To facilitate this, postings with explicit multi-commodity amounts
are displayed as multiple similar postings, one per commodity. are displayed as multiple similar postings, one per commodity.
(Normally does not happen with this function). (Normally does not happen with this function).
-} -}
showTransaction :: Transaction -> String showTransaction :: Transaction -> Text
showTransaction = showTransactionHelper False showTransaction = showTransactionHelper False
-- | Deprecated alias for 'showTransaction' -- | Deprecated alias for 'showTransaction'
showTransactionUnelided :: Transaction -> String showTransactionUnelided :: Transaction -> Text
showTransactionUnelided = showTransaction -- TODO: drop it showTransactionUnelided = showTransaction -- TODO: drop it
-- | Like showTransaction, but explicit multi-commodity amounts -- | Like showTransaction, but explicit multi-commodity amounts
-- are shown on one line, comma-separated. In this case the output will -- are shown on one line, comma-separated. In this case the output will
-- not be parseable journal syntax. -- not be parseable journal syntax.
showTransactionOneLineAmounts :: Transaction -> String showTransactionOneLineAmounts :: Transaction -> Text
showTransactionOneLineAmounts = showTransactionHelper True showTransactionOneLineAmounts = showTransactionHelper True
-- | Deprecated alias for 'showTransactionOneLineAmounts' -- | Deprecated alias for 'showTransactionOneLineAmounts'
showTransactionUnelidedOneLineAmounts :: Transaction -> String showTransactionUnelidedOneLineAmounts :: Transaction -> Text
showTransactionUnelidedOneLineAmounts = showTransactionOneLineAmounts -- TODO: drop it showTransactionUnelidedOneLineAmounts = showTransactionOneLineAmounts -- TODO: drop it
-- | Helper for showTransaction*. -- | Helper for showTransaction*.
showTransactionHelper :: Bool -> Transaction -> String showTransactionHelper :: Bool -> Transaction -> Text
showTransactionHelper onelineamounts t = showTransactionHelper onelineamounts t =
unlines $ [descriptionline] T.unlines $
++ newlinecomments descriptionline
++ (postingsAsLines onelineamounts (tpostings t)) : newlinecomments
++ [""] ++ (postingsAsLines onelineamounts (tpostings t))
where ++ [""]
descriptionline = rstrip $ concat [date, status, code, desc, samelinecomment] where
date = showDate (tdate t) ++ maybe "" (("="++) . showDate) (tdate2 t) descriptionline = T.stripEnd $ T.concat [date, status, code, desc, samelinecomment]
status | tstatus t == Cleared = " *" date = T.pack $ showDate (tdate t) ++ maybe "" (("="++) . showDate) (tdate2 t)
| tstatus t == Pending = " !" status | tstatus t == Cleared = " *"
| otherwise = "" | tstatus t == Pending = " !"
code = if T.length (tcode t) > 0 then printf " (%s)" $ T.unpack $ tcode t else "" | otherwise = ""
desc = if null d then "" else " " ++ d where d = T.unpack $ tdescription t code = if T.null (tcode t) then "" else wrap " (" ")" $ tcode t
(samelinecomment, newlinecomments) = desc = if T.null d then "" else " " <> d where d = tdescription t
case renderCommentLines (tcomment t) of [] -> ("",[]) (samelinecomment, newlinecomments) =
c:cs -> (c,cs) case renderCommentLines (tcomment t) of [] -> ("",[])
c:cs -> (c,cs)
-- | Render a transaction or posting's comment as indented, semicolon-prefixed comment lines. -- | 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. -- The first line (unless empty) will have leading space, subsequent lines will have a larger indent.
renderCommentLines :: Text -> [String] renderCommentLines :: Text -> [Text]
renderCommentLines t = 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 ("":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 where
comment = ("; "++) comment = ("; "<>)
-- | Given a transaction and its postings, render the postings, suitable -- | Given a transaction and its postings, render the postings, suitable
-- for `print` output. Normally this output will be valid journal syntax which -- 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 -- Posting amounts will be aligned with each other, starting about 4 columns
-- beyond the widest account name (see postingAsLines for details). -- 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 postingsAsLines onelineamounts ps = concatMap (postingAsLines False onelineamounts ps) ps
-- | Render one posting, on one or more lines, suitable for `print` output. -- | Render one posting, on one or more lines, suitable for `print` output.
@ -236,23 +236,25 @@ postingsAsLines onelineamounts ps = concatMap (postingAsLines False onelineamoun
-- increased if needed to match the posting with the longest account name. -- increased if needed to match the posting with the longest account name.
-- This is used to align the amounts of a transaction's postings. -- This is used to align the amounts of a transaction's postings.
-- --
postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [String] postingAsLines :: Bool -> Bool -> [Posting] -> Posting -> [Text]
postingAsLines elideamount onelineamounts pstoalignwith p = concat [ postingAsLines elideamount onelineamounts pstoalignwith p = concat [
postingblock postingblock
++ newlinecomments ++ newlinecomments
| postingblock <- postingblocks] | postingblock <- postingblocks]
where where
postingblocks = [map rstrip $ lines $ concatTopPadded [statusandaccount, " ", amt, assertion, samelinecomment] | amt <- shownAmounts] postingblocks = [map (T.stripEnd . T.pack) . lines $
concatTopPadded [T.unpack statusandaccount, " ", amt, assertion, T.unpack samelinecomment]
| amt <- shownAmounts]
assertion = maybe "" ((' ':).showBalanceAssertion) $ pbalanceassertion p assertion = maybe "" ((' ':).showBalanceAssertion) $ pbalanceassertion p
statusandaccount = lineIndent $ fitString (Just $ minwidth) Nothing False True $ pstatusandacct p statusandaccount = lineIndent . fitText (Just $ minwidth) Nothing False True $ pstatusandacct p
where where
-- pad to the maximum account name width, plus 2 to leave room for status flags, to keep amounts aligned -- 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 minwidth = maximum $ map ((2+) . textWidth . pacctstr) pstoalignwith
pstatusandacct p' = pstatusprefix p' ++ pacctstr p' pstatusandacct p' = pstatusprefix p' <> pacctstr p'
pstatusprefix p' | null s = "" pstatusprefix p' = case pstatus p' of
| otherwise = s ++ " " Unmarked -> ""
where s = show $ pstatus p' s -> T.pack (show s) <> " "
pacctstr p' = showAccountName Nothing (ptype p') (paccount p') pacctstr p' = showAccountName Nothing (ptype p') (paccount p')
-- currently prices are considered part of the amount string when right-aligning amounts -- currently prices are considered part of the amount string when right-aligning amounts
shownAmounts shownAmounts
@ -286,33 +288,27 @@ showBalanceAssertion BalanceAssertion{..} =
-- | Render a posting, at the appropriate width for aligning with -- | Render a posting, at the appropriate width for aligning with
-- its siblings if any. Used by the rewrite command. -- its siblings if any. Used by the rewrite command.
showPostingLines :: Posting -> [String] showPostingLines :: Posting -> [Text]
showPostingLines p = postingAsLines False False ps p where showPostingLines p = postingAsLines False False ps p where
ps | Just t <- ptransaction p = tpostings t ps | Just t <- ptransaction p = tpostings t
| otherwise = [p] | otherwise = [p]
-- | Prepend a suitable indent for a posting (or transaction/posting comment) line. -- | Prepend a suitable indent for a posting (or transaction/posting comment) line.
lineIndent :: String -> String lineIndent :: Text -> Text
lineIndent = (" "++) lineIndent = (" "<>)
-- | Prepend the space required before a same-line comment. -- | Prepend the space required before a same-line comment.
commentSpace :: String -> String commentSpace :: Text -> Text
commentSpace = (" "++) commentSpace = (" "<>)
-- | Show an account name, clipped to the given width if any, and -- | Show an account name, clipped to the given width if any, and
-- appropriately bracketed/parenthesised for the given posting type. -- appropriately bracketed/parenthesised for the given posting type.
showAccountName :: Maybe Int -> PostingType -> AccountName -> String showAccountName :: Maybe Int -> PostingType -> AccountName -> Text
showAccountName w = fmt showAccountName w = fmt
where where
fmt RegularPosting = maybe id take w . T.unpack fmt RegularPosting = maybe id T.take w
fmt VirtualPosting = parenthesise . maybe id (takeEnd . subtract 2) w . T.unpack fmt VirtualPosting = wrap "(" ")" . maybe id (T.takeEnd . subtract 2) w
fmt BalancedVirtualPosting = bracket . maybe id (takeEnd . subtract 2) w . T.unpack fmt BalancedVirtualPosting = wrap "[" "]" . maybe id (T.takeEnd . subtract 2) w
parenthesise :: String -> String
parenthesise s = "("++s++")"
bracket :: String -> String
bracket s = "["++s++"]"
hasRealPostings :: Transaction -> Bool hasRealPostings :: Transaction -> Bool
hasRealPostings = not . null . realPostings hasRealPostings = not . null . realPostings
@ -427,7 +423,7 @@ transactionBalanceError t errs =
annotateErrorWithTransaction :: Transaction -> String -> String annotateErrorWithTransaction :: Transaction -> String -> String
annotateErrorWithTransaction t s = 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 -- | 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 -- likewise for its balanced virtual postings, if needed; or return an error
@ -678,7 +674,7 @@ tests_Transaction =
Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` usd 5]} 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]}) @?= (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]} Right nulltransaction{tpostings = ["a" `post` usd (-5), "b" `post` (eur 3 @@ usd 4), "c" `post` usd 1]}
, tests "showTransaction" [ , tests "showTransaction" [
test "null transaction" $ showTransaction nulltransaction @?= "0000-01-01\n\n" test "null transaction" $ showTransaction nulltransaction @?= "0000-01-01\n\n"
, test "non-null transaction" $ showTransaction , test "non-null transaction" $ showTransaction
@ -701,7 +697,7 @@ tests_Transaction =
} }
] ]
} @?= } @?=
unlines T.unlines
[ "2012-05-14=2012-05-15 (code) desc ; tcomment1" [ "2012-05-14=2012-05-15 (code) desc ; tcomment1"
, " ; tcomment2" , " ; tcomment2"
, " * a $1.00" , " * a $1.00"
@ -727,7 +723,7 @@ tests_Transaction =
, posting {paccount = "assets:checking", pamount = Mixed [usd (-47.18)], ptransaction = Just t} , posting {paccount = "assets:checking", pamount = Mixed [usd (-47.18)], ptransaction = Just t}
] ]
in showTransaction t) @?= in showTransaction t) @?=
(unlines (T.unlines
[ "2007-01-28 coopportunity" [ "2007-01-28 coopportunity"
, " expenses:food:groceries $47.18" , " expenses:food:groceries $47.18"
, " assets:checking $-47.18" , " assets:checking $-47.18"
@ -750,7 +746,7 @@ tests_Transaction =
[ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18]} [ posting {paccount = "expenses:food:groceries", pamount = Mixed [usd 47.18]}
, posting {paccount = "assets:checking", pamount = Mixed [usd (-47.19)]} , posting {paccount = "assets:checking", pamount = Mixed [usd (-47.19)]}
])) @?= ])) @?=
(unlines (T.unlines
[ "2007-01-28 coopportunity" [ "2007-01-28 coopportunity"
, " expenses:food:groceries $47.18" , " expenses:food:groceries $47.18"
, " assets:checking $-47.19" , " assets:checking $-47.19"
@ -771,9 +767,9 @@ tests_Transaction =
"" ""
[] []
[posting {paccount = "expenses:food:groceries", pamount = missingmixedamt}])) @?= [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" $ , test "show a transaction with a priced commodityless amount" $
(showTransaction (T.unpack $ showTransaction
(txnTieKnot $ (txnTieKnot $
Transaction Transaction
0 0

2
hledger-lib/Hledger/Data/TransactionModifier.hs
View File

@ -62,7 +62,7 @@ modifyTransactions d tmods ts = do
-- postings when certain other postings are present. -- postings when certain other postings are present.
-- --
-- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]} -- >>> t = nulltransaction{tpostings=["ping" `post` usd 1]}
-- >>> test = either putStr (putStr.showTransaction) . fmap ($ t) . transactionModifierToFunction nulldate -- >>> test = either putStr (putStr.T.unpack.showTransaction) . fmap ($ t) . transactionModifierToFunction nulldate
-- >>> test $ TransactionModifier "" ["pong" `post` usd 2] -- >>> test $ TransactionModifier "" ["pong" `post` usd 2]
-- 0000-01-01 -- 0000-01-01
-- ping $1.00 -- ping $1.00

5
hledger-lib/Hledger/Utils/Text.hs
View File

@ -13,6 +13,7 @@ module Hledger.Utils.Text
-- stripbrackets, -- stripbrackets,
textUnbracket, textUnbracket,
wrap, wrap,
textChomp,
-- -- quoting -- -- quoting
quoteIfSpaced, quoteIfSpaced,
textQuoteIfNeeded, textQuoteIfNeeded,
@ -92,6 +93,10 @@ textElideRight width t =
wrap :: Text -> Text -> Text -> Text wrap :: Text -> Text -> Text -> Text
wrap start end x = start <> x <> end 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. -- -- | 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). -- -- Works on multi-line strings too (but will rewrite non-unix line endings).
-- formatString :: Bool -> Maybe Int -> Maybe Int -> String -> String -- formatString :: Bool -> Maybe Int -> Maybe Int -> String -> String

7
hledger-ui/Hledger/UI/TransactionScreen.hs
View File

@ -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 fromMaybe (error' "TransactionScreen: expected a non-empty journal") $ -- PARTIAL: shouldn't happen
reportPeriodOrJournalLastDay rspec j reportPeriodOrJournalLastDay rspec j
render $ defaultLayout toplabel bottomlabel $ str $ render . defaultLayout toplabel bottomlabel . str
showTransactionOneLineAmounts $ . T.unpack . showTransactionOneLineAmounts
maybe t (transactionApplyValuation prices styles periodlast (rsToday rspec) t) $ value_ ropts . maybe t (transactionApplyValuation prices styles periodlast (rsToday rspec) t)
$ value_ ropts
-- (if real_ ropts then filterTransactionPostings (Real True) else id) -- filter postings by --real -- (if real_ ropts then filterTransactionPostings (Real True) else id) -- filter postings by --real
where where
toplabel = toplabel =

2
hledger-web/templates/chart.hamlet
View File

@ -38,7 +38,7 @@
#{simpleMixedAmountQuantity $ triCommodityBalance c i}, #{simpleMixedAmountQuantity $ triCommodityBalance c i},
'#{showMixedAmountWithZeroCommodity $ triCommodityAmount c i}', '#{showMixedAmountWithZeroCommodity $ triCommodityAmount c i}',
'#{showMixedAmountWithZeroCommodity $ triCommodityBalance 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} #{tindex $ triOrigTransaction i}
], ],
/* [] */ /* [] */

41
hledger/Hledger/Cli/Commands/Add.hs
View File

@ -27,18 +27,19 @@ import Data.Either (isRight)
import Data.Functor.Identity (Identity(..)) import Data.Functor.Identity (Identity(..))
import "base-compat-batteries" Data.List.Compat import "base-compat-batteries" Data.List.Compat
import qualified Data.Set as S import qualified Data.Set as S
import Data.Maybe import Data.Maybe (fromJust, fromMaybe, isJust)
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as T 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 as TL
import qualified Data.Text.Lazy.IO as TL import qualified Data.Text.Lazy.IO as TL
import Data.Time.Calendar (Day) import Data.Time.Calendar (Day)
import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat) import Data.Time.Format (formatTime, defaultTimeLocale, iso8601DateFormat)
import Safe (headDef, headMay, atMay) 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 (runInputT, defaultSettings, setComplete)
import System.Console.Haskeline.Completion import System.Console.Haskeline.Completion (CompletionFunc, completeWord, isFinished, noCompletion, simpleCompletion)
import System.Console.Wizard import System.Console.Wizard (Wizard, defaultTo, line, output, retryMsg, linePrewritten, nonEmpty, parser, run)
import System.Console.Wizard.Haskeline import System.Console.Wizard.Haskeline
import System.IO ( stderr, hPutStr, hPutStrLn ) import System.IO ( stderr, hPutStr, hPutStrLn )
import Text.Megaparsec import Text.Megaparsec
@ -91,7 +92,7 @@ add :: CliOpts -> Journal -> IO ()
add opts j add opts j
| journalFilePath j == "-" = return () | journalFilePath j == "-" = return ()
| otherwise = do | otherwise = do
hPrintf stderr "Adding transactions to journal file %s\n" (journalFilePath j) hPutStrLn stderr $ "Adding transactions to journal file " <> journalFilePath j
showHelp showHelp
today <- getCurrentDay today <- getCurrentDay
let es = defEntryState{esOpts=opts let es = defEntryState{esOpts=opts
@ -125,16 +126,16 @@ getAndAddTransactions es@EntryState{..} = (do
Nothing -> error "Could not interpret the input, restarting" -- caught below causing a restart, I believe -- PARTIAL: Nothing -> error "Could not interpret the input, restarting" -- caught below causing a restart, I believe -- PARTIAL:
Just t -> do Just t -> do
j <- if debug_ esOpts > 0 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 return esJournal
else do j' <- journalAddTransaction esJournal esOpts t else do j' <- journalAddTransaction esJournal esOpts t
hPrintf stderr "Saved.\n" hPutStrLn stderr "Saved."
return j' 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} getAndAddTransactions es{esJournal=j, esDefDate=tdate t}
) )
`E.catch` (\(_::RestartTransactionException) -> `E.catch` (\(_::RestartTransactionException) ->
hPrintf stderr "Restarting this transaction.\n" >> getAndAddTransactions es) hPutStrLn stderr "Restarting this transaction." >> getAndAddTransactions es)
data TxnParams = TxnParams data TxnParams = TxnParams
{ txnDate :: Day { txnDate :: Day
@ -182,7 +183,9 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
} }
descAndCommentString = T.unpack $ desc <> (if T.null comment then "" else " ; " <> comment) descAndCommentString = T.unpack $ desc <> (if T.null comment then "" else " ; " <> comment)
prevInput' = prevInput{prevDescAndCmnt=Just descAndCommentString} 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) confirmedTransactionWizard prevInput' es' ((EnterNewPosting TxnParams{txnDate=date, txnCode=code, txnDesc=desc, txnCmnt=comment} Nothing) : stack)
Nothing -> Nothing ->
confirmedTransactionWizard prevInput es (drop 1 stack) confirmedTransactionWizard prevInput es (drop 1 stack)
@ -241,7 +244,7 @@ confirmedTransactionWizard prevInput es@EntryState{..} stack@(currentStage : _)
Nothing -> confirmedTransactionWizard prevInput es (drop 1 stack) Nothing -> confirmedTransactionWizard prevInput es (drop 1 stack)
EndStage t -> do EndStage t -> do
output $ showTransaction t output . T.unpack $ showTransaction t
y <- let def = "y" in y <- let def = "y" in
retryMsg "Please enter y or n." $ retryMsg "Please enter y or n." $
parser ((fmap (\c -> if c == '<' then Nothing else Just c)) . headMay . map toLower . strip) $ parser ((fmap (\c -> if c == '<' then Nothing else Just c)) . headMay . map toLower . strip) $
@ -305,7 +308,7 @@ accountWizard PrevInput{..} EntryState{..} = do
historicalp = fmap ((!! (pnum - 1)) . (++ (repeat nullposting)) . tpostings) esSimilarTransaction historicalp = fmap ((!! (pnum - 1)) . (++ (repeat nullposting)) . tpostings) esSimilarTransaction
historicalacct = case historicalp of Just p -> showAccountName Nothing (ptype p) (paccount p) historicalacct = case historicalp of Just p -> showAccountName Nothing (ptype p) (paccount p)
Nothing -> "" Nothing -> ""
def = headDef historicalacct esArgs def = headDef (T.unpack historicalacct) esArgs
endmsg | canfinish && null def = " (or . or enter to finish this transaction)" endmsg | canfinish && null def = " (or . or enter to finish this transaction)"
| canfinish = " (or . to finish this transaction)" | canfinish = " (or . to finish this transaction)"
| otherwise = "" | otherwise = ""
@ -444,7 +447,7 @@ journalAddTransaction j@Journal{jtxns=ts} opts t = do
-- unelided shows all amounts explicitly, in case there's a price, cf #283 -- unelided shows all amounts explicitly, in case there's a price, cf #283
when (debug_ opts > 0) $ do when (debug_ opts > 0) $ do
putStrLn $ printf "\nAdded transaction to %s:" f putStrLn $ printf "\nAdded transaction to %s:" f
TL.putStrLn =<< registerFromString (T.pack $ showTransaction t) TL.putStrLn =<< registerFromString (showTransaction t)
return j{jtxns=ts++[t]} return j{jtxns=ts++[t]}
-- | Append a string, typically one or more transactions, to a journal -- | Append a string, typically one or more transactions, to a journal
@ -455,15 +458,15 @@ journalAddTransaction j@Journal{jtxns=ts} opts t = do
-- even if the file uses dos line endings (\r\n), which could leave -- even if the file uses dos line endings (\r\n), which could leave
-- mixed line endings in the file. See also writeFileWithBackupIfChanged. -- mixed line endings in the file. See also writeFileWithBackupIfChanged.
-- --
appendToJournalFileOrStdout :: FilePath -> String -> IO () appendToJournalFileOrStdout :: FilePath -> Text -> IO ()
appendToJournalFileOrStdout f s appendToJournalFileOrStdout f s
| f == "-" = putStr s' | f == "-" = T.putStr s'
| otherwise = appendFile f s' | otherwise = appendFile f $ T.unpack s'
where s' = "\n" ++ ensureOneNewlineTerminated s where s' = "\n" <> ensureOneNewlineTerminated s
-- | Replace a string's 0 or more terminating newlines with exactly one. -- | Replace a string's 0 or more terminating newlines with exactly one.
ensureOneNewlineTerminated :: String -> String ensureOneNewlineTerminated :: Text -> Text
ensureOneNewlineTerminated = (++"\n") . reverse . dropWhile (=='\n') . reverse ensureOneNewlineTerminated = (<>"\n") . T.dropWhileEnd (=='\n')
-- | Convert a string of journal data into a register report. -- | Convert a string of journal data into a register report.
registerFromString :: Text -> IO TL.Text registerFromString :: Text -> IO TL.Text

8
hledger/Hledger/Cli/Commands/Close.hs
View File

@ -11,7 +11,8 @@ import Control.Monad (when)
import Data.Function (on) import Data.Function (on)
import Data.List (groupBy) import Data.List (groupBy)
import Data.Maybe import Data.Maybe
import qualified Data.Text as T (pack) import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Calendar import Data.Time.Calendar
import System.Console.CmdArgs.Explicit as C import System.Console.CmdArgs.Explicit as C
@ -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] ++ [posting{paccount=openingacct, pamount=if explicit then mapMixedAmount precise (negate totalamt) else missingmixedamt} | not interleaved]
-- print them -- print them
when closing $ putStr $ showTransaction closingtxn when closing . T.putStr $ showTransaction closingtxn
when opening $ putStr $ showTransaction openingtxn when opening . T.putStr $ showTransaction openingtxn

5
hledger/Hledger/Cli/Commands/Diff.hs
View File

@ -19,6 +19,7 @@ import Data.Maybe
import Data.Time import Data.Time
import Data.Either import Data.Either
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T
import System.Exit import System.Exit
import Hledger import Hledger
@ -116,10 +117,10 @@ diff CliOpts{file_=[f1, f2], reportspec_=ReportSpec{rsQuery=Acct acctRe}} _ = do
let unmatchedtxn2 = unmatchedtxns R pp2 m let unmatchedtxn2 = unmatchedtxns R pp2 m
putStrLn "These transactions are in the first file only:\n" 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" putStrLn "These transactions are in the second file only:\n"
mapM_ (putStr . showTransaction) unmatchedtxn2 mapM_ (T.putStr . showTransaction) unmatchedtxn2
diff _ _ = do diff _ _ = do
putStrLn "Please specify two input files. Usage: hledger diff -f FILE1 -f FILE2 FULLACCOUNTNAME" putStrLn "Please specify two input files. Usage: hledger diff -f FILE1 -f FILE2 FULLACCOUNTNAME"

3
hledger/Hledger/Cli/Commands/Import.hs
View File

@ -9,6 +9,7 @@ where
import Control.Monad import Control.Monad
import Data.List import Data.List
import qualified Data.Text.IO as T
import Hledger import Hledger
import Hledger.Cli.CliOptions import Hledger.Cli.CliOptions
import Hledger.Cli.Commands.Add (journalAddTransaction) 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 printf "; would import %d new transactions from %s:\n\n" (length newts) inputstr
-- TODO how to force output here ? -- TODO how to force output here ?
-- length (jtxns newj) `seq` print' opts{rawopts_=("explicit",""):rawopts} newj -- length (jtxns newj) `seq` print' opts{rawopts_=("explicit",""):rawopts} newj
mapM_ (putStr . showTransaction) newts mapM_ (T.putStr . showTransaction) newts
newts | catchup -> do newts | catchup -> do
printf "marked %s as caught up, skipping %d unimported transactions\n\n" inputstr (length newts) printf "marked %s as caught up, skipping %d unimported transactions\n\n" inputstr (length newts)
newts -> do newts -> do

9
hledger/Hledger/Cli/Commands/Print.hs
View File

@ -19,6 +19,7 @@ import Data.Maybe (isJust)
import Data.Text (Text) import Data.Text (Text)
import Data.List (intersperse) import Data.List (intersperse)
import qualified Data.Text as T 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 as TL
import qualified Data.Text.Lazy.Builder as TB import qualified Data.Text.Lazy.Builder as TB
import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Explicit
@ -65,7 +66,7 @@ printEntries opts@CliOpts{reportspec_=rspec} j =
| otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL: | otherwise = error' $ unsupportedOutputFormatError fmt -- PARTIAL:
entriesReportAsText :: CliOpts -> EntriesReport -> TL.Text entriesReportAsText :: CliOpts -> EntriesReport -> TL.Text
entriesReportAsText opts = TB.toLazyText . foldMap (TB.fromString . showTransaction . whichtxn) entriesReportAsText opts = TB.toLazyText . foldMap (TB.fromText . showTransaction . whichtxn)
where where
whichtxn whichtxn
-- With -x, use the fully-inferred txn with all amounts & txn prices explicit. -- With -x, use the fully-inferred txn with all amounts & txn prices explicit.
@ -176,8 +177,8 @@ postingToCSV p =
where where
Mixed amounts = pamount p Mixed amounts = pamount p
status = show $ pstatus p status = show $ pstatus p
account = showAccountName Nothing (ptype p) (paccount p) account = T.unpack $ showAccountName Nothing (ptype p) (paccount p)
comment = chomp $ strip $ T.unpack $ pcomment p comment = T.unpack . textChomp . T.strip $ pcomment p
-- --match -- --match
@ -187,7 +188,7 @@ printMatch :: CliOpts -> Journal -> Text -> IO ()
printMatch CliOpts{reportspec_=rspec} j desc = do printMatch CliOpts{reportspec_=rspec} j desc = do
case similarTransaction' j (rsQuery rspec) desc of case similarTransaction' j (rsQuery rspec) desc of
Nothing -> putStrLn "no matches found." Nothing -> putStrLn "no matches found."
Just t -> putStr $ showTransaction t Just t -> T.putStr $ showTransaction t
where where
-- Identify the closest recent match for this description in past transactions. -- Identify the closest recent match for this description in past transactions.

34
hledger/Hledger/Cli/Commands/Rewrite.hs
View File

@ -13,7 +13,9 @@ import Control.Monad.Writer hiding (Any)
#endif #endif
import Data.Functor.Identity import Data.Functor.Identity
import Data.List (sortOn, foldl') import Data.List (sortOn, foldl')
import Data.Text (Text)
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Text.IO as T
import Hledger import Hledger
import Hledger.Cli.CliOptions import Hledger.Cli.CliOptions
import Hledger.Cli.Commands.Print import Hledger.Cli.Commands.Print
@ -65,9 +67,9 @@ printOrDiff opts
diffOutput :: Journal -> Journal -> IO () diffOutput :: Journal -> Journal -> IO ()
diffOutput j j' = do diffOutput j j' = do
let changed = [(originalTransaction t, originalTransaction t') | (t, t') <- zip (jtxns j) (jtxns j'), t /= t'] 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: -- XXX doctests, update needed:
-- >>> putStr $ renderPatch [(GenericSourcePos "a" 1 1, [D.First "x", D.Second "y"])] -- >>> 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 @@ -- @@ -5,0 +5,1 @@
-- +z -- +z
-- | Render list of changed lines as a unified diff -- | Render list of changed lines as a unified diff
renderPatch :: [Chunk] -> String renderPatch :: [Chunk] -> Text
renderPatch = go Nothing . sortOn fst where renderPatch = go Nothing . sortOn fst where
go _ [] = "" 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, _)) 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 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 (dels, adds) = foldl' countDiff (0, 0) diffs
chunk = concatMap renderLine diffs chunk = foldMap renderLine diffs
fileHeader fp = printf "--- %s\n+++ %s\n" fp fp fileHeader fp = "--- " <> T.pack fp <> "\n+++ " <> T.pack fp <> "\n"
countDiff (dels, adds) = \case countDiff (dels, adds) = \case
Del _ -> (dels + 1, adds) Del _ -> (dels + 1, adds)
@ -113,9 +115,9 @@ renderPatch = go Nothing . sortOn fst where
Ctx _ -> (dels + 1, adds + 1) Ctx _ -> (dels + 1, adds + 1)
renderLine = \case renderLine = \case
Del s -> '-' : s ++ "\n" Del s -> "-" <> s <> "\n"
Add s -> '+' : s ++ "\n" Add s -> "+" <> s <> "\n"
Ctx s -> ' ' : s ++ "\n" Ctx s -> " " <> s <> "\n"
diffTxn :: Journal -> Transaction -> Transaction -> Chunk diffTxn :: Journal -> Transaction -> Transaction -> Chunk
diffTxn j t t' = diffTxn j t t' =
@ -124,18 +126,18 @@ diffTxn j t t' =
-- TODO: use range and produce two chunks: one removes part of -- TODO: use range and produce two chunks: one removes part of
-- original file, other adds transaction to new file with -- original file, other adds transaction to new file with
-- suffix .ledger (generated). I.e. move transaction from one file to another. -- 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') diffs = concat . map (traverse showPostingLines . mapDiff) $ D.getDiff (tpostings t) (tpostings t')
pos@(JournalSourcePos fp (line, line')) -> (pos, diffs) where pos@(JournalSourcePos fp (line, line')) -> (pos, diffs) where
-- We do diff for original lines vs generated ones. Often leads -- We do diff for original lines vs generated ones. Often leads
-- to big diff because of re-format effect. -- to big diff because of re-format effect.
diffs :: [DiffLine String] diffs :: [DiffLine Text]
diffs = map mapDiff $ D.getDiff source changed' 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 = [] | otherwise = []
changed = lines $ showTransaction t' changed = T.lines $ showTransaction t'
changed' | null changed = changed changed' | null changed = changed
| null $ last changed = init changed | T.null $ last changed = init changed
| otherwise = changed | otherwise = changed
data DiffLine a = Del a | Add a | Ctx a data DiffLine a = Del a | Add a | Ctx a