diff --git a/Hledger/Cli.hs b/Hledger/Cli.hs --- a/Hledger/Cli.hs +++ b/Hledger/Cli.hs @@ -13,9 +13,17 @@ module Hledger.Cli.Stats, module Hledger.Cli.Options, module Hledger.Cli.Utils, + module Hledger.Cli.Version, tests_Hledger_Cli ) where +import Control.Monad +import qualified Data.Map as Map +import Data.Time.Calendar +import System.Time (ClockTime(TOD)) +import Test.HUnit + +import Hledger import Hledger.Cli.Add import Hledger.Cli.Balance import Hledger.Cli.Convert @@ -25,19 +33,11 @@ import Hledger.Cli.Stats import Hledger.Cli.Options import Hledger.Cli.Utils - - -import qualified Data.Map as Map -import System.Time (ClockTime(TOD)) - -import Hledger.Data -- including testing utils in Hledger.Data.Utils -import Hledger.Read -import Hledger.Read.JournalReader (someamount) - +import Hledger.Cli.Version -- | hledger and hledger-lib's unit tests aggregated from all modules -- plus some more which are easier to define here for now. --- tests_Hledger_Cli1 :: Test +tests_Hledger_Cli :: Test tests_Hledger_Cli = TestList [ tests_Hledger_Data @@ -83,8 +83,20 @@ "2008/12/07 Four\n outer:why $-4\n outer:zed $4\n" ++ "2008/12/07 Five\n foo $-5\n bar $5\n" ) + + ,"account directive should preserve \"virtual\" posting type" ~: do + j <- readJournal Nothing "!account test\n2008/12/07 One\n (from) $-1\n (to) $1\n" >>= either error' return + let p = head $ tpostings $ head $ jtxns j + assertBool "" $ (paccount p) == "test:from" + assertBool "" $ (ptype p) == VirtualPosting + ] + ,"account aliases" ~: do + Right j <- readJournal Nothing "!alias expenses = equity:draw:personal\n1/1\n (expenses:food) 1\n" + let p = head $ tpostings $ head $ jtxns j + assertBool "" $ paccount p == "equity:draw:personal:food" + ,"ledgerAccountNames" ~: ledgerAccountNames ledger7 `is` ["assets","assets:cash","assets:checking","assets:saving","equity","equity:opening balances", @@ -92,15 +104,14 @@ "liabilities","liabilities:credit cards","liabilities:credit cards:discover"] ,"balance report tests" ~: - let (opts,args) `gives` es = do - l <- samplejournalwithopts opts args - t <- getCurrentLocalTime - balanceReportAsText opts (balanceReport opts (optsToFilterSpec opts args t) l) `is` unlines es + let opts `gives` es = do + j <- samplejournal + d <- getCurrentDay + accountsReportAsText opts (accountsReport opts (optsToFilterSpec opts d) j) `is` es in TestList [ - "balance report with no args" ~: - ([], []) `gives` + defreportopts `gives` [" $-1 assets" ," $1 bank:saving" ," $-2 cash" @@ -116,7 +127,7 @@ ] ,"balance report can be limited with --depth" ~: - ([Depth "1"], []) `gives` + defreportopts{depth_=Just 1} `gives` [" $-1 assets" ," $2 expenses" ," $-2 income" @@ -126,7 +137,7 @@ ] ,"balance report with account pattern o" ~: - ([SubTotal], ["o"]) `gives` + defreportopts{patterns_=["o"]} `gives` [" $1 expenses:food" ," $-2 income" ," $-1 gifts" @@ -136,7 +147,7 @@ ] ,"balance report with account pattern o and --depth 1" ~: - ([Depth "1"], ["o"]) `gives` + defreportopts{patterns_=["o"],depth_=Just 1} `gives` [" $1 expenses" ," $-2 income" ,"--------------------" @@ -144,7 +155,7 @@ ] ,"balance report with account pattern a" ~: - ([], ["a"]) `gives` + defreportopts{patterns_=["a"]} `gives` [" $-1 assets" ," $1 bank:saving" ," $-2 cash" @@ -155,7 +166,7 @@ ] ,"balance report with account pattern e" ~: - ([], ["e"]) `gives` + defreportopts{patterns_=["e"]} `gives` [" $-1 assets" ," $1 bank:saving" ," $-2 cash" @@ -171,7 +182,7 @@ ] ,"balance report with unmatched parent of two matched subaccounts" ~: - ([], ["cash","saving"]) `gives` + defreportopts{patterns_=["cash","saving"]} `gives` [" $-1 assets" ," $1 bank:saving" ," $-2 cash" @@ -180,14 +191,14 @@ ] ,"balance report with multi-part account name" ~: - ([], ["expenses:food"]) `gives` + defreportopts{patterns_=["expenses:food"]} `gives` [" $1 expenses:food" ,"--------------------" ," $1" ] ,"balance report with negative account pattern" ~: - ([], ["not:assets"]) `gives` + defreportopts{patterns_=["not:assets"]} `gives` [" $2 expenses" ," $1 food" ," $1 supplies" @@ -200,20 +211,20 @@ ] ,"balance report negative account pattern always matches full name" ~: - ([], ["not:e"]) `gives` + defreportopts{patterns_=["not:e"]} `gives` ["--------------------" ," 0" ] ,"balance report negative patterns affect totals" ~: - ([], ["expenses","not:food"]) `gives` + defreportopts{patterns_=["expenses","not:food"]} `gives` [" $1 expenses:supplies" ,"--------------------" ," $1" ] ,"balance report with -E shows zero-balance accounts" ~: - ([SubTotal,Empty], ["assets"]) `gives` + defreportopts{patterns_=["assets"],empty_=True} `gives` [" $-1 assets" ," $1 bank" ," 0 checking" @@ -231,8 +242,7 @@ ," c:d " ]) >>= either error' return let j' = journalCanonicaliseAmounts $ journalConvertAmountsToCost j -- enable cost basis adjustment - balanceReportAsText [] (balanceReport [] nullfilterspec j') `is` - unlines + accountsReportAsText defreportopts (accountsReport defreportopts nullfilterspec j') `is` [" $500 a:b" ," $-500 c:d" ,"--------------------" @@ -240,14 +250,13 @@ ] ,"balance report elides zero-balance root account(s)" ~: do - l <- readJournalWithOpts [] + j <- readJournal' (unlines ["2008/1/1 one" ," test:a 1" ," test:b" ]) - balanceReportAsText [] (balanceReport [] nullfilterspec l) `is` - unlines + accountsReportAsText defreportopts (accountsReport defreportopts nullfilterspec j) `is` [" 1 test:a" ," -1 test:b" ,"--------------------" @@ -271,8 +280,8 @@ -- `is` "aa:aa:aaaaaaaaaaaaaa") ,"default year" ~: do - rl <- readJournal Nothing defaultyear_journal_str >>= either error' return - tdate (head $ jtxns rl) `is` fromGregorian 2009 1 1 + j <- readJournal Nothing defaultyear_journal_str >>= either error' return + tdate (head $ jtxns j) `is` fromGregorian 2009 1 1 return () ,"print report tests" ~: TestList @@ -280,10 +289,10 @@ "print expenses" ~: do - let args = ["expenses"] - l <- samplejournalwithopts [] args - t <- getCurrentLocalTime - showTransactions (optsToFilterSpec [] args t) l `is` unlines + let opts = defreportopts{patterns_=["expenses"]} + j <- samplejournal + d <- getCurrentDay + showTransactions opts (optsToFilterSpec opts d) j `is` unlines ["2008/06/03 * eat & shop" ," expenses:food $1" ," expenses:supplies $1" @@ -293,9 +302,10 @@ , "print report with depth arg" ~: do - l <- samplejournal - t <- getCurrentLocalTime - showTransactions (optsToFilterSpec [Depth "2"] [] t) l `is` unlines + let opts = defreportopts{depth_=Just 2} + j <- samplejournal + d <- getCurrentDay + showTransactions opts (optsToFilterSpec opts d) j `is` unlines ["2008/01/01 income" ," income:salary $-1" ,"" @@ -322,8 +332,9 @@ "register report with no args" ~: do - l <- samplejournal - (registerReportAsText [] $ registerReport [] (optsToFilterSpec [] [] t1) l) `is` unlines + j <- samplejournal + let opts = defreportopts + (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines ["2008/01/01 income assets:bank:checking $1 $1" ," income:salary $-1 0" ,"2008/06/01 gift assets:bank:checking $1 $1" @@ -339,9 +350,9 @@ ,"register report with cleared option" ~: do - let opts = [Cleared] - l <- readJournalWithOpts opts sample_journal_str - (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` unlines + let opts = defreportopts{cleared_=True} + j <- readJournal' sample_journal_str + (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines ["2008/06/03 eat & shop expenses:food $1 $1" ," expenses:supplies $1 $2" ," assets:cash $-2 0" @@ -351,9 +362,9 @@ ,"register report with uncleared option" ~: do - let opts = [UnCleared] - l <- readJournalWithOpts opts sample_journal_str - (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` unlines + let opts = defreportopts{uncleared_=True} + j <- readJournal' sample_journal_str + (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines ["2008/01/01 income assets:bank:checking $1 $1" ," income:salary $-1 0" ,"2008/06/01 gift assets:bank:checking $1 $1" @@ -364,7 +375,7 @@ ,"register report sorts by date" ~: do - l <- readJournalWithOpts [] $ unlines + j <- readJournal' $ unlines ["2008/02/02 a" ," b 1" ," c" @@ -373,28 +384,31 @@ ," e 1" ," f" ] - registerdates (registerReportAsText [] $ registerReport [] (optsToFilterSpec [] [] t1) l) `is` ["2008/01/01","2008/02/02"] + let opts = defreportopts + registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` ["2008/01/01","2008/02/02"] ,"register report with account pattern" ~: do - l <- samplejournal - (registerReportAsText [] $ registerReport [] (optsToFilterSpec [] ["cash"] t1) l) `is` unlines + j <- samplejournal + let opts = defreportopts{patterns_=["cash"]} + (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines ["2008/06/03 eat & shop assets:cash $-2 $-2" ] ,"register report with account pattern, case insensitive" ~: do - l <- samplejournal - (registerReportAsText [] $ registerReport [] (optsToFilterSpec [] ["cAsH"] t1) l) `is` unlines + j <- samplejournal + let opts = defreportopts{patterns_=["cAsH"]} + (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines ["2008/06/03 eat & shop assets:cash $-2 $-2" ] ,"register report with display expression" ~: do - l <- samplejournal + j <- samplejournal let gives displayexpr = - (registerdates (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is`) - where opts = [Display displayexpr] + (registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is`) + where opts = defreportopts{display_=Just displayexpr} "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"] "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"] "d=[2008/6/2]" `gives` ["2008/06/02"] @@ -403,19 +417,19 @@ ,"register report with period expression" ~: do - l <- samplejournal + j <- samplejournal let periodexpr `gives` dates = do - l' <- samplejournalwithopts opts [] - registerdates (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l') `is` dates - where opts = [Period periodexpr] + j' <- samplejournal + registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j') `is` dates + where opts = defreportopts{period_=maybePeriod date1 periodexpr} "" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"] "2007" `gives` [] "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"] "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"] "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"] - let opts = [Period "yearly"] - (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` unlines + let opts = defreportopts{period_=maybePeriod date1 "yearly"} + (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1" ," assets:cash $-2 $-1" ," expenses:food $1 0" @@ -424,18 +438,18 @@ ," income:salary $-1 $-1" ," liabilities:debts $1 0" ] - let opts = [Period "quarterly"] - registerdates (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/10/01"] - let opts = [Period "quarterly",Empty] - registerdates (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] + let opts = defreportopts{period_=maybePeriod date1 "quarterly"} + registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` ["2008/01/01","2008/04/01","2008/10/01"] + let opts = defreportopts{period_=maybePeriod date1 "quarterly",empty_=True} + registerdates (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"] ] , "register report with depth arg" ~: do - l <- samplejournal - let opts = [Depth "2"] - (registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] t1) l) `is` unlines + j <- samplejournal + let opts = defreportopts{depth_=Just 2} + (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines ["2008/01/01 income assets:bank $1 $1" ," income:salary $-1 0" ,"2008/06/01 gift assets:bank $1 $1" @@ -454,9 +468,10 @@ ,"show hours" ~: show (hours 1) ~?= "1.0h" ,"unicode in balance layout" ~: do - l <- readJournalWithOpts [] + j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" - balanceReportAsText [] (balanceReport [] (optsToFilterSpec [] [] t1) l) `is` unlines + let opts = defreportopts + accountsReportAsText opts (accountsReport opts (optsToFilterSpec opts date1) j) `is` [" -100 актив:наличные" ," 100 расходы:покупки" ,"--------------------" @@ -464,9 +479,10 @@ ] ,"unicode in register layout" ~: do - l <- readJournalWithOpts [] + j <- readJournal' "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n" - (registerReportAsText [] $ registerReport [] (optsToFilterSpec [] [] t1) l) `is` unlines + let opts = defreportopts + (postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts date1) j) `is` unlines ["2009/01/01 медвежья шкура расходы:покупки 100 100" ," актив:наличные -100 0"] @@ -480,10 +496,10 @@ -- fixtures/test data -t1 = LocalTime date1 midday where date1 = parsedate "2008/11/26" +date1 = parsedate "2008/11/26" +-- t1 = LocalTime date1 midday -samplejournal = readJournalWithOpts [] sample_journal_str -samplejournalwithopts opts _ = readJournalWithOpts opts sample_journal_str +samplejournal = readJournal' sample_journal_str sample_journal_str = unlines ["; A sample journal file." @@ -906,4 +922,3 @@ [] (TOD 0 0) where parse = fromparse . parseWithCtx nullctx someamount - diff --git a/Hledger/Cli/Add.hs b/Hledger/Cli/Add.hs --- a/Hledger/Cli/Add.hs +++ b/Hledger/Cli/Add.hs @@ -1,36 +1,40 @@ -{-# LANGUAGE CPP #-} {-| A history-aware add command to help with data entry. Note: this might not be sensible, but add has some aspirations of being -both user-fiendly and pipeable/scriptable and for this reason +both user-friendly and pipeable/scriptable and for this reason informational messages are mostly written to stderr rather than stdout. -} module Hledger.Cli.Add where -import Hledger.Data -import Hledger.Read.JournalReader (someamount) -import Hledger.Cli.Options -import Hledger.Cli.Register (registerReport, registerReportAsText) -import Prelude hiding (putStr, putStrLn, appendFile) -import Hledger.Data.UTF8 (putStr, putStrLn, appendFile) - +import Control.Exception (throw) +import Control.Monad +import Control.Monad.Trans (liftIO) +import Data.Char (toUpper) +import Data.List +import Data.Maybe +import Data.Time.Calendar +import Safe (headMay) +import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine) +import System.Console.Haskeline.Completion import System.IO ( stderr, hPutStrLn, hPutStr ) import System.IO.Error import Text.ParserCombinators.Parsec -import Hledger.Cli.Utils (readJournalWithOpts) +import Text.Printf import qualified Data.Foldable as Foldable (find) -import System.Console.Haskeline ( - InputT, runInputT, defaultSettings, setComplete, getInputLine) -import Control.Monad.Trans (liftIO) -import System.Console.Haskeline.Completion import qualified Data.Set as Set -import Safe (headMay) -import Control.Exception (throw) +import Hledger +import Prelude hiding (putStr, putStrLn, appendFile) +import Hledger.Utils.UTF8 (putStr, putStrLn, appendFile) +import Hledger.Cli.Options +import Hledger.Cli.Register (postingsReportAsText) +import Hledger.Cli.Utils + + {- | Information used as the basis for suggested account names, amounts, etc in add prompt -} @@ -43,8 +47,8 @@ -- | Read transactions from the terminal, prompting for each field, -- and append them to the journal file. If the journal came from stdin, this -- command has no effect. -add :: [Opt] -> [String] -> Journal -> IO () -add opts args j +add :: CliOpts -> Journal -> IO () +add opts j | f == "-" = return () | otherwise = do hPutStrLn stderr $ @@ -52,7 +56,7 @@ ++"To complete a transaction, enter . when prompted for an account.\n" ++"To quit, press control-d or control-c." today <- getCurrentDay - getAndAddTransactions j opts args today + getAndAddTransactions j opts today `catch` (\e -> unless (isEOFError e) $ ioError e) where f = journalFilePath j @@ -60,29 +64,29 @@ -- validating, displaying and appending them to the journal file, until -- end of input (then raise an EOF exception). Any command-line arguments -- are used as the first transaction's description. -getAndAddTransactions :: Journal -> [Opt] -> [String] -> Day -> IO () -getAndAddTransactions j opts args defaultDate = do - (t, d) <- getTransaction j opts args defaultDate +getAndAddTransactions :: Journal -> CliOpts -> Day -> IO () +getAndAddTransactions j opts defaultDate = do + (t, d) <- getTransaction j opts defaultDate j <- journalAddTransaction j opts t - getAndAddTransactions j opts args d + getAndAddTransactions j opts d -- | Read a transaction from the command line, with history-aware prompting. -getTransaction :: Journal -> [Opt] -> [String] -> Day +getTransaction :: Journal -> CliOpts -> Day -> IO (Transaction,Day) -getTransaction j opts args defaultDate = do +getTransaction j opts defaultDate = do today <- getCurrentDay datestr <- runInteractionDefault $ askFor "date" (Just $ showDate defaultDate) (Just $ \s -> null s || isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s)) description <- runInteractionDefault $ askFor "description" (Just "") Nothing - let historymatches = transactionsSimilarTo j args description + let historymatches = transactionsSimilarTo j (patterns_ $ reportopts_ opts) description bestmatch | null historymatches = Nothing | otherwise = Just $ snd $ head historymatches bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr accept x = x == "." || (not . null) x && - if NoNewAccts `elem` opts + if no_new_accounts_ opts then isJust $ Foldable.find (== x) ant else True where (ant,_,_,_) = groupPostings $ journalPostings j @@ -130,7 +134,7 @@ -- force a decimal point in the output in case there's a -- digit group separator that would be mistaken for one historicalamountstr = showMixedAmountWithPrecision maxprecisionwithpoint $ pamount $ fromJust bestmatch' - balancingamountstr = showMixedAmountWithPrecision maxprecisionwithpoint $ negate $ sumMixedAmountsPreservingHighestPrecision $ map pamount enteredrealps + balancingamountstr = showMixedAmountWithPrecision maxprecisionwithpoint $ negate $ sum $ map pamount enteredrealps amountstr <- runInteractionDefault $ askFor (printf "amount %d" n) defaultamountstr validateamount let amount = fromparse $ runParser (someamount <|> return missingamt) ctx "" amountstr amount' = fromparse $ runParser (someamount <|> return missingamt) nullctx "" amountstr @@ -184,11 +188,11 @@ -- | Append this transaction to the journal's file, and to the journal's -- transaction list. -journalAddTransaction :: Journal -> [Opt] -> Transaction -> IO Journal +journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal journalAddTransaction j@Journal{jtxns=ts} opts t = do let f = journalFilePath j appendToJournalFile f $ showTransaction t - when (Debug `elem` opts) $ do + when (debug_ opts) $ do putStrLn $ printf "\nAdded transaction to %s:" f putStrLn =<< registerFromString (show t) return j{jtxns=ts++[t]} @@ -200,6 +204,9 @@ then putStr $ sep ++ s else appendFile f $ sep++s where + -- appendFile means we don't need file locking to be + -- multi-user-safe, but also that we can't figure out the minimal + -- number of newlines needed as separator sep = "\n\n" -- sep | null $ strip t = "" -- | otherwise = replicate (2 - min 2 (length lastnls)) '\n' @@ -208,10 +215,10 @@ -- | Convert a string of journal data into a register report. registerFromString :: String -> IO String registerFromString s = do - now <- getCurrentLocalTime - l <- readJournalWithOpts [] s - return $ registerReportAsText opts $ registerReport opts (optsToFilterSpec opts [] now) l - where opts = [Empty] + d <- getCurrentDay + j <- readJournal' s + return $ postingsReportAsText opts $ postingsReport opts (optsToFilterSpec opts d) j + where opts = defreportopts{empty_=True} -- | Return a similarity measure, from 0 to 1, for two strings. -- This is Simon White's letter pairs algorithm from diff --git a/Hledger/Cli/Balance.hs b/Hledger/Cli/Balance.hs --- a/Hledger/Cli/Balance.hs +++ b/Hledger/Cli/Balance.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-| A ledger-compatible @balance@ command. @@ -96,119 +95,86 @@ -} module Hledger.Cli.Balance ( - BalanceReport - ,BalanceReportItem - ,balance - ,balanceReport - ,balanceReportAsText + balance + ,accountsReportAsText ,tests_Hledger_Cli_Balance - -- ,tests_Balance ) where -import Hledger.Data.Utils -import Hledger.Data.Types -import Hledger.Data.Amount -import Hledger.Data.AccountName -import Hledger.Data.Posting -import Hledger.Data.Ledger -import Hledger.Cli.Options -import Prelude hiding (putStr) -import Hledger.Data.UTF8 (putStr) +import Data.List +import Data.Maybe +import Test.HUnit --- | A balance report is a chart of accounts with balances, and their grand total. -type BalanceReport = ([BalanceReportItem] -- line items, one per account - ,MixedAmount -- total balance of all accounts - ) +import Hledger +import Prelude hiding (putStr) +import Hledger.Utils.UTF8 (putStr) +import Hledger.Cli.Format +import qualified Hledger.Cli.Format as Format +import Hledger.Cli.Options --- | The data for a single balance report line item, representing one account. -type BalanceReportItem = (AccountName -- full account name - ,AccountName -- account name elided for display: the leaf name, - -- prefixed by any boring parents immediately above - ,Int -- account depth within this report, excludes boring parents - ,MixedAmount) -- account balance, includes subs unless --flat is present -- | Print a balance report. -balance :: [Opt] -> [String] -> Journal -> IO () -balance opts args j = do - t <- getCurrentLocalTime - putStr $ balanceReportAsText opts $ balanceReport opts (optsToFilterSpec opts args t) j +balance :: CliOpts -> Journal -> IO () +balance CliOpts{reportopts_=ropts} j = do + d <- getCurrentDay + let lines = case formatFromOpts ropts of + Left err -> [err] + Right _ -> accountsReportAsText ropts $ accountsReport ropts (optsToFilterSpec ropts d) j + putStr $ unlines lines -- | Render a balance report as plain text suitable for console output. -balanceReportAsText :: [Opt] -> BalanceReport -> String -balanceReportAsText opts (items,total) = - unlines $ - map (balanceReportItemAsText opts) items - ++ - if NoTotal `elem` opts - then [] - else ["--------------------" - ,padleft 20 $ showMixedAmountWithoutPrice total - ] - --- | Render one balance report line item as plain text. -balanceReportItemAsText :: [Opt] -> BalanceReportItem -> String -balanceReportItemAsText opts (a, adisplay, adepth, abal) = concatTopPadded [amt, " ", name] - where - amt = padleft 20 $ showMixedAmountWithoutPrice abal - name | Flat `elem` opts = accountNameDrop (dropFromOpts opts) a - | otherwise = depthspacer ++ adisplay - depthspacer = replicate (indentperlevel * adepth) ' ' - indentperlevel = 2 - --- | Get a balance report with the specified options for this journal. -balanceReport :: [Opt] -> FilterSpec -> Journal -> BalanceReport -balanceReport opts filterspec j = (items, total) +accountsReportAsText :: ReportOpts -> AccountsReport -> [String] +accountsReportAsText opts (items, total) = concat lines ++ t where - items = map mkitem interestingaccts - interestingaccts = filter (isInteresting opts l) acctnames - acctnames = sort $ tail $ flatten $ treemap aname accttree - accttree = ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) l - total = sum $ map abalance $ ledgerTopAccounts l - l = journalToLedger filterspec j - -- | Get data for one balance report line item. - mkitem :: AccountName -> BalanceReportItem - mkitem a = (a, adisplay, indent, abal) - where - adisplay | Flat `elem` opts = a - | otherwise = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a] - where ps = takeWhile boring parents where boring = not . (`elem` interestingparents) - indent | Flat `elem` opts = 0 - | otherwise = length interestingparents - interestingparents = filter (`elem` interestingaccts) parents - parents = parentAccountNames a - abal | Flat `elem` opts = exclusiveBalance acct - | otherwise = abalance acct - where acct = ledgerAccount l a + lines = case formatFromOpts opts of + Right f -> map (accountsReportItemAsText opts f) items + Left err -> [[err]] + t = if no_total_ opts + then [] + else ["--------------------" + -- TODO: This must use the format somehow + ,padleft 20 $ showMixedAmountWithoutPrice total + ] -exclusiveBalance :: Account -> MixedAmount -exclusiveBalance = sumPostings . apostings +{- +This implementation turned out to be a bit convoluted but implements the following algorithm for formatting: --- | Is the named account considered interesting for this ledger's balance report ? -isInteresting :: [Opt] -> Ledger -> AccountName -> Bool -isInteresting opts l a | Flat `elem` opts = isInterestingFlat opts l a - | otherwise = isInterestingIndented opts l a +- If there is a single amount, print it with the account name directly: +- Otherwise, only print the account name on the last line. -isInterestingFlat :: [Opt] -> Ledger -> AccountName -> Bool -isInterestingFlat opts l a = notempty || emptyflag + a USD 1 ; Account 'a' has a single amount + EUR -1 + b USD -1 ; Account 'b' has two amounts. The account name is printed on the last line. +-} +-- | Render one balance report line item as plain text. +accountsReportItemAsText :: ReportOpts -> [FormatString] -> AccountsReportItem -> [String] +accountsReportItemAsText opts format (_, accountName, depth, Mixed amounts) = + case amounts of + [] -> [] + [a] -> [formatAccountsReportItem opts (Just accountName) depth a format] + (as) -> multiline as where - acct = ledgerAccount l a - notempty = not $ isZeroMixedAmount $ exclusiveBalance acct - emptyflag = Empty `elem` opts + multiline :: [Amount] -> [String] + multiline [] = [] + multiline [a] = [formatAccountsReportItem opts (Just accountName) depth a format] + multiline (a:as) = (formatAccountsReportItem opts Nothing depth a format) : multiline as -isInterestingIndented :: [Opt] -> Ledger -> AccountName -> Bool -isInterestingIndented opts l a - | numinterestingsubs==1 && not atmaxdepth = notlikesub - | otherwise = notzero || emptyflag - where - atmaxdepth = isJust d && Just (accountNameLevel a) == d where d = depthFromOpts opts - emptyflag = Empty `elem` opts - acct = ledgerAccount l a - notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct - notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct - numinterestingsubs = length $ filter isInterestingTree subtrees - where - isInterestingTree = treeany (isInteresting opts l . aname) - subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a +formatAccountsReportItem :: ReportOpts -> Maybe AccountName -> Int -> Amount -> [FormatString] -> String +formatAccountsReportItem _ _ _ _ [] = "" +formatAccountsReportItem opts accountName depth amount (fmt:fmts) = + s ++ (formatAccountsReportItem opts accountName depth amount fmts) + where + s = case fmt of + FormatLiteral l -> l + FormatField ljust min max field -> formatField opts accountName depth amount ljust min max field + +formatField :: ReportOpts -> Maybe AccountName -> Int -> Amount -> Bool -> Maybe Int -> Maybe Int -> Field -> String +formatField opts accountName depth total ljust min max field = case field of + Format.Account -> formatValue ljust min max $ maybe "" (accountNameDrop (drop_ opts)) accountName + Format.DepthSpacer -> case min of + Just m -> formatValue ljust Nothing max $ replicate (depth * m) ' ' + Nothing -> formatValue ljust Nothing max $ replicate depth ' ' + Format.Total -> formatValue ljust min max $ showAmountWithoutPrice total + _ -> "" tests_Hledger_Cli_Balance = TestList [ diff --git a/Hledger/Cli/Convert.hs b/Hledger/Cli/Convert.hs --- a/Hledger/Cli/Convert.hs +++ b/Hledger/Cli/Convert.hs @@ -4,30 +4,27 @@ -} module Hledger.Cli.Convert where -import Hledger.Cli.Options (Opt(Debug), progname_cli) -import Hledger.Cli.Version (progversionstr) -import Hledger.Data.Types (Journal,AccountName,Transaction(..),Posting(..),PostingType(..)) -import Hledger.Data.Utils (strip, spacenonewline, restofline, parseWithCtx, assertParse, assertParseEqual, error') -import Hledger.Read.JournalReader (someamount,ledgeraccountname) -import Hledger.Data.Journal (nullctx) -import Hledger.Data.Amount (nullmixedamt, costOfMixedAmount) -import Safe (atDef, maximumDef) -import System.IO (stderr) -import Text.CSV (parseCSVFromFile, printCSV) -import Text.Printf (hPrintf) -import Text.RegexPR (matchRegexPR, gsubRegexPR) +import Control.Monad (when, guard, liftM) import Data.Maybe -import Hledger.Data.Dates (firstJust, showDate, parsedate) -import System.Locale (defaultTimeLocale) import Data.Time.Format (parseTime) -import Control.Monad (when, guard, liftM) -import Safe (readDef, readMay) +import Safe import System.Directory (doesFileExist) import System.Exit (exitFailure) import System.FilePath (takeBaseName, replaceExtension) -import Text.ParserCombinators.Parsec +import System.IO (stderr) +import System.Locale (defaultTimeLocale) import Test.HUnit +import Text.CSV (parseCSV, parseCSVFromFile, printCSV, CSV) +import Text.ParserCombinators.Parsec +import Text.Printf (hPrintf) +import Prelude hiding (getContents) +import Hledger.Utils.UTF8 (getContents) +import Hledger +import Hledger.Cli.Format +import qualified Hledger.Cli.Format as Format +import Hledger.Cli.Version +import Hledger.Cli.Options {- | A set of data definitions and account-matching patterns sufficient to @@ -38,11 +35,14 @@ dateFormat :: Maybe String, statusField :: Maybe FieldPosition, codeField :: Maybe FieldPosition, - descriptionField :: Maybe FieldPosition, + descriptionField :: [FormatString], amountField :: Maybe FieldPosition, + inField :: Maybe FieldPosition, + outField :: Maybe FieldPosition, currencyField :: Maybe FieldPosition, baseCurrency :: Maybe String, accountField :: Maybe FieldPosition, + account2Field :: Maybe FieldPosition, effectiveDateField :: Maybe FieldPosition, baseAccount :: AccountName, accountRules :: [AccountRule] @@ -53,11 +53,14 @@ dateFormat=Nothing, statusField=Nothing, codeField=Nothing, - descriptionField=Nothing, + descriptionField=[], amountField=Nothing, + inField=Nothing, + outField=Nothing, currencyField=Nothing, baseCurrency=Nothing, accountField=Nothing, + account2Field=Nothing, effectiveDateField=Nothing, baseAccount="unknown", accountRules=[] @@ -75,16 +78,19 @@ -- | Read the CSV file named as an argument and print equivalent journal transactions, -- using/creating a .rules file. -convert :: [Opt] -> [String] -> Journal -> IO () -convert opts args _ = do - when (null args) $ error' "please specify a csv data file." - let csvfile = head args - csvparse <- parseCSVFromFile csvfile +convert :: CliOpts -> IO () +convert opts = do + let csvfile = case headDef "" $ patterns_ $ reportopts_ opts of + "" -> "-" + s -> s + usingStdin = csvfile == "-" + rulesFileSpecified = isJust $ rules_file_ opts + rulesfile = rulesFileFor opts csvfile + when (usingStdin && (not rulesFileSpecified)) $ error' "please use --rules to specify a rules file when converting stdin" + csvparse <- parseCsv csvfile let records = case csvparse of Left e -> error' $ show e Right rs -> reverse $ filter (/= [""]) rs - let debug = Debug `elem` opts - rulesfile = rulesFileFor csvfile exists <- doesFileExist rulesfile if (not exists) then do hPrintf stderr "creating conversion rules file %s, edit this file for better results\n" rulesfile @@ -92,11 +98,13 @@ else hPrintf stderr "using conversion rules file %s\n" rulesfile rules <- liftM (either (error'.show) id) $ parseCsvRulesFile rulesfile - when debug $ hPrintf stderr "rules: %s\n" (show rules) + let invalid = validateRules rules + when (debug_ opts) $ hPrintf stderr "rules: %s\n" (show rules) + when (isJust invalid) $ error (fromJust invalid) let requiredfields = max 2 (maxFieldIndex rules + 1) badrecords = take 1 $ filter ((< requiredfields).length) records if null badrecords - then mapM_ (printTxn debug rules) records + then mapM_ (printTxn (debug_ opts) rules) records else do hPrintf stderr (unlines [ "Warning, at least one CSV record does not contain a field referenced by the" @@ -105,6 +113,12 @@ ]) (show $ head badrecords) exitFailure +parseCsv :: FilePath -> IO (Either ParseError CSV) +parseCsv path = + case path of + "-" -> liftM (parseCSV "(stdin)") getContents + p -> parseCSVFromFile p + -- | The highest (0-based) field index referenced in the field -- definitions, or -1 if no fields are defined. maxFieldIndex :: CsvRules -> Int @@ -112,19 +126,22 @@ dateField r ,statusField r ,codeField r - ,descriptionField r ,amountField r + ,inField r + ,outField r ,currencyField r ,accountField r + ,account2Field r ,effectiveDateField r ] -rulesFileFor :: FilePath -> FilePath -rulesFileFor csvfile = replaceExtension csvfile ".rules" +rulesFileFor :: CliOpts -> FilePath -> FilePath +rulesFileFor CliOpts{rules_file_=Just f} _ = f +rulesFileFor CliOpts{rules_file_=Nothing} csvfile = replaceExtension csvfile ".rules" initialRulesFileContent :: String initialRulesFileContent = - "# csv conversion rules file generated by "++(progversionstr progname_cli)++"\n" ++ + "# csv conversion rules file generated by "++(progversionstr progname)++"\n" ++ "# Add rules to this file for more accurate conversion, see\n"++ "# http://hledger.org/MANUAL.html#convert\n" ++ "\n" ++ @@ -146,6 +163,19 @@ "(TO|FROM) SAVINGS\n" ++ "assets:bank:savings\n" +validateRules :: CsvRules -> Maybe String +validateRules rules = let + hasAmount = isJust $ amountField rules + hasIn = isJust $ inField rules + hasOut = isJust $ outField rules + in case (hasAmount, hasIn, hasOut) of + (True, True, _) -> Just "Don't specify in-field when specifying amount-field" + (True, _, True) -> Just "Don't specify out-field when specifying amount-field" + (_, False, True) -> Just "Please specify in-field when specifying out-field" + (_, True, False) -> Just "Please specify out-field when specifying in-field" + (False, False, False) -> Just "Please specify either amount-field, or in-field and out-field" + _ -> Nothing + -- rules file parser parseCsvRulesFile :: FilePath -> IO (Either ParseError CsvRules) @@ -166,9 +196,6 @@ eof return r{accountRules=ars} --- | Real independent parser choice, even when alternative matches share a prefix. -choice' parsers = choice $ map try (init parsers) ++ [last parsers] - definitions :: GenParser Char CsvRules () definitions = do choice' [ @@ -178,8 +205,11 @@ ,codefield ,descriptionfield ,amountfield + ,infield + ,outfield ,currencyfield ,accountfield + ,account2field ,effectivedatefield ,basecurrency ,baseaccount @@ -191,80 +221,96 @@ string "date-field" many1 spacenonewline v <- restofline - r <- getState - setState r{dateField=readMay v} + updateState (\r -> r{dateField=readMay v}) effectivedatefield = do string "effective-date-field" many1 spacenonewline v <- restofline - r <- getState - setState r{effectiveDateField=readMay v} + updateState (\r -> r{effectiveDateField=readMay v}) dateformat = do string "date-format" many1 spacenonewline v <- restofline - r <- getState - setState r{dateFormat=Just v} + updateState (\r -> r{dateFormat=Just v}) codefield = do string "code-field" many1 spacenonewline v <- restofline - r <- getState - setState r{codeField=readMay v} + updateState (\r -> r{codeField=readMay v}) statusfield = do string "status-field" many1 spacenonewline v <- restofline - r <- getState - setState r{statusField=readMay v} + updateState (\r -> r{statusField=readMay v}) +descriptionFieldValue :: GenParser Char st [FormatString] +descriptionFieldValue = do +-- try (fieldNo <* spacenonewline) + try fieldNo + <|> formatStrings + where + fieldNo = many1 digit >>= \x -> return [FormatField False Nothing Nothing $ FieldNo $ read x] + descriptionfield = do string "description-field" many1 spacenonewline - v <- restofline - r <- getState - setState r{descriptionField=readMay v} + formatS <- descriptionFieldValue + restofline + updateState (\x -> x{descriptionField=formatS}) amountfield = do string "amount-field" many1 spacenonewline v <- restofline - r <- getState - setState r{amountField=readMay v} + x <- updateState (\r -> r{amountField=readMay v}) + return x +infield = do + string "in-field" + many1 spacenonewline + v <- restofline + updateState (\r -> r{inField=readMay v}) + +outfield = do + string "out-field" + many1 spacenonewline + v <- restofline + updateState (\r -> r{outField=readMay v}) + currencyfield = do string "currency-field" many1 spacenonewline v <- restofline - r <- getState - setState r{currencyField=readMay v} + updateState (\r -> r{currencyField=readMay v}) accountfield = do string "account-field" many1 spacenonewline v <- restofline - r <- getState - setState r{accountField=readMay v} + updateState (\r -> r{accountField=readMay v}) +account2field = do + string "account2-field" + many1 spacenonewline + v <- restofline + updateState (\r -> r{account2Field=readMay v}) basecurrency = do string "currency" many1 spacenonewline v <- restofline - r <- getState - setState r{baseCurrency=Just v} + updateState (\r -> r{baseCurrency=Just v}) baseaccount = do string "base-account" many1 spacenonewline v <- ledgeraccountname optional newline - r <- getState - setState r{baseAccount=v} + updateState (\r -> r{baseAccount=v}) accountrule :: GenParser Char CsvRules AccountRule accountrule = do @@ -277,7 +323,7 @@ return (pats',acct) "account rule" -blanklines = many1 blankline >> return () +blanklines = many1 blankline blankline = many spacenonewline >> newline >> return () "blank line" @@ -300,7 +346,25 @@ putStr $ show $ transactionFromCsvRecord rules rec -- csv record conversion +formatD :: CsvRecord -> Bool -> Maybe Int -> Maybe Int -> Field -> String +formatD record leftJustified min max f = case f of + FieldNo n -> maybe "" show $ atMay record n + -- Some of these might in theory in read from fields + Format.Account -> "" + DepthSpacer -> "" + Total -> "" + DefaultDate -> "" + Description -> "" + where + show = formatValue leftJustified min max +formatDescription :: CsvRecord -> [FormatString] -> String +formatDescription _ [] = "" +formatDescription record (f:fs) = s ++ (formatDescription record fs) + where s = case f of + FormatLiteral l -> l + FormatField leftJustified min max field -> formatD record leftJustified min max field + transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction transactionFromCsvRecord rules fields = let @@ -309,11 +373,11 @@ return $ parsedate $ normaliseDate (dateFormat rules) $ (atDef "" fields) idx status = maybe False (null . strip . (atDef "" fields)) (statusField rules) code = maybe "" (atDef "" fields) (codeField rules) - desc = maybe "" (atDef "" fields) (descriptionField rules) + desc = formatDescription fields (descriptionField rules) comment = "" precomment = "" baseacc = maybe (baseAccount rules) (atDef "" fields) (accountField rules) - amountstr = maybe "" (atDef "" fields) (amountField rules) + amountstr = getAmount rules fields amountstr' = strnegate amountstr where strnegate ('-':s) = s strnegate s = '-':s currency = maybe (fromMaybe "" $ baseCurrency rules) (atDef "" fields) (currencyField rules) @@ -325,7 +389,8 @@ baseamount = costOfMixedAmount amount unknownacct | (readDef 0 amountstr' :: Double) < 0 = "income:unknown" | otherwise = "expenses:unknown" - (acct,newdesc) = identify (accountRules rules) unknownacct desc + (acct',newdesc) = identify (accountRules rules) unknownacct desc + acct = maybe acct' (atDef "" fields) (account2Field rules) t = Transaction { tdate=date, teffectivedate=effectivedate, @@ -382,16 +447,50 @@ | otherwise = (acct,newdesc) where matchingrules = filter ismatch rules :: [AccountRule] - where ismatch = any (isJust . flip matchRegexPR (caseinsensitive desc) . fst) . fst + where ismatch = any ((`regexMatchesCI` desc) . fst) . fst (prs,acct) = head matchingrules - p_ms_r = filter (\(_,m,_) -> isJust m) $ map (\(p,r) -> (p, matchRegexPR (caseinsensitive p) desc, r)) prs + p_ms_r = filter (\(_,m,_) -> m) $ map (\(p,r) -> (p, p `regexMatchesCI` desc, r)) prs (p,_,r) = head p_ms_r - newdesc = case r of Just rpat -> gsubRegexPR (caseinsensitive p) rpat desc + newdesc = case r of Just repl -> regexReplaceCI p repl desc Nothing -> desc caseinsensitive = ("(?i)"++) -tests_Hledger_Cli_Convert = TestList [ +getAmount :: CsvRules -> CsvRecord -> String +getAmount rules fields = case amountField rules of + Just f -> maybe "" (atDef "" fields) $ Just f + Nothing -> + case (c, d) of + (x, "") -> x + ("", x) -> "-"++x + _ -> "" + where + c = maybe "" (atDef "" fields) (inField rules) + d = maybe "" (atDef "" fields) (outField rules) + +tests_Hledger_Cli_Convert = TestList (test_parser ++ test_description_parsing) + +test_description_parsing = [ + "description-field 1" ~: assertParseDescription "description-field 1\n" [FormatField False Nothing Nothing (FieldNo 1)] + , "description-field 1 " ~: assertParseDescription "description-field 1 \n" [FormatField False Nothing Nothing (FieldNo 1)] + , "description-field %(1)" ~: assertParseDescription "description-field %(1)\n" [FormatField False Nothing Nothing (FieldNo 1)] + , "description-field %(1)/$(2)" ~: assertParseDescription "description-field %(1)/%(2)\n" [ + FormatField False Nothing Nothing (FieldNo 1) + , FormatLiteral "/" + , FormatField False Nothing Nothing (FieldNo 2) + ] + ] + where + assertParseDescription string expected = do assertParseEqual (parseDescription string) (nullrules {descriptionField = expected}) + parseDescription :: String -> Either ParseError CsvRules + parseDescription x = runParser descriptionfieldWrapper nullrules "(unknown)" x + descriptionfieldWrapper :: GenParser Char CsvRules CsvRules + descriptionfieldWrapper = do + descriptionfield + r <- getState + return r + +test_parser = [ "convert rules parsing: empty file" ~: do -- let assertMixedAmountParse parseresult mixedamount = diff --git a/Hledger/Cli/Format.hs b/Hledger/Cli/Format.hs new file mode 100644 --- /dev/null +++ b/Hledger/Cli/Format.hs @@ -0,0 +1,133 @@ +module Hledger.Cli.Format ( + parseFormatString + , formatStrings + , formatValue + , FormatString(..) + , Field(..) + , tests + ) where + +import Numeric +import Data.Char (isPrint) +import Data.Maybe +import Test.HUnit +import Text.ParserCombinators.Parsec +import Text.Printf + + +data Field = + Account + | DefaultDate + | Description + | Total + | DepthSpacer + | FieldNo Int + deriving (Show, Eq) + +data FormatString = + FormatLiteral String + | FormatField Bool -- Left justified ? + (Maybe Int) -- Min width + (Maybe Int) -- Max width + Field -- Field + deriving (Show, Eq) + +formatValue :: Bool -> Maybe Int -> Maybe Int -> String -> String +formatValue leftJustified min max value = printf formatS value + where + l = if leftJustified then "-" else "" + min' = maybe "" show min + max' = maybe "" (\i -> "." ++ (show i)) max + formatS = "%" ++ l ++ min' ++ max' ++ "s" + +parseFormatString :: String -> Either String [FormatString] +parseFormatString input = case (runParser formatStrings () "(unknown)") input of + Left y -> Left $ show y + Right x -> Right x + +{- +Parsers +-} + +field :: GenParser Char st Field +field = do + try (string "account" >> return Account) + <|> try (string "depth_spacer" >> return DepthSpacer) + <|> try (string "date" >> return Description) + <|> try (string "description" >> return Description) + <|> try (string "total" >> return Total) + <|> try (many1 digit >>= (\s -> return $ FieldNo $ read s)) + +formatField :: GenParser Char st FormatString +formatField = do + char '%' + leftJustified <- optionMaybe (char '-') + minWidth <- optionMaybe (many1 $ digit) + maxWidth <- optionMaybe (do char '.'; many1 $ digit) -- TODO: Can this be (char '1') *> (many1 digit) + char '(' + f <- field + char ')' + return $ FormatField (isJust leftJustified) (parseDec minWidth) (parseDec maxWidth) f + where + parseDec s = case s of + Just text -> Just m where ((m,_):_) = readDec text + _ -> Nothing + +formatLiteral :: GenParser Char st FormatString +formatLiteral = do + s <- many1 c + return $ FormatLiteral s + where + isPrintableButNotPercentage x = isPrint x && (not $ x == '%') + c = (satisfy isPrintableButNotPercentage "printable character") + <|> try (string "%%" >> return '%') + +formatString :: GenParser Char st FormatString +formatString = + formatField + <|> formatLiteral + +formatStrings :: GenParser Char st [FormatString] +formatStrings = many formatString + +testFormat :: FormatString -> String -> String -> Assertion +testFormat fs value expected = assertEqual name expected actual + where + (name, actual) = case fs of + FormatLiteral l -> ("literal", formatValue False Nothing Nothing l) + FormatField leftJustify min max _ -> ("field", formatValue leftJustify min max value) + +testParser :: String -> [FormatString] -> Assertion +testParser s expected = case (parseFormatString s) of + Left error -> assertFailure $ show error + Right actual -> assertEqual ("Input: " ++ s) expected actual + +tests = test [ formattingTests ++ parserTests ] + +formattingTests = [ + testFormat (FormatLiteral " ") "" " " + , testFormat (FormatField False Nothing Nothing Description) "description" "description" + , testFormat (FormatField False (Just 20) Nothing Description) "description" " description" + , testFormat (FormatField False Nothing (Just 20) Description) "description" "description" + , testFormat (FormatField True Nothing (Just 20) Description) "description" "description" + , testFormat (FormatField True (Just 20) Nothing Description) "description" "description " + , testFormat (FormatField True (Just 20) (Just 20) Description) "description" "description " + , testFormat (FormatField True Nothing (Just 3) Description) "description" "des" + ] + +parserTests = [ + testParser "" [] + , testParser "D" [FormatLiteral "D"] + , testParser "%(date)" [FormatField False Nothing Nothing Description] + , testParser "%(total)" [FormatField False Nothing Nothing Total] + , testParser "Hello %(date)!" [FormatLiteral "Hello ", FormatField False Nothing Nothing Description, FormatLiteral "!"] + , testParser "%-(date)" [FormatField True Nothing Nothing Description] + , testParser "%20(date)" [FormatField False (Just 20) Nothing Description] + , testParser "%.10(date)" [FormatField False Nothing (Just 10) Description] + , testParser "%20.10(date)" [FormatField False (Just 20) (Just 10) Description] + , testParser "%20(account) %.10(total)\n" [ FormatField False (Just 20) Nothing Account + , FormatLiteral " " + , FormatField False Nothing (Just 10) Total + , FormatLiteral "\n" + ] + ] diff --git a/Hledger/Cli/Histogram.hs b/Hledger/Cli/Histogram.hs --- a/Hledger/Cli/Histogram.hs +++ b/Hledger/Cli/Histogram.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-| Print a histogram report. @@ -7,22 +6,28 @@ module Hledger.Cli.Histogram where -import Hledger.Data +import Data.List +import Data.Maybe +import Data.Ord +import Text.Printf + import Hledger.Cli.Options +import Hledger.Data +import Hledger.Reports import Prelude hiding (putStr) -import Hledger.Data.UTF8 (putStr) +import Hledger.Utils.UTF8 (putStr) barchar = '*' -- | Print a histogram of some statistic per reporting interval, such as -- number of postings per day. -histogram :: [Opt] -> [String] -> Journal -> IO () -histogram opts args j = do - t <- getCurrentLocalTime - putStr $ showHistogram opts (optsToFilterSpec opts args t) j +histogram :: CliOpts -> Journal -> IO () +histogram CliOpts{reportopts_=reportopts_} j = do + d <- getCurrentDay + putStr $ showHistogram reportopts_ (optsToFilterSpec reportopts_ d) j -showHistogram :: [Opt] -> FilterSpec -> Journal -> String +showHistogram :: ReportOpts -> FilterSpec -> Journal -> String showHistogram opts filterspec j = concatMap (printDayWith countBar) spanps where i = intervalFromOpts opts @@ -35,13 +40,13 @@ -- should count transactions, not postings ? ps = sortBy (comparing postingDate) $ filterempties $ filter matchapats $ filterdepth $ journalPostings j filterempties - | Empty `elem` opts = id + | empty_ opts = id | otherwise = filter (not . isZeroMixedAmount . pamount) matchapats = matchpats apats . paccount apats = acctpats filterspec filterdepth | interval == NoInterval = filter (\p -> accountNameLevel (paccount p) <= depth) | otherwise = id - depth = fromMaybe 99999 $ depthFromOpts opts + depth = fromMaybe 99999 $ depth_ opts printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts) diff --git a/Hledger/Cli/Main.hs b/Hledger/Cli/Main.hs --- a/Hledger/Cli/Main.hs +++ b/Hledger/Cli/Main.hs @@ -39,30 +39,71 @@ module Hledger.Cli.Main where -import Prelude hiding (putStr, putStrLn) -import Hledger.Data.UTF8 (putStr, putStrLn) -import Hledger.Data -import Hledger.Cli +import Control.Monad +import Data.List +import Safe +import System.Environment +import System.Exit +import System.Process +import Text.Printf + +import Hledger.Cli.Add +import Hledger.Cli.Balance +import Hledger.Cli.Convert +import Hledger.Cli.Histogram +import Hledger.Cli.Print +import Hledger.Cli.Register +import Hledger.Cli.Stats +import Hledger.Cli.Options import Hledger.Cli.Tests -import Hledger.Cli.Version (progversionstr, binaryfilename) +import Hledger.Cli.Utils +import Hledger.Cli.Version +import Hledger.Utils main :: IO () main = do - (opts, args) <- parseArgumentsWith options_cli - run opts args + args <- getArgs + addons <- getHledgerAddonCommands + opts <- getHledgerCliOpts addons + when (debug_ opts) $ printf "%s\n" progversion >> printf "opts: %s\n" (show opts) + run' opts addons args where - run opts _ - | Help `elem` opts = putStr usage_cli - | Version `elem` opts = putStrLn $ progversionstr progname_cli - | BinaryFilename `elem` opts = putStrLn $ binaryfilename progname_cli - run _ [] = argsError "a command is required." - run opts (cmd:args) - | cmd `isPrefixOf` "balance" = withJournalDo opts args cmd balance - | cmd `isPrefixOf` "convert" = withJournalDo opts args cmd convert - | cmd `isPrefixOf` "print" = withJournalDo opts args cmd print' - | cmd `isPrefixOf` "register" = withJournalDo opts args cmd register - | cmd `isPrefixOf` "histogram" = withJournalDo opts args cmd histogram - | cmd `isPrefixOf` "add" = withJournalDo opts args cmd add - | cmd `isPrefixOf` "stats" = withJournalDo opts args cmd stats - | cmd `isPrefixOf` "test" = runtests opts args >> return () - | otherwise = argsError $ "command "++cmd++" is unrecognized." + run' opts@CliOpts{command_=cmd} addons args + | "version" `in_` (rawopts_ opts) = putStrLn progversion + | "binary-filename" `in_` (rawopts_ opts) = putStrLn $ binaryfilename progname + | null cmd = putStr $ showModeHelp mainmode' + | cmd `isPrefixOf` "add" = showModeHelpOr addmode $ withJournalDo opts add + | cmd `isPrefixOf` "convert" = showModeHelpOr convertmode $ convert opts + | cmd `isPrefixOf` "test" = showModeHelpOr testmode $ runtests opts + | any (cmd `isPrefixOf`) ["accounts","balance"] = showModeHelpOr accountsmode $ withJournalDo opts balance + | any (cmd `isPrefixOf`) ["entries","print"] = showModeHelpOr entriesmode $ withJournalDo opts print' + | any (cmd `isPrefixOf`) ["postings","register"] = showModeHelpOr postingsmode $ withJournalDo opts register + | any (cmd `isPrefixOf`) ["activity","histogram"] = showModeHelpOr activitymode $ withJournalDo opts histogram + | cmd `isPrefixOf` "stats" = showModeHelpOr statsmode $ withJournalDo opts stats + | not (null matchedaddon) = system shellcmd >>= exitWith + | otherwise = optserror ("command "++cmd++" is not recognized") >> exitFailure + where + mainmode' = mainmode addons + showModeHelpOr mode f | "help" `in_` (rawopts_ opts) = putStr $ showModeHelp mode + | otherwise = f + matchedaddon = headDef "" $ filter (cmd `isPrefixOf`) addons + shellcmd = printf "%s-%s %s" progname matchedaddon (unwords' args) + +{- tests: + +hledger -> main help +hledger --help -> main help +hledger --help command -> command help +hledger command --help -> command help +hledger badcommand -> unrecognized command, try --help (non-zero exit) +hledger badcommand --help -> main help +hledger --help badcommand -> main help +hledger --mainflag command -> works +hledger command --mainflag -> works +hledger command --commandflag -> works +hledger command --mainflag --commandflag -> works +XX hledger --mainflag command --commandflag -> works +XX hledger --commandflag command -> works +XX hledger --commandflag command --mainflag -> works + +-} diff --git a/Hledger/Cli/Options.hs b/Hledger/Cli/Options.hs --- a/Hledger/Cli/Options.hs +++ b/Hledger/Cli/Options.hs @@ -1,320 +1,453 @@ {-| -Command-line options for the application. + +Command-line options for the hledger program, and option-parsing utilities. + -} module Hledger.Cli.Options where -import System.Console.GetOpt +import Data.List +import Data.List.Split +import Data.Maybe +import Data.Time.Calendar +import Safe +import System.Console.CmdArgs +import System.Console.CmdArgs.Explicit +import System.Console.CmdArgs.Text +import System.Directory import System.Environment +import Test.HUnit +import Text.Parsec +import Text.Printf -import Hledger.Data.Utils -import Hledger.Data.Types -import Hledger.Data.Dates -import Hledger.Read (myJournalPath, myTimelogPath) +import Hledger +import Hledger.Cli.Format as Format +import Hledger.Cli.Version -progname_cli = "hledger" +progname = "hledger" +progversion = progversionstr progname --- | The program name which, if we are invoked as (via symlink or --- renaming), causes us to default to reading the user's time log instead --- of their journal. -progname_cli_time = "hours" +-- 1. cmdargs mode and flag definitions, for the main and subcommand modes. +-- Flag values are parsed initially to simple RawOpts to permit reuse. -usage_preamble_cli = - "Usage: hledger [OPTIONS] COMMAND [PATTERNS]\n" ++ - " hledger [OPTIONS] convert CSVFILE\n" ++ - "\n" ++ - "Reads your ~/.journal file, or another specified by $LEDGER or -f, and\n" ++ - "runs the specified command (may be abbreviated):\n" ++ - "\n" ++ - " add - prompt for new transactions and add them to the journal\n" ++ - " balance - show accounts, with balances\n" ++ - " convert - show the specified CSV file as a hledger journal\n" ++ - " histogram - show a barchart of transactions per day or other interval\n" ++ - " print - show transactions in journal format\n" ++ - " register - show transactions as a register with running balance\n" ++ - " stats - show various statistics for a journal\n" ++ - " test - run self-tests\n" ++ - "\n" +type RawOpts = [(String,String)] -usage_options_cli = usageInfo "hledger options:" options_cli +defmode :: Mode RawOpts +defmode = Mode { + modeNames = [] + ,modeHelp = "" + ,modeHelpSuffix = [] + ,modeValue = [] + ,modeCheck = Right + ,modeReform = const Nothing + ,modeGroupFlags = toGroup [] + ,modeArgs = ([], Nothing) + ,modeGroupModes = toGroup [] + } -usage_postscript_cli = - "\n" ++ - "DATES can be y/m/d or smart dates like \"last month\". PATTERNS are regular\n" ++ - "expressions which filter by account name. Prefix a pattern with desc: to\n" ++ - "filter by transaction description instead, prefix with not: to negate it.\n" ++ - "When using both, not: comes last.\n" +mainmode addons = defmode { + modeNames = [progname] + ,modeHelp = "run the specified hledger command. hledger COMMAND --help for more detail. \nIn general, COMMAND should precede OPTIONS." + ,modeHelpSuffix = [""] + ,modeGroupFlags = Group { + groupUnnamed = helpflags + ,groupHidden = [flagNone ["binary-filename"] (setboolopt "binary-filename") "show the download filename for this executable, and exit"] + ,groupNamed = [] + } + ,modeArgs = ([], Just mainargsflag) + ,modeGroupModes = Group { + groupUnnamed = [ + ] + ,groupHidden = [ + ] + ,groupNamed = [ + ("Misc commands", [ + addmode + ,convertmode + ,testmode + ]) + ,("\nReport commands", [ + accountsmode + ,entriesmode + ,postingsmode + -- ,transactionsmode + ,activitymode + ,statsmode + ]) + ] + ++ case addons of [] -> [] + cs -> [("\nAdd-on commands found", map addonmode cs)] + } + } -usage_cli = concat [ - usage_preamble_cli - ,usage_options_cli - ,usage_postscript_cli - ] +addonmode name = defmode { + modeNames = [name] + ,modeHelp = printf "[-- OPTIONS] run the %s-%s program" progname name + ,modeValue=[("command",name)] + ,modeGroupFlags = Group { + groupUnnamed = [] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags1)] + } + ,modeArgs = ([], Just addonargsflag) + } --- | Command-line options we accept. -options_cli :: [OptDescr Opt] -options_cli = [ - Option "f" ["file"] (ReqArg File "FILE") "use a different journal/timelog file; - means stdin" - ,Option "" ["no-new-accounts"] (NoArg NoNewAccts) "don't allow to create new accounts" - ,Option "b" ["begin"] (ReqArg Begin "DATE") "report on transactions on or after this date" - ,Option "e" ["end"] (ReqArg End "DATE") "report on transactions before this date" - ,Option "p" ["period"] (ReqArg Period "EXPR") ("report on transactions during the specified period\n" ++ - "and/or with the specified reporting interval\n") - ,Option "C" ["cleared"] (NoArg Cleared) "report only on cleared transactions" - ,Option "U" ["uncleared"] (NoArg UnCleared) "report only on uncleared transactions" - ,Option "B" ["cost","basis"] (NoArg CostBasis) "report cost of commodities" - ,Option "" ["depth"] (ReqArg Depth "N") "hide accounts/transactions deeper than this" - ,Option "d" ["display"] (ReqArg Display "EXPR") ("show only transactions matching EXPR (where\n" ++ - "EXPR is 'dOP[DATE]' and OP is <, <=, =, >=, >)") - ,Option "" ["effective"] (NoArg Effective) "use transactions' effective dates, if any" - ,Option "E" ["empty"] (NoArg Empty) "show empty/zero things which are normally elided" - ,Option "R" ["real"] (NoArg Real) "report only on real (non-virtual) transactions" - ,Option "" ["flat"] (NoArg Flat) "balance: show full account names, unindented" - ,Option "" ["drop"] (ReqArg Drop "N") "balance: with --flat, elide first N account name components" - ,Option "" ["no-total"] (NoArg NoTotal) "balance: hide the final total" - ,Option "D" ["daily"] (NoArg DailyOpt) "register, stats: report by day" - ,Option "W" ["weekly"] (NoArg WeeklyOpt) "register, stats: report by week" - ,Option "M" ["monthly"] (NoArg MonthlyOpt) "register, stats: report by month" - ,Option "Q" ["quarterly"] (NoArg QuarterlyOpt) "register, stats: report by quarter" - ,Option "Y" ["yearly"] (NoArg YearlyOpt) "register, stats: report by year" - ,Option "v" ["verbose"] (NoArg Verbose) "show more verbose output" - ,Option "" ["debug"] (NoArg Debug) "show extra debug output; implies verbose" - ,Option "" ["binary-filename"] (NoArg BinaryFilename) "show the download filename for this hledger build" - ,Option "V" ["version"] (NoArg Version) "show version information" - ,Option "h" ["help"] (NoArg Help) "show command-line usage" +help_postscript = [ + -- "DATES can be Y/M/D or smart dates like \"last month\"." + -- ,"PATTERNS are regular" + -- ,"expressions which filter by account name. Prefix a pattern with desc: to" + -- ,"filter by transaction description instead, prefix with not: to negate it." + -- ,"When using both, not: comes last." ] --- | An option value from a command-line flag. -data Opt = - File {value::String} - | NoNewAccts - | Begin {value::String} - | End {value::String} - | Period {value::String} - | Cleared - | UnCleared - | CostBasis - | Depth {value::String} - | Display {value::String} - | Effective - | Empty - | Real - | Flat - | Drop {value::String} - | NoTotal - | SubTotal - | DailyOpt - | WeeklyOpt - | MonthlyOpt - | QuarterlyOpt - | YearlyOpt - | Help - | Verbose - | Version - | BinaryFilename - | Debug - -- XXX add-on options, must be defined here for now - -- vty - | DebugVty - -- web - | BaseUrl {value::String} - | Port {value::String} - -- chart - | ChartOutput {value::String} - | ChartItems {value::String} - | ChartSize {value::String} - deriving (Show,Eq) +generalflagstitle = "\nGeneral flags" +generalflags1 = fileflags ++ reportflags ++ helpflags +generalflags2 = fileflags ++ helpflags +generalflags3 = helpflags --- these make me nervous -optsWithConstructor f opts = concatMap get opts - where get o = [o | f v == o] where v = value o +fileflags = [ + flagReq ["file","f"] (\s opts -> Right $ setopt "file" s opts) "FILE" "use a different journal file; - means stdin" + ,flagReq ["alias"] (\s opts -> Right $ setopt "alias" s opts) "ACCT=ALIAS" "display ACCT's name as ALIAS in reports" + ] -optsWithConstructors fs opts = concatMap get opts - where get o = [o | any (== o) fs] +reportflags = [ + flagReq ["begin","b"] (\s opts -> Right $ setopt "begin" s opts) "DATE" "report on transactions on or after this date" + ,flagReq ["end","e"] (\s opts -> Right $ setopt "end" s opts) "DATE" "report on transactions before this date" + ,flagReq ["period","p"] (\s opts -> Right $ setopt "period" s opts) "PERIODEXP" "report on transactions during the specified period and/or with the specified reporting interval" + ,flagNone ["daily","D"] (\opts -> setboolopt "daily" opts) "report by day" + ,flagNone ["weekly","W"] (\opts -> setboolopt "weekly" opts) "report by week" + ,flagNone ["monthly","M"] (\opts -> setboolopt "monthly" opts) "report by month" + ,flagNone ["quarterly","Q"] (\opts -> setboolopt "quarterly" opts) "report by quarter" + ,flagNone ["yearly","Y"] (\opts -> setboolopt "yearly" opts) "report by year" + ,flagNone ["cleared","C"] (\opts -> setboolopt "cleared" opts) "report only on cleared transactions" + ,flagNone ["uncleared","U"] (\opts -> setboolopt "uncleared" opts) "report only on uncleared transactions" + ,flagNone ["cost","B"] (\opts -> setboolopt "cost" opts) "report cost of commodities" + ,flagReq ["depth"] (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/transactions deeper than this" + ,flagReq ["display","d"] (\s opts -> Right $ setopt "display" s opts) "DISPLAYEXP" "show only transactions matching the expression, which is 'dOP[DATE]' where OP is <, <=, =, >=, >" + ,flagNone ["effective"] (\opts -> setboolopt "effective" opts) "use transactions' effective dates, if any" + ,flagNone ["empty","E"] (\opts -> setboolopt "empty" opts) "show empty/zero things which are normally elided" + ,flagNone ["real","R"] (\opts -> setboolopt "real" opts) "report only on real (non-virtual) transactions" + ] -optValuesForConstructor f opts = concatMap get opts - where get o = [v | f v == o] where v = value o +helpflags = [ + flagHelpSimple (setboolopt "help") + ,flagNone ["debug"] (setboolopt "debug") "Show extra debug output" + ,flagVersion (setboolopt "version") + ] -optValuesForConstructors fs opts = concatMap get opts - where get o = [v | any (\f -> f v == o) fs] where v = value o +mainargsflag = flagArg f "" + where f s opts = let as = words' s + cmd = headDef "" as + args = drop (length cmd + 1) s + in Right $ setopt "command" cmd $ setopt "args" args opts --- | Parse the command-line arguments into options and arguments using the --- specified option descriptors. Any smart dates in the options are --- converted to explicit YYYY/MM/DD format based on the current time. If --- parsing fails, raise an error, displaying the problem along with the --- provided usage string. -parseArgumentsWith :: [OptDescr Opt] -> IO ([Opt], [String]) -parseArgumentsWith options = do - rawargs <- map fromPlatformString `fmap` getArgs - let (opts,args,errs) = getOpt Permute options rawargs - opts' <- fixOptDates opts - let opts'' = if Debug `elem` opts' then Verbose:opts' else opts' - if null errs - then return (opts'',args) - else argsError (concat errs) >> return ([],[]) +commandargsflag = flagArg (\s opts -> Right $ setopt "args" s opts) "[PATTERNS]" -argsError :: String -> IO () -argsError = ioError . userError' . (++ " Run with --help to see usage.") +addonargsflag = flagArg (\s opts -> Right $ setopt "args" s opts) "[ARGS]" --- | Convert any fuzzy dates within these option values to explicit ones, --- based on today's date. -fixOptDates :: [Opt] -> IO [Opt] -fixOptDates opts = do +commandmode names = defmode {modeNames=names, modeValue=[("command",headDef "" names)]} + +addmode = (commandmode ["add"]) { + modeHelp = "prompt for new transactions and append them to the journal" + ,modeHelpSuffix = ["Defaults come from previous similar transactions; use query patterns to restrict these."] + ,modeArgs = ([], Just commandargsflag) + ,modeGroupFlags = Group { + groupUnnamed = [ + flagNone ["no-new-accounts"] (\opts -> setboolopt "no-new-accounts" opts) "don't allow creating new accounts" + ] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags2)] + } + } + +convertmode = (commandmode ["convert"]) { + modeValue = [("command","convert")] + ,modeHelp = "show the specified CSV file as hledger journal entries" + ,modeArgs = ([], Just $ flagArg (\s opts -> Right $ setopt "args" s opts) "[CSVFILE]") + ,modeGroupFlags = Group { + groupUnnamed = [ + flagReq ["rules-file"] (\s opts -> Right $ setopt "rules-file" s opts) "FILE" "rules file to use (default: CSVFILE.rules)" + ] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags3)] + } + } + +testmode = (commandmode ["test"]) { + modeHelp = "run self-tests, or just the ones matching REGEXPS" + ,modeArgs = ([], Just $ flagArg (\s opts -> Right $ setopt "args" s opts) "[REGEXPS]") + ,modeGroupFlags = Group { + groupUnnamed = [] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags3)] + } + } + +accountsmode = (commandmode ["balance","accounts"]) { + modeHelp = "(or accounts) show matched accounts and their balances" + ,modeArgs = ([], Just commandargsflag) + ,modeGroupFlags = Group { + groupUnnamed = [ + flagNone ["flat"] (\opts -> setboolopt "flat" opts) "show full account names, unindented" + ,flagReq ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "with --flat, omit this many leading account name components" + ,flagReq ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "use this custom line format" + ,flagNone ["no-elide"] (\opts -> setboolopt "no-elide" opts) "no eliding at all, stronger than --empty" + ,flagNone ["no-total"] (\opts -> setboolopt "no-total" opts) "don't show the final total" + ] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags1)] + } + } + +entriesmode = (commandmode ["print","entries"]) { + modeHelp = "(or entries) show matched journal entries" + ,modeArgs = ([], Just commandargsflag) + ,modeGroupFlags = Group { + groupUnnamed = [] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags1)] + } + } + +postingsmode = (commandmode ["register","postings"]) { + modeHelp = "(or postings) show matched postings and running total" + ,modeArgs = ([], Just commandargsflag) + ,modeGroupFlags = Group { + groupUnnamed = [] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags1)] + } + } + +transactionsmode = (commandmode ["transactions"]) { + modeHelp = "show matched transactions and balance in some account(s)" + ,modeArgs = ([], Just commandargsflag) + ,modeGroupFlags = Group { + groupUnnamed = [] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags1)] + } + } + +activitymode = (commandmode ["activity","histogram"]) { + modeHelp = "show a barchart of transactions per interval" + ,modeHelpSuffix = ["The default interval is daily."] + ,modeArgs = ([], Just commandargsflag) + ,modeGroupFlags = Group { + groupUnnamed = [] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags1)] + } + } + +statsmode = (commandmode ["stats"]) { + modeHelp = "show quick statistics for a journal (or part of it)" + ,modeArgs = ([], Just commandargsflag) + ,modeGroupFlags = Group { + groupUnnamed = [] + ,groupHidden = [] + ,groupNamed = [(generalflagstitle, generalflags1)] + } + } + +-- 2. ADT holding options used in this package and above, parsed from RawOpts. +-- This represents the command-line options that were provided, with all +-- parsing completed, but before adding defaults or derived values (XXX add) + +-- cli options, used in hledger and above +data CliOpts = CliOpts { + rawopts_ :: RawOpts + ,command_ :: String + ,file_ :: Maybe FilePath + ,alias_ :: [String] + ,debug_ :: Bool + ,no_new_accounts_ :: Bool -- add + ,rules_file_ :: Maybe FilePath -- convert + ,reportopts_ :: ReportOpts + } deriving (Show) + +defcliopts = CliOpts + def + def + def + def + def + def + def + def + +instance Default CliOpts where def = defcliopts + +-- | Parse raw option string values to the desired final data types. +-- Any relative smart dates will be converted to fixed dates based on +-- today's date. Parsing failures will raise an error. +toCliOpts :: RawOpts -> IO CliOpts +toCliOpts rawopts = do d <- getCurrentDay - return $ map (fixopt d) opts - where - fixopt d (Begin s) = Begin $ fixSmartDateStr d s - fixopt d (End s) = End $ fixSmartDateStr d s - fixopt d (Display s) = -- hacky - Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddatestr s - where fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]" - fixopt _ o = o + return defcliopts { + rawopts_ = rawopts + ,command_ = stringopt "command" rawopts + ,file_ = maybestringopt "file" rawopts + ,alias_ = listofstringopt "alias" rawopts + ,debug_ = boolopt "debug" rawopts + ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add + ,rules_file_ = maybestringopt "rules-file" rawopts -- convert + ,reportopts_ = defreportopts { + begin_ = maybesmartdateopt d "begin" rawopts + ,end_ = maybesmartdateopt d "end" rawopts + ,period_ = maybeperiodopt d rawopts + ,cleared_ = boolopt "cleared" rawopts + ,uncleared_ = boolopt "uncleared" rawopts + ,cost_ = boolopt "cost" rawopts + ,depth_ = maybeintopt "depth" rawopts + ,display_ = maybedisplayopt d rawopts + ,effective_ = boolopt "effective" rawopts + ,empty_ = boolopt "empty" rawopts + ,no_elide_ = boolopt "no-elide" rawopts + ,real_ = boolopt "real" rawopts + ,flat_ = boolopt "flat" rawopts -- balance + ,drop_ = intopt "drop" rawopts -- balance + ,no_total_ = boolopt "no-total" rawopts -- balance + ,daily_ = boolopt "daily" rawopts + ,weekly_ = boolopt "weekly" rawopts + ,monthly_ = boolopt "monthly" rawopts + ,quarterly_ = boolopt "quarterly" rawopts + ,yearly_ = boolopt "yearly" rawopts + ,format_ = maybestringopt "format" rawopts + ,patterns_ = words'' prefixes $ singleQuoteIfNeeded $ stringopt "args" rawopts + } + } --- | Figure out the overall date span we should report on, based on any --- begin/end/period options provided. If there is a period option, the --- others are ignored. -dateSpanFromOpts :: Day -> [Opt] -> DateSpan -dateSpanFromOpts refdate opts - | not (null popts) = case parsePeriodExpr refdate $ last popts of - Right (_, s) -> s - Left e -> parseerror e - | otherwise = DateSpan lastb laste - where - popts = optValuesForConstructor Period opts - bopts = optValuesForConstructor Begin opts - eopts = optValuesForConstructor End opts - lastb = listtomaybeday bopts - laste = listtomaybeday eopts - listtomaybeday vs = if null vs then Nothing else Just $ parse $ last vs - where parse = parsedate . fixSmartDateStr refdate +-- | Get all command-line options, specifying any extra commands that are allowed, or fail on parse errors. +getHledgerCliOpts :: [String] -> IO CliOpts +getHledgerCliOpts addons = do + args <- getArgs + toCliOpts (decodeRawOpts $ processValue (mainmode addons) $ moveFileOption args) >>= checkCliOpts --- | Figure out the reporting interval, if any, specified by the options. --- If there is a period option, the others are ignored. -intervalFromOpts :: [Opt] -> Interval -intervalFromOpts opts = - case (periodopts, intervalopts) of - ((p:_), _) -> case parsePeriodExpr (parsedate "0001/01/01") p of - Right (i, _) -> i - Left e -> parseerror e - (_, (DailyOpt:_)) -> Days 1 - (_, (WeeklyOpt:_)) -> Weeks 1 - (_, (MonthlyOpt:_)) -> Months 1 - (_, (QuarterlyOpt:_)) -> Quarters 1 - (_, (YearlyOpt:_)) -> Years 1 - (_, _) -> NoInterval - where - periodopts = reverse $ optValuesForConstructor Period opts - intervalopts = reverse $ filter (`elem` [DailyOpt,WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts +-- utils --- | Get the value of the (last) depth option, if any. -depthFromOpts :: [Opt] -> Maybe Int -depthFromOpts opts = listtomaybeint $ optValuesForConstructor Depth opts - where - listtomaybeint [] = Nothing - listtomaybeint vs = Just $ read $ last vs +-- | Get the unique suffixes (without hledger-) of hledger-* executables +-- found in the current user's PATH, or the empty list if there is any +-- problem. +getHledgerAddonCommands :: IO [String] +getHledgerAddonCommands = map (drop (length progname + 1)) `fmap` getHledgerProgramsInPath --- | Get the value of the (last) drop option, if any, otherwise 0. -dropFromOpts :: [Opt] -> Int -dropFromOpts opts = fromMaybe 0 $ listtomaybeint $ optValuesForConstructor Drop opts +-- | Get the unique names of hledger-* executables found in the current +-- user's PATH, or the empty list if there is any problem. +getHledgerProgramsInPath :: IO [String] +getHledgerProgramsInPath = do + pathdirs <- splitOn ":" `fmap` getEnvSafe "PATH" + pathexes <- concat `fmap` mapM getDirectoryContentsSafe pathdirs + return $ nub $ sort $ filter (isRight . parsewith hledgerprog) pathexes where - listtomaybeint [] = Nothing - listtomaybeint vs = Just $ read $ last vs + hledgerprog = string progname >> char '-' >> many1 (letter <|> char '-') >> eof --- | Get the value of the (last) display option, if any. -displayExprFromOpts :: [Opt] -> Maybe String -displayExprFromOpts opts = listtomaybe $ optValuesForConstructor Display opts - where - listtomaybe [] = Nothing - listtomaybe vs = Just $ last vs +getEnvSafe v = getEnv v `catch` (\_ -> return "") +getDirectoryContentsSafe d = getDirectoryContents d `catch` (\_ -> return []) --- | Get the value of the (last) baseurl option, if any. -baseUrlFromOpts :: [Opt] -> Maybe String -baseUrlFromOpts opts = listtomaybe $ optValuesForConstructor BaseUrl opts - where - listtomaybe [] = Nothing - listtomaybe vs = Just $ last vs +-- | Convert possibly encoded option values to regular unicode strings. +decodeRawOpts = map (\(name,val) -> (name, fromPlatformString val)) --- | Get the value of the (last) port option, if any. -portFromOpts :: [Opt] -> Maybe Int -portFromOpts opts = listtomaybeint $ optValuesForConstructor Port opts +-- A workaround related to http://code.google.com/p/ndmitchell/issues/detail?id=457 : +-- we'd like to permit options before COMMAND as well as after it. Here we +-- make sure at least -f FILE will be accepted in either position. +moveFileOption (fopt@('-':'f':_:_):cmd:rest) = cmd:fopt:rest +moveFileOption ("-f":fval:cmd:rest) = cmd:"-f":fval:rest +moveFileOption as = as + +optserror = error' . (++ " (run with --help for usage)") + +setopt name val = (++ [(name,singleQuoteIfNeeded val)]) + +setboolopt name = (++ [(name,"")]) + +in_ :: String -> RawOpts -> Bool +in_ name = isJust . lookup name + +boolopt = in_ + +maybestringopt name = maybe Nothing (Just . stripquotes) . lookup name + +stringopt name = fromMaybe "" . maybestringopt name + +listofstringopt name rawopts = [stripquotes v | (n,v) <- rawopts, n==name] + +maybeintopt :: String -> RawOpts -> Maybe Int +maybeintopt name rawopts = + let ms = maybestringopt name rawopts in + case ms of Nothing -> Nothing + Just s -> Just $ readDef (optserror $ "could not parse "++name++" number: "++s) s + +intopt name = fromMaybe 0 . maybeintopt name + +maybesmartdateopt :: Day -> String -> RawOpts -> Maybe Day +maybesmartdateopt d name rawopts = + case maybestringopt name rawopts of + Nothing -> Nothing + Just s -> either + (\e -> optserror $ "could not parse "++name++" date: "++show e) + Just + $ fixSmartDateStrEither' d s + +maybedisplayopt :: Day -> RawOpts -> Maybe DisplayExp +maybedisplayopt d rawopts = + maybe Nothing (Just . regexReplaceBy "\\[.+?\\]" fixbracketeddatestr) $ maybestringopt "display" rawopts where - listtomaybeint [] = Nothing - listtomaybeint vs = Just $ read $ last vs + fixbracketeddatestr "" = "" + fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]" +maybeperiodopt :: Day -> RawOpts -> Maybe (Interval,DateSpan) +maybeperiodopt d rawopts = + case maybestringopt "period" rawopts of + Nothing -> Nothing + Just s -> either + (\e -> optserror $ "could not parse period option: "++show e) + Just + $ parsePeriodExpr d s --- | Get a maybe boolean representing the last cleared/uncleared option if any. -clearedValueFromOpts opts | null os = Nothing - | last os == Cleared = Just True - | otherwise = Just False - where os = optsWithConstructors [Cleared,UnCleared] opts +-- | Do final validation of processed opts, raising an error if there is trouble. +checkCliOpts :: CliOpts -> IO CliOpts -- or pure.. +checkCliOpts opts@CliOpts{reportopts_=ropts} = do + case formatFromOpts ropts of + Left err -> optserror $ "could not parse format option: "++err + Right _ -> return () + return opts --- | Were we invoked as \"hours\" ? -usingTimeProgramName :: IO Bool -usingTimeProgramName = do - progname <- getProgName - return $ map toLower progname == progname_cli_time +-- | Parse any format option provided, possibly raising an error, or get +-- the default value. +formatFromOpts :: ReportOpts -> Either String [FormatString] +formatFromOpts = maybe (Right defaultBalanceFormatString) parseFormatString . format_ +-- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)" +defaultBalanceFormatString :: [FormatString] +defaultBalanceFormatString = [ + FormatField False (Just 20) Nothing Total + , FormatLiteral " " + , FormatField True (Just 2) Nothing DepthSpacer + , FormatField True Nothing Nothing Format.Account + ] + -- | Get the journal file path from options, an environment variable, or a default -journalFilePathFromOpts :: [Opt] -> IO String +journalFilePathFromOpts :: CliOpts -> IO String journalFilePathFromOpts opts = do - istimequery <- usingTimeProgramName - f <- if istimequery then myTimelogPath else myJournalPath - return $ last $ f : optValuesForConstructor File opts + f <- myJournalPath + return $ fromMaybe f $ file_ opts --- | Gather filter pattern arguments into a list of account patterns and a --- list of description patterns. We interpret pattern arguments as --- follows: those prefixed with "desc:" are description patterns, all --- others are account patterns; also patterns prefixed with "not:" are --- negated. not: should come after desc: if both are used. -parsePatternArgs :: [String] -> ([String],[String]) -parsePatternArgs args = (as, ds') +aliasesFromOpts :: CliOpts -> [(AccountName,AccountName)] +aliasesFromOpts = map parseAlias . alias_ where - descprefix = "desc:" - (ds, as) = partition (descprefix `isPrefixOf`) args - ds' = map (drop (length descprefix)) ds - --- | Convert application options to the library's generic filter specification. -optsToFilterSpec :: [Opt] -> [String] -> LocalTime -> FilterSpec -optsToFilterSpec opts args t = FilterSpec { - datespan=dateSpanFromOpts (localDay t) opts - ,cleared=clearedValueFromOpts opts - ,real=Real `elem` opts - ,empty=Empty `elem` opts - ,costbasis=CostBasis `elem` opts - ,acctpats=apats - ,descpats=dpats - ,whichdate = if Effective `elem` opts then EffectiveDate else ActualDate - ,depth = depthFromOpts opts - } - where (apats,dpats) = parsePatternArgs args + -- similar to ledgerAlias + parseAlias :: String -> (AccountName,AccountName) + parseAlias s = (accountNameWithoutPostingType $ strip orig + ,accountNameWithoutPostingType $ strip alias') + where + (orig, alias) = break (=='=') s + alias' = case alias of ('=':rest) -> rest + _ -> orig --- currentLocalTimeFromOpts opts = listtomaybe $ optValuesForConstructor CurrentLocalTime opts --- where --- listtomaybe [] = Nothing --- listtomaybe vs = Just $ last vs +showModeHelp = showText defaultWrap . helpText HelpFormatDefault tests_Hledger_Cli_Options = TestList [ - "dateSpanFromOpts" ~: do - let todaysdate = parsedate "2008/11/26" - let gives = is . show . dateSpanFromOpts todaysdate - [] `gives` "DateSpan Nothing Nothing" - [Begin "2008", End "2009"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" - [Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" - [Begin "2005", End "2007",Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" - - ,"intervalFromOpts" ~: do - let gives = is . intervalFromOpts - [] `gives` NoInterval - [DailyOpt] `gives` Days 1 - [WeeklyOpt] `gives` Weeks 1 - [MonthlyOpt] `gives` Months 1 - [QuarterlyOpt] `gives` Quarters 1 - [YearlyOpt] `gives` Years 1 - [Period "weekly"] `gives` Weeks 1 - [Period "monthly"] `gives` Months 1 - [Period "quarterly"] `gives` Quarters 1 - [WeeklyOpt, Period "yearly"] `gives` Years 1 - ] diff --git a/Hledger/Cli/Print.hs b/Hledger/Cli/Print.hs --- a/Hledger/Cli/Print.hs +++ b/Hledger/Cli/Print.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-| A ledger-compatible @print@ command. @@ -6,36 +5,25 @@ -} module Hledger.Cli.Print ( - JournalReport - ,JournalReportItem - ,print' - ,journalReport + print' ,showTransactions ) where -import Hledger.Cli.Options -import Hledger.Data -import Prelude hiding (putStr) -import Hledger.Data.UTF8 (putStr) - - --- | A "journal report" is just a list of transactions. -type JournalReport = [JournalReportItem] +import Data.List --- | The data for a single journal report item, representing one transaction. -type JournalReportItem = Transaction +import Hledger +import Prelude hiding (putStr) +import Hledger.Utils.UTF8 (putStr) +import Hledger.Cli.Options -- | Print journal transactions in standard format. -print' :: [Opt] -> [String] -> Journal -> IO () -print' opts args j = do - t <- getCurrentLocalTime - putStr $ showTransactions (optsToFilterSpec opts args t) j +print' :: CliOpts -> Journal -> IO () +print' CliOpts{reportopts_=ropts} j = do + d <- getCurrentDay + putStr $ showTransactions ropts (optsToFilterSpec ropts d) j -showTransactions :: FilterSpec -> Journal -> String -showTransactions fspec j = journalReportAsText [] fspec $ journalReport [] fspec j +showTransactions :: ReportOpts -> FilterSpec -> Journal -> String +showTransactions opts fspec j = entriesReportAsText opts fspec $ entriesReport opts fspec j -journalReportAsText :: [Opt] -> FilterSpec -> JournalReport -> String -- XXX unlike the others, this one needs fspec not opts -journalReportAsText _ fspec items = concatMap (showTransactionForPrint effective) items - where effective = EffectiveDate == whichdate fspec +entriesReportAsText :: ReportOpts -> FilterSpec -> EntriesReport -> String +entriesReportAsText opts _ items = concatMap (showTransactionForPrint (effective_ opts)) items -journalReport :: [Opt] -> FilterSpec -> Journal -> JournalReport -journalReport _ fspec j = sortBy (comparing tdate) $ jtxns $ filterJournalTransactions fspec j diff --git a/Hledger/Cli/Register.hs b/Hledger/Cli/Register.hs --- a/Hledger/Cli/Register.hs +++ b/Hledger/Cli/Register.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-| A ledger-compatible @register@ command. @@ -6,44 +5,32 @@ -} module Hledger.Cli.Register ( - RegisterReport - ,RegisterReportItem - ,register - ,registerReport - ,registerReportAsText + register + ,postingsReportAsText ,showPostingWithBalanceForVty ,tests_Hledger_Cli_Register ) where -import Safe (headMay, lastMay) -import Text.ParserCombinators.Parsec +import Data.List +import Data.Maybe +import Test.HUnit +import Text.Printf -import Hledger.Cli.Options -import Hledger.Data +import Hledger import Prelude hiding (putStr) -import Hledger.Data.UTF8 (putStr) +import Hledger.Utils.UTF8 (putStr) +import Hledger.Cli.Options --- | A register report is a list of postings to an account or set of --- accounts, with a running total. Postings may be actual postings, or --- virtual postings aggregated over a reporting interval. -type RegisterReport = [RegisterReportItem] -- line items, one per posting - --- | The data for a single register report line item, representing one posting. -type RegisterReportItem = (Maybe (Day, String) -- transaction date and description if this is the first posting - ,Posting -- the posting - ,MixedAmount -- balance so far - ) - --- | Print a register report. -register :: [Opt] -> [String] -> Journal -> IO () -register opts args j = do - t <- getCurrentLocalTime - putStr $ registerReportAsText opts $ registerReport opts (optsToFilterSpec opts args t) j +-- | Print a (posting) register report. +register :: CliOpts -> Journal -> IO () +register CliOpts{reportopts_=ropts} j = do + d <- getCurrentDay + putStr $ postingsReportAsText ropts $ postingsReport ropts (optsToFilterSpec ropts d) j -- | Render a register report as plain text suitable for console output. -registerReportAsText :: [Opt] -> RegisterReport -> String -registerReportAsText opts = unlines . map (registerReportItemAsText opts) +postingsReportAsText :: ReportOpts -> PostingsReport -> String +postingsReportAsText opts = unlines . map (postingsReportItemAsText opts) . snd -- | Render one register report line item as plain text. Eg: -- @ @@ -52,8 +39,8 @@ -- ^ displayed for first postings^ -- only, otherwise blank -- @ -registerReportItemAsText :: [Opt] -> RegisterReportItem -> String -registerReportItemAsText _ (dd, p, b) = concatTopPadded [datedesc, pstr, " ", bal] +postingsReportItemAsText :: ReportOpts -> PostingsReportItem -> String +postingsReportItemAsText _ (dd, p, b) = concatTopPadded [datedesc, pstr, " ", bal] where datedesc = case dd of Nothing -> replicate datedescwidth ' ' Just (da, de) -> printf "%s %s " date desc @@ -65,178 +52,13 @@ datedescwidth = 32 datewidth = 10 pstr = showPostingForRegister p - bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b) - -showPostingWithBalanceForVty showtxninfo p b = registerReportItemAsText [] $ mkitem showtxninfo p b - --- | Get a register report with the specified options for this journal. -registerReport :: [Opt] -> FilterSpec -> Journal -> RegisterReport -registerReport opts fspec j = getitems ps nullposting startbal - where - ps | interval == NoInterval = displayableps - | otherwise = summarisePostingsByInterval interval depth empty filterspan displayableps - (precedingps, displayableps, _) = postingsMatchingDisplayExpr (displayExprFromOpts opts) - $ depthClipPostings depth - $ journalPostings - $ filterJournalPostings fspec{depth=Nothing} j - startbal = sumPostings precedingps - filterspan = datespan fspec - (interval, depth, empty) = (intervalFromOpts opts, depthFromOpts opts, Empty `elem` opts) - --- | Generate register report line items. -getitems :: [Posting] -> Posting -> MixedAmount -> [RegisterReportItem] -getitems [] _ _ = [] -getitems (p:ps) pprev b = i:(getitems ps p b') - where - i = mkitem isfirst p b' - isfirst = ptransaction p /= ptransaction pprev - b' = b + pamount p - --- | Generate one register report line item, from a flag indicating --- whether to include transaction info, a posting, and the current running --- balance. -mkitem :: Bool -> Posting -> MixedAmount -> RegisterReportItem -mkitem False p b = (Nothing, p, b) -mkitem True p b = (ds, p, b) - where ds = case ptransaction p of Just (Transaction{tdate=da,tdescription=de}) -> Just (da,de) - Nothing -> Just (nulldate,"") - --- | Date-sort and split a list of postings into three spans - postings matched --- by the given display expression, and the preceding and following postings. -postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting]) -postingsMatchingDisplayExpr d ps = (before, matched, after) - where - sorted = sortBy (comparing postingDate) ps - (before, rest) = break (displayExprMatches d) sorted - (matched, after) = span (displayExprMatches d) rest - --- | Does this display expression allow this posting to be displayed ? --- Raises an error if the display expression can't be parsed. -displayExprMatches :: Maybe String -> Posting -> Bool -displayExprMatches Nothing _ = True -displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p - --- | Parse a hledger display expression, which is a simple date test like --- "d>[DATE]" or "d<=[DATE]", and return a "Posting"-matching predicate. -datedisplayexpr :: GenParser Char st (Posting -> Bool) -datedisplayexpr = do - char 'd' - op <- compareop - char '[' - (y,m,d) <- smartdate - char ']' - let date = parsedate $ printf "%04s/%02s/%02s" y m d - test op = return $ (`op` date) . postingDate - case op of - "<" -> test (<) - "<=" -> test (<=) - "=" -> test (==) - "==" -> test (==) - ">=" -> test (>=) - ">" -> test (>) - _ -> mzero - where - compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] - --- XXX confusing, refactor - --- | Convert a list of postings into summary postings. Summary postings --- are one per account per interval and aggregated to the specified depth --- if any. -summarisePostingsByInterval :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting] -summarisePostingsByInterval interval depth empty filterspan ps = concatMap summarisespan $ splitSpan interval reportspan - where - summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s) - postingsinspan s = filter (isPostingInDateSpan s) ps - dataspan = postingsDateSpan ps - reportspan | empty = filterspan `orDatesFrom` dataspan - | otherwise = dataspan - --- | Given a date span (representing a reporting interval) and a list of --- postings within it: aggregate the postings so there is only one per --- account, and adjust their date/description so that they will render --- as a summary for this interval. --- --- As usual with date spans the end date is exclusive, but for display --- purposes we show the previous day as end date, like ledger. --- --- When a depth argument is present, postings to accounts of greater --- depth are aggregated where possible. --- --- The showempty flag includes spans with no postings and also postings --- with 0 amount. -summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting] -summarisePostingsInDateSpan (DateSpan b e) depth showempty ps - | null ps && (isNothing b || isNothing e) = [] - | null ps && showempty = [summaryp] - | otherwise = summaryps' - where - summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e')) - b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b - e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e - summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}} - - summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps - summaryps = [summaryp{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames] - anames = sort $ nub $ map paccount ps - -- aggregate balances by account, like journalToLedger, then do depth-clipping - (_,_,exclbalof,inclbalof) = groupPostings ps - clippedanames = nub $ map (clipAccountName d) anames - isclipped a = accountNameLevel a >= d - d = fromMaybe 99999 $ depth - balancetoshowfor a = - (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a) - --- | Clip the account names to the specified depth in a list of postings. -depthClipPostings :: Maybe Int -> [Posting] -> [Posting] -depthClipPostings depth = map (depthClipPosting depth) - --- | Clip a posting's account name to the specified depth. -depthClipPosting :: Maybe Int -> Posting -> Posting -depthClipPosting Nothing p = p -depthClipPosting (Just d) p@Posting{paccount=a} = p{paccount=clipAccountName d a} + bal = padleft 12 (showMixedAmountWithoutPrice b) +-- XXX +showPostingWithBalanceForVty showtxninfo p b = postingsReportItemAsText defreportopts $ mkpostingsReportItem showtxninfo p b tests_Hledger_Cli_Register :: Test tests_Hledger_Cli_Register = TestList [ - - "summarisePostingsByInterval" ~: do - summarisePostingsByInterval (Quarters 1) Nothing False (DateSpan Nothing Nothing) [] ~?= [] - - -- ,"summarisePostingsInDateSpan" ~: do - -- let gives (b,e,depth,showempty,ps) = - -- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`) - -- let ps = - -- [ - -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]} - -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 2]} - -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [dollars 4]} - -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 8]} - -- ] - -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives` - -- [] - -- ("2008/01/01","2009/01/01",0,9999,True,[]) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"} - -- ] - -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [dollars 4]} - -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 10]} - -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]} - -- ] - -- ("2008/01/01","2009/01/01",0,2,False,ts) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [dollars 15]} - -- ] - -- ("2008/01/01","2009/01/01",0,1,False,ts) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [dollars 15]} - -- ] - -- ("2008/01/01","2009/01/01",0,0,False,ts) `gives` - -- [ - -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [dollars 15]} - -- ] ] diff --git a/Hledger/Cli/Stats.hs b/Hledger/Cli/Stats.hs --- a/Hledger/Cli/Stats.hs +++ b/Hledger/Cli/Stats.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-| Print some statistics for the journal. @@ -7,30 +6,34 @@ module Hledger.Cli.Stats where +import Data.List +import Data.Maybe +import Data.Ord +import Data.Time.Calendar +import Text.Printf import qualified Data.Map as Map +import Hledger import Hledger.Cli.Options -import Hledger.Data import Prelude hiding (putStr) -import Hledger.Data.UTF8 (putStr) +import Hledger.Utils.UTF8 (putStr) -- like Register.summarisePostings -- | Print various statistics for the journal. -stats :: [Opt] -> [String] -> Journal -> IO () -stats opts args j = do - today <- getCurrentDay - t <- getCurrentLocalTime - let filterspec = optsToFilterSpec opts args t +stats :: CliOpts -> Journal -> IO () +stats CliOpts{reportopts_=reportopts_} j = do + d <- getCurrentDay + let filterspec = optsToFilterSpec reportopts_ d l = journalToLedger filterspec j reportspan = (ledgerDateSpan l) `orDatesFrom` (datespan filterspec) - intervalspans = splitSpan (intervalFromOpts opts) reportspan - showstats = showLedgerStats opts args l today + intervalspans = splitSpan (intervalFromOpts reportopts_) reportspan + showstats = showLedgerStats l d s = intercalate "\n" $ map showstats intervalspans putStr s -showLedgerStats :: [Opt] -> [String] -> Ledger -> Day -> DateSpan -> String -showLedgerStats _ _ l today span = +showLedgerStats :: Ledger -> Day -> DateSpan -> String +showLedgerStats l today span = unlines (map (uncurry (printf fmt)) stats) where fmt = "%-" ++ show w1 ++ "s: %-" ++ show w2 ++ "s" diff --git a/Hledger/Cli/Tests.hs b/Hledger/Cli/Tests.hs --- a/Hledger/Cli/Tests.hs +++ b/Hledger/Cli/Tests.hs @@ -15,7 +15,7 @@ hledger source tree. They are hardly used, but here is an example: @ -$ bin/hledger -f data/sample.journal balance o +$ bin\/hledger -f data\/sample.journal balance o $1 expenses:food $-2 income $-1 gifts @@ -28,21 +28,31 @@ module Hledger.Cli.Tests where -import System.Exit (exitFailure, exitWith, ExitCode(ExitSuccess)) -- base 3 compatible +import Control.Monad +import System.Exit +import Test.HUnit -import Hledger.Data -- including testing utils in Hledger.Data.Utils +import Hledger import Hledger.Cli --- | Run unit tests. -runtests :: [Opt] -> [String] -> IO () -runtests _ args = do - (counts,_) <- liftM (flip (,) 0) $ runTestTT ts - if errors counts > 0 || (failures counts > 0) +-- | Run unit tests and exit with success or failure. +runtests :: CliOpts -> IO () +runtests opts = do + (hunitcounts,_) <- runtests' opts + if errors hunitcounts > 0 || (failures hunitcounts > 0) then exitFailure else exitWith ExitSuccess + +-- | Run unit tests and exit on failure. +runTestsOrExit :: CliOpts -> IO () +runTestsOrExit opts = do + (hunitcounts,_) <- runtests' opts + when (errors hunitcounts > 0 || (failures hunitcounts > 0)) $ exitFailure + +runtests' :: Num b => CliOpts -> IO (Counts, b) +runtests' opts = liftM (flip (,) 0) $ runTestTT ts where ts = TestList $ filter matchname $ tflatten tests_Hledger_Cli -- show flat test names -- ts = tfilter matchname $ TestList tests -- show hierarchical test names - matchname = matchpats args . tname - + matchname = matchpats (patterns_ $ reportopts_ opts) . tname diff --git a/Hledger/Cli/Utils.hs b/Hledger/Cli/Utils.hs --- a/Hledger/Cli/Utils.hs +++ b/Hledger/Cli/Utils.hs @@ -1,15 +1,14 @@ -{-# LANGUAGE CPP #-} {-| Utilities for top-level modules and ghci. See also Hledger.Read and -Hledger.Data.Utils. +Hledger.Utils. -} module Hledger.Cli.Utils ( withJournalDo, - readJournalWithOpts, + readJournal', journalReload, journalReloadIfChanged, journalFileIsNewer, @@ -22,38 +21,44 @@ Test(TestList), ) where -import Hledger.Data -import Hledger.Read -import Hledger.Cli.Options (Opt(..),journalFilePathFromOpts) -- ,optsToFilterSpec) import Control.Exception +import Data.List +import Data.Maybe import Safe (readMay) +import System.Console.CmdArgs import System.Directory (getModificationTime, getDirectoryContents, copyFile) import System.Exit import System.FilePath ((), splitFileName, takeDirectory) import System.Info (os) import System.Process (readProcessWithExitCode) import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff)) +import Test.HUnit +import Text.Printf +import Hledger.Cli.Options +import Hledger.Data +import Hledger.Read +import Hledger.Utils + -- | Parse the user's specified journal file and run a hledger command on -- it, or throw an error. -withJournalDo :: [Opt] -> [String] -> String -> ([Opt] -> [String] -> Journal -> IO ()) -> IO () -withJournalDo opts args _ cmd = do +withJournalDo :: CliOpts -> (CliOpts -> Journal -> IO ()) -> IO () +withJournalDo opts cmd = do -- We kludgily read the file before parsing to grab the full text, unless -- it's stdin, or it doesn't exist and we are adding. We read it strictly -- to let the add command work. - journalFilePathFromOpts opts >>= readJournalFile Nothing >>= either error' runcmd - where - costify = (if CostBasis `elem` opts then journalConvertAmountsToCost else id) - runcmd = cmd opts args . costify + journalFilePathFromOpts opts >>= readJournalFile Nothing >>= + either error' (cmd opts . journalApplyAliases (aliasesFromOpts opts)) --- | Get a journal from the given string and options, or throw an error. -readJournalWithOpts :: [Opt] -> String -> IO Journal -readJournalWithOpts opts s = do - j <- readJournal Nothing s >>= either error' return - return $ (if cost then journalConvertAmountsToCost else id) j - where cost = CostBasis `elem` opts +-- -- | Get a journal from the given string and options, or throw an error. +-- readJournalWithOpts :: CliOpts -> String -> IO Journal +-- readJournalWithOpts opts s = readJournal Nothing s >>= either error' return +-- | Get a journal from the given string, or throw an error. +readJournal' :: String -> IO Journal +readJournal' s = readJournal Nothing s >>= either error' return + -- | Re-read a journal from its data file, or return an error string. journalReload :: Journal -> IO (Either String Journal) journalReload j = readJournalFile Nothing $ journalFilePath j @@ -63,14 +68,14 @@ -- stdin). The provided options are mostly ignored. Return a journal or -- the error message while reading it, and a flag indicating whether it -- was re-read or not. -journalReloadIfChanged :: [Opt] -> Journal -> IO (Either String Journal, Bool) -journalReloadIfChanged opts j = do +journalReloadIfChanged :: CliOpts -> Journal -> IO (Either String Journal, Bool) +journalReloadIfChanged _ j = do let maybeChangedFilename f = do newer <- journalSpecifiedFileIsNewer j f return $ if newer then Just f else Nothing changedfiles <- catMaybes `fmap` mapM maybeChangedFilename (journalFilePaths j) if not $ null changedfiles then do - when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (head changedfiles) + whenLoud $ printf "%s has changed, reloading\n" (head changedfiles) jE <- journalReload j return (jE, True) else @@ -153,6 +158,6 @@ -- | Does the second file represent a backup of the first, and if so which version is it ? backupNumber :: FilePath -> FilePath -> Maybe Int -backupNumber f g = case matchRegexPR ("^" ++ f ++ "\\.([0-9]+)$") g of +backupNumber f g = case regexMatch ("^" ++ f ++ "\\.([0-9]+)$") g of Just (_, ((_,suffix):_)) -> readMay suffix _ -> Nothing diff --git a/Hledger/Cli/Version.hs b/Hledger/Cli/Version.hs --- a/Hledger/Cli/Version.hs +++ b/Hledger/Cli/Version.hs @@ -10,21 +10,26 @@ ,binaryfilename ) where +import Data.List import System.Info (os, arch) +import Text.Printf -import Hledger.Data.Utils +import Hledger.Utils -- version and PATCHLEVEL are set by the make process -version = "0.14.0" +version :: String +version = "0.15.0" +patchlevel :: String #ifdef PATCHLEVEL -patchlevel = "." ++ show PATCHLEVEL -- must be numeric ! +patchlevel = "." ++ show (PATCHLEVEL :: Int) -- must be numeric ! #else patchlevel = "" #endif +buildversion :: String buildversion = version ++ patchlevel :: String -- | Given a program name, return a human-readable version string. For diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,12 +1,2 @@ -#!/usr/bin/env runhaskell import Distribution.Simple -import Distribution.Simple.LocalBuildInfo -import Distribution.PackageDescription -import System.FilePath -import System.Process - -main = defaultMainWithHooks $ simpleUserHooks{runTests=runTests'} - -runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () -runTests' _ _ _ lbi = system testprog >> return () - where testprog = buildDir lbi "hledger" "hledger test" +main = defaultMain diff --git a/hledger-cli.hs b/hledger-cli.hs new file mode 100644 --- /dev/null +++ b/hledger-cli.hs @@ -0,0 +1,6 @@ +#!/usr/bin/env runhaskell +-- the hledger command-line executable; see Hledger/Cli/Main.hs + +module Main (main) +where +import Hledger.Cli.Main (main) diff --git a/hledger.cabal b/hledger.cabal --- a/hledger.cabal +++ b/hledger.cabal @@ -1,13 +1,14 @@ name: hledger -version: 0.14 +version: 0.15 category: Finance -synopsis: A robust command-line accounting tool with a simple human-editable data format, similar to ledger. +synopsis: The main command-line interface for the hledger accounting tool. description: - hledger is a haskell port and friendly fork of John Wiegley's ledger accounting tool. - This package provides the main hledger command-line tool; see the other hledger-* packages for web and curses interfaces and chart generation. - hledger aims to be a reliable, practical financial reporting tool for day-to-day use, and also a useful library for building financial apps in haskell. - Given a plain text file describing transactions, of money or any other commodity, hledger will print the chart of accounts, account balances, or transactions you're interested in. - It can also help you add transactions to the journal file, or convert CSV data from your bank. + hledger is a library and set of user tools for working + with financial data (or anything that can be tracked in a + double-entry accounting ledger.) It is a haskell port and + friendly fork of John Wiegley's Ledger. hledger provides + command-line, curses and web interfaces, and aims to be a + reliable, practical tool for daily use. license: GPL license-file: LICENSE @@ -16,30 +17,37 @@ homepage: http://hledger.org bug-reports: http://code.google.com/p/hledger/issues stability: beta -tested-with: GHC==6.10, GHC==6.12 -cabal-version: >= 1.6 -build-type: Custom +tested-with: GHC==6.12, GHC==7.0 +cabal-version: >= 1.8 +build-type: Simple -- data-dir: data -- data-files: extra-tmp-files: extra-source-files: +-- Cabal-Version: >= 1.9.2 +-- Test-Suite test-hledger +-- type: exitcode-stdio-1.0 +-- main-is: test-hledger.hs +-- build-depends: base + source-repository head type: darcs location: http://joyful.com/repos/hledger -executable hledger - main-is: hledger.hs - -- XXX set patchlevel here as in Makefile +library + -- XXX should set patchlevel here as in Makefile cpp-options: -DPATCHLEVEL=0 - ghc-options: -threaded -W - other-modules: + ghc-options: -W + -- should be the same as below + exposed-modules: + Hledger.Cli Hledger.Cli.Main + Hledger.Cli.Format Hledger.Cli.Options Hledger.Cli.Tests Hledger.Cli.Utils Hledger.Cli.Version - Hledger.Cli Hledger.Cli.Add Hledger.Cli.Balance Hledger.Cli.Convert @@ -47,14 +55,17 @@ Hledger.Cli.Print Hledger.Cli.Register Hledger.Cli.Stats + -- should be the same as below build-depends: - hledger-lib == 0.14 - ,HUnit + hledger-lib == 0.15 ,base >= 3 && < 5 ,containers + ,cmdargs >= 0.8 && < 0.9 ,csv ,directory ,filepath + ,haskeline == 0.6.* + ,HUnit ,mtl ,old-locale ,old-time @@ -65,20 +76,25 @@ ,split == 0.1.* ,time ,utf8-string >= 0.3.5 && < 0.4 - ,haskeline == 0.6.* --- modules and dependencies below should be as above -library - -- should set patchlevel here as in Makefile - cpp-options: -DPATCHLEVEL=0 - ghc-options: -W - exposed-modules: +-- should depend on the above to avoid double compilation but this is +-- still too complicated as of 2011/6/1 because: +-- - breaks haddock, http://hackage.haskell.org/trac/hackage/ticket/656 +-- - library and executable must have different hs-source-dirs +-- - the exe may need to list all the lib's dependencies +-- - how it works seems ghc version dependent +-- leksah is reported to have this working, http://hackage.haskell.org/packages/archive/leksah/0.10.0.4/leksah.cabal +executable hledger + main-is: hledger-cli.hs + -- should be the same as above + other-modules: + Hledger.Cli Hledger.Cli.Main + Hledger.Cli.Format Hledger.Cli.Options Hledger.Cli.Tests Hledger.Cli.Utils Hledger.Cli.Version - Hledger.Cli Hledger.Cli.Add Hledger.Cli.Balance Hledger.Cli.Convert @@ -86,14 +102,20 @@ Hledger.Cli.Print Hledger.Cli.Register Hledger.Cli.Stats + -- XXX should set patchlevel here as in Makefile + cpp-options: -DPATCHLEVEL=0 + ghc-options: -threaded -W + -- should be the same as above build-depends: - hledger-lib == 0.14 - ,HUnit + hledger-lib == 0.15 ,base >= 3 && < 5 ,containers + ,cmdargs >= 0.8 && < 0.9 ,csv ,directory ,filepath + ,haskeline == 0.6.* + ,HUnit ,mtl ,old-locale ,old-time diff --git a/hledger.hs b/hledger.hs deleted file mode 100644 --- a/hledger.hs +++ /dev/null @@ -1,6 +0,0 @@ -#!/usr/bin/env runhaskell --- the hledger command-line executable; see Hledger/Cli/Main.hs - -module Main (main) -where -import Hledger.Cli.Main (main)