hledger 0.14 → 0.15

raw patch · 18 files changed

+1144/−900 lines, 18 filesdep +cmdargsdep ~hledger-libsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: cmdargs

Dependency ranges changed: hledger-lib

API changes (from Hackage documentation)

Files

• Hledger/Cli.hs +94/−79
• Hledger/Cli/Add.hs +41/−34
• Hledger/Cli/Balance.hs +65/−99
• Hledger/Cli/Convert.hs +165/−66
• Hledger/Cli/Format.hs +133/−0
• Hledger/Cli/Histogram.hs +15/−10
• Hledger/Cli/Main.hs +63/−22
• Hledger/Cli/Options.hs +406/−273
• Hledger/Cli/Print.hs +14/−26
• Hledger/Cli/Register.hs +21/−199
• Hledger/Cli/Stats.hs +15/−12
• Hledger/Cli/Tests.hs +20/−10
• Hledger/Cli/Utils.hs +27/−22
• Hledger/Cli/Version.hs +8/−3
• Setup.hs +1/−11
• hledger-cli.hs +6/−0
• hledger.cabal +50/−28
• hledger.hs +0/−6

@@ -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-

@@ -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

@@ -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  [

@@ -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 =

@@ -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"+                                                ]+  ]

@@ -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) 

@@ -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++-}

@@ -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-  ]

@@ -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

@@ -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]}-  --    ]   ]

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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)