hledger 0.19.3 → 0.20

raw patch · 8 files changed

+302/−282 lines, 8 filesdep ~hledger-libPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: hledger-lib

API changes (from Hackage documentation)

Files

• Hledger/Cli.hs +30/−150
• Hledger/Cli/Add.hs +156/−83
• Hledger/Cli/Histogram.hs +1/−1
• Hledger/Cli/Options.hs +47/−8
• Hledger/Cli/Register.hs +41/−26
• Hledger/Cli/Tests.hs +15/−1
• Hledger/Cli/Utils.hs +6/−7
• hledger.cabal +6/−6

@@ -336,214 +336,94 @@           [            txnTieKnot $ Transaction {              tdate=parsedate "2007/01/01",-             teffectivedate=Nothing,+             tdate2=Nothing,              tstatus=False,              tcode="*",              tdescription="opening balance",              tcomment="",              ttags=[],-             tpostings=[-              Posting {-                pstatus=False,-                paccount="assets:cash",-                pamount=(Mixed [usd 4.82]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              },-              Posting {-                pstatus=False,-                paccount="equity:opening balances",-                pamount=(Mixed [usd (-4.82)]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              }-             ],+             tpostings=+                 ["assets:cash" `post` usd 4.82+                 ,"equity:opening balances" `post` usd (-4.82)+                 ],              tpreceding_comment_lines=""            }           ,            txnTieKnot $ Transaction {              tdate=parsedate "2007/02/01",-             teffectivedate=Nothing,+             tdate2=Nothing,              tstatus=False,              tcode="*",              tdescription="ayres suites",              tcomment="",              ttags=[],-             tpostings=[-              Posting {-                pstatus=False,-                paccount="expenses:vacation",-                pamount=(Mixed [usd 179.92]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              },-              Posting {-                pstatus=False,-                paccount="assets:checking",-                pamount=(Mixed [usd (-179.92)]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              }-             ],+             tpostings=+                 ["expenses:vacation" `post` usd 179.92+                 ,"assets:checking" `post` usd (-179.92)+                 ],              tpreceding_comment_lines=""            }           ,            txnTieKnot $ Transaction {              tdate=parsedate "2007/01/02",-             teffectivedate=Nothing,+             tdate2=Nothing,              tstatus=False,              tcode="*",              tdescription="auto transfer to savings",              tcomment="",              ttags=[],-             tpostings=[-              Posting {-                pstatus=False,-                paccount="assets:saving",-                pamount=(Mixed [usd 200]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              },-              Posting {-                pstatus=False,-                paccount="assets:checking",-                pamount=(Mixed [usd (-200)]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              }-             ],+             tpostings=+                 ["assets:saving" `post` usd 200+                 ,"assets:checking" `post` usd (-200)+                 ],              tpreceding_comment_lines=""            }           ,            txnTieKnot $ Transaction {              tdate=parsedate "2007/01/03",-             teffectivedate=Nothing,+             tdate2=Nothing,              tstatus=False,              tcode="*",              tdescription="poquito mas",              tcomment="",              ttags=[],-             tpostings=[-              Posting {-                pstatus=False,-                paccount="expenses:food:dining",-                pamount=(Mixed [usd 4.82]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              },-              Posting {-                pstatus=False,-                paccount="assets:cash",-                pamount=(Mixed [usd (-4.82)]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              }-             ],+             tpostings=+                 ["expenses:food:dining" `post` usd 4.82+                 ,"assets:cash" `post` usd (-4.82)+                 ],              tpreceding_comment_lines=""            }           ,            txnTieKnot $ Transaction {              tdate=parsedate "2007/01/03",-             teffectivedate=Nothing,+             tdate2=Nothing,              tstatus=False,              tcode="*",              tdescription="verizon",              tcomment="",              ttags=[],-             tpostings=[-              Posting {-                pstatus=False,-                paccount="expenses:phone",-                pamount=(Mixed [usd 95.11]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              },-              Posting {-                pstatus=False,-                paccount="assets:checking",-                pamount=(Mixed [usd (-95.11)]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              }-             ],+             tpostings=+                 ["expenses:phone" `post` usd 95.11+                 ,"assets:checking" `post` usd (-95.11)+                 ],              tpreceding_comment_lines=""            }           ,            txnTieKnot $ Transaction {              tdate=parsedate "2007/01/03",-             teffectivedate=Nothing,+             tdate2=Nothing,              tstatus=False,              tcode="*",              tdescription="discover",              tcomment="",              ttags=[],-             tpostings=[-              Posting {-                pstatus=False,-                paccount="liabilities:credit cards:discover",-                pamount=(Mixed [usd 80]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              },-              Posting {-                pstatus=False,-                paccount="assets:checking",-                pamount=(Mixed [usd (-80)]),-                pcomment="",-                ptype=RegularPosting,-                ptags=[],-                ptransaction=Nothing-              }-             ],+             tpostings=+                 ["liabilities:credit cards:discover" `post` usd 80+                 ,"assets:checking" `post` usd (-80)+                 ],              tpreceding_comment_lines=""            }           ]          }  ledger7 = ledgerFromJournal Any journal7---- journal8_str = unlines---  ["2008/1/1 test           "---  ,"  a:b          10h @ $40"---  ,"  c:d                   "---  ,""---  ]---- timelogentry1_str  = "i 2007/03/11 16:19:00 hledger\n"--- timelogentry1 = TimeLogEntry In (parsedatetime "2007/03/11 16:19:00") "hledger"---- timelogentry2_str  = "o 2007/03/11 16:30:00\n"--- timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") ""---- a1 = Mixed [(hrs 1){aprice=Just $ Mixed [Amount (comm "$") 10 Nothing]}]--- a2 = Mixed [(hrs 2){aprice=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}]--- a3 = Mixed $ amounts a1 ++ amounts a2---- journalWithAmounts :: [String] -> Journal--- journalWithAmounts as =---        nulljournal{jtxns=---         [t | a <- as, let t = nulltransaction{tdescription=a,tpostings=[nullposting{pamount=parse a,ptransaction=Just t}]}]---         }---     where parse = fromparse . parseWithCtx nullctx amountp

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables, DeriveDataTypeable #-} {-|   A history-aware add command to help with data entry.@@ -10,16 +11,17 @@  module Hledger.Cli.Add where-import Control.Exception as C+import Control.Exception as E import Control.Monad import Control.Monad.Trans (liftIO)-import Data.Char (toUpper)+import Data.Char (toUpper, toLower) import Data.List import Data.Maybe-import Data.Time.Calendar+import Data.Typeable (Typeable)+import Safe (headDef, tailDef, headMay) import System.Console.Haskeline (InputT, runInputT, defaultSettings, setComplete, getInputLine) import System.Console.Haskeline.Completion-import System.IO ( stderr, hPutStrLn, hPutStr )+import System.IO ( stderr, hPutStr, hPutStrLn ) import System.IO.Error import Text.ParserCombinators.Parsec import Text.Printf@@ -32,55 +34,107 @@ import Hledger.Cli.Register (postingsReportAsText)  -{- | Information used as the basis for suggested account names, amounts,-     etc in add prompt--}-data PostingState = PostingState {-      psJournal :: Journal,-      psAccept  :: AccountName -> Bool,-      psSuggestHistoricalAmount :: Bool,-      psHistory :: Maybe [Posting]}---- | 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.+-- | Read multiple transactions from the console, prompting for each+-- field, and append them to the journal file.  If the journal came+-- from stdin, this command has no effect. add :: CliOpts -> Journal -> IO () add opts j     | f == "-" = return ()     | otherwise = do-  hPrintf stderr "Adding transactions to journal file \"%s\".\n" f-  hPutStrLn stderr $-    "To complete a transaction, enter . (period) at an account prompt.\n"-    ++"To stop adding transactions, enter . at a date prompt, or control-d/control-c."-  today <- getCurrentDay-  getAndAddTransactions j opts today-        `C.catch` (\e -> unless (isEOFError e) $ ioError e)+  hPutStr stderr $ unlines [+     "Adding transactions to journal file "++f+    ,"Provide field values at the prompts, or press enter to accept defaults."+    ,"Use readline keys to edit, use tab key to complete account names."+    ,"A code (in parentheses) may be entered following transaction dates."+    ,"A comment may be entered following descriptions or amounts."+    ,"If you make a mistake, enter < at any prompt to restart the transaction."+    ,"To complete a transaction, enter . when prompted."+    ,"To quit, press control-d or control-c."+    ]+  today <- showDate `fmap` getCurrentDay+  let args                = words' $ query_ $ reportopts_ opts+      (defdate, moredefs) = headTailDef today args+  getAndAddTransactionsLoop j opts defdate moredefs+        `E.catch` (\e -> unless (isEOFError e) $ ioError e)       where f = journalFilePath j --- | Read a number of transactions from the command line, prompting,--- 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 -> CliOpts -> Day -> IO ()-getAndAddTransactions j opts defaultDate = do-  (t, d) <- getTransaction j opts defaultDate-  j <- journalAddTransaction j opts t-  getAndAddTransactions j opts d+-- | Loop reading transactions from the console, prompting for,+-- validating, displaying and appending each one to the journal file,+-- until end of input or ctrl-c (then raise an EOF exception).+-- If provided, command-line arguments are used as defaults for the+-- first transaction; otherwise defaults come from the most similar+-- recent transaction in the journal.+getAndAddTransactionsLoop :: Journal -> CliOpts -> String -> [String] -> IO ()+getAndAddTransactionsLoop j opts defdate moredefs = do+  hPrintf stderr "\nStarting a new transaction.\n"+  t <- getTransaction j opts defdate moredefs+  j' <- journalAddTransaction j opts t+  hPrintf stderr "Added to the journal.\n"+  let defdate' = showDate $ tdate t+  getAndAddTransactionsLoop j' opts defdate' [] --- | Read a transaction from the command line, with history-aware prompting.-getTransaction :: Journal -> CliOpts -> Day-                    -> IO (Transaction,Day)-getTransaction j opts defaultDate = do-  today <- getCurrentDay-  datestr <- runInteractionDefault $ askFor "date, or . to end"-            (Just $ showDate defaultDate)+-- | Read a single transaction from the console, with history-aware prompting,+-- allowing the user to restart and confirm at the end.+-- A default date, and zero or more defaults for subsequent fields, are provided.+getTransaction :: Journal -> CliOpts -> String -> [String] -> IO Transaction+getTransaction j opts defdate moredefs = do+  mt <- getTransactionOrRestart j opts defdate moredefs+  let restart = do+        hPrintf stderr "\nRestarting this transaction.\n"+        getTransaction j opts defdate moredefs+  case mt of+    Nothing -> restart+    Just t  -> do+      hPrintf stderr "\nTransaction entered:\n%s" (show t)+      yn <- runInteractionDefault $ askFor "Accept this transaction" (Just "y") (Just $ \s -> map toLower s `elem` ["<","y","yes","n","no"])+      case headMay $ map toLower yn of+        Just 'y' -> return t+        _        -> restart++-- | Read a single transaction from the console, with history-aware prompting,+-- or return nothing indicating that the user wants to restart entering this transaction.+-- A default date, and zero or more defaults for subsequent fields, are provided.+getTransactionOrRestart :: Journal -> CliOpts -> String -> [String] -> IO (Maybe Transaction)+getTransactionOrRestart j opts defdate moredefs = do+  let dateandcodep = do {d <- smartdate; c <- optionMaybe code; many spacenonewline; eof; return (d, fromMaybe "" c)}+  datecodestr <- runInteractionDefault $ askFor "date"+            (Just defdate)             (Just $ \s -> null s                          || s == "."-                         || isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))-  when (datestr == ".") $ ioError $ mkIOError eofErrorType "" Nothing Nothing-  description <- runInteractionDefault $ askFor "description" (Just "") Nothing+                         || isRight (parseWithCtx nullctx dateandcodep $ lowercase s))+  when (datecodestr == ".") $ ioError $ mkIOError eofErrorType "" Nothing Nothing+  today <- getCurrentDay+  let (sdate,code) = fromparse $ parseWithCtx nullctx dateandcodep datecodestr+      defday = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) defdate+      datestr = showDate $ fixSmartDate defday sdate++  let (defdesc, moredefs') = headTailDef "" moredefs+  desc <- runInteractionDefault $ askFor "description" (Just defdesc) Nothing+  if desc == "<"+   then return Nothing+   else do+    let (description,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') desc+    getPostingsForTransactionWithHistory j opts datestr code description comment moredefs'++data RestartEntryException = RestartEntryException deriving (Typeable,Show)+instance Exception RestartEntryException++-- | Information used as the basis for suggested account names, amounts etc. in add prompt.+data PostingsState = PostingsState {+   psJournal                 :: Journal+  ,psAccept                  :: AccountName -> Bool+  ,psSuggestHistoricalAmount :: Bool+  ,psHistory                 :: Maybe [Posting]+  }++-- | Loop reading postings from the console, until a valid balanced+-- set of postings has been entered, then return the final transaction,+-- or nothing indicating that the user wants to restart entering this transaction.+getPostingsForTransactionWithHistory :: Journal -> CliOpts -> String -> String -> String -> String -> [String] -> IO (Maybe Transaction)+getPostingsForTransactionWithHistory j opts datestr code description comment defargs = do+  today <- getCurrentDay   let historymatches = transactionsSimilarTo j (queryFromOpts today $ reportopts_ opts) description-      bestmatch | null historymatches = Nothing+      bestmatch | not (null defargs) || null historymatches = Nothing                 | otherwise = Just $ snd $ head historymatches       bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch       date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr@@ -89,53 +143,56 @@             then x `elem` existingaccts             else True       existingaccts = journalAccountNames j-      getpostingsandvalidate = do-        ps <- getPostings (PostingState j accept True bestmatchpostings) []+      getvalidpostings = do+        ps <- getPostingsLoop (PostingsState j accept True bestmatchpostings) [] defargs         let t = nulltransaction{tdate=date                                ,tstatus=False+                               ,tcode=code                                ,tdescription=description+                               ,tcomment=comment                                ,tpostings=ps                                }-            retry msg = do-              liftIO $ hPutStrLn stderr $ "\n" ++ msg ++ "please re-enter."-              getpostingsandvalidate-        either retry (return . flip (,) date) $ balanceTransaction Nothing t -- imprecise balancing-  unless (null historymatches) -       (liftIO $ do-         hPutStrLn stderr "Similar transactions found, using the first for defaults:\n"-         hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches)-  getpostingsandvalidate+        either retry (return . Just) $ balanceTransaction Nothing t -- imprecise balancing+          where+            retry msg = liftIO (hPutStrLn stderr $ "\n" ++ (capitalize msg) ++ "please re-enter.") >> getvalidpostings --- fragile--- | Read postings from the command line until . is entered, using any--- provided historical postings and the journal context to guess defaults.-getPostings :: PostingState -> [Posting] -> IO [Posting]-getPostings st enteredps = do+  when (isJust bestmatch) $ liftIO $ hPrintf stderr "\nUsing this existing transaction for defaults:\n%s" (show $ fromJust bestmatch)+  getvalidpostings `E.catch` \(_::RestartEntryException) -> return Nothing++-- | Read postings from the command line until . is entered, generating+-- useful defaults based on historical context and postings entered so far.+getPostingsLoop :: PostingsState -> [Posting] -> [String] -> IO [Posting]+getPostingsLoop st enteredps defargs = do   let bestmatch | isNothing historicalps = Nothing                 | n <= length ps = Just $ ps !! (n-1)                 | otherwise = Nothing                 where Just ps = historicalps-      defaultaccount = maybe Nothing (Just . showacctname) bestmatch+      bestmatchacct = maybe Nothing (Just . showacctname) bestmatch+      defacct  = maybe bestmatchacct Just $ headMay defargs+      defargs' = tailDef [] defargs       ordot | null enteredps || length enteredrealps == 1 = "" :: String-            | otherwise = ", or . to record"-  account <- runInteraction j $ askFor (printf "account %d%s" n ordot) defaultaccount (Just accept)+            | otherwise = " (or . to complete this transaction)"+  account <- runInteraction j $ askFor (printf "account %d%s" n ordot) defacct (Just accept)+  when (account=="<") $ throwIO RestartEntryException   if account=="."     then      if null enteredps       then do hPutStrLn stderr $ "\nPlease enter some postings first."-              getPostings st enteredps+              getPostingsLoop st enteredps defargs       else return enteredps     else do-      let defaultacctused = Just account == defaultaccount-          historicalps' = if defaultacctused then historicalps else Nothing+      let defacctused = Just account == defacct+          historicalps' = if defacctused then historicalps else Nothing           bestmatch' | isNothing historicalps' = Nothing                      | n <= length ps = Just $ ps !! (n-1)                      | otherwise = Nothing                      where Just ps = historicalps'-          defaultamountstr | isJust bestmatch' && suggesthistorical = Just historicalamountstr-                           | n > 1             = Just balancingamountstr-                           | otherwise         = Nothing+          defamountstr | isJust commandlineamt                  = commandlineamt+                       | isJust bestmatch' && suggesthistorical = Just historicalamountstr+                       | n > 1                                  = Just balancingamountstr+                       | otherwise                              = Nothing               where+                commandlineamt      = headMay defargs'                 historicalamountstr = showMixedAmountWithPrecision p $ pamount $ fromJust bestmatch'                 balancingamountstr  = showMixedAmountWithPrecision p $ negate $ sum $ map pamount enteredrealps                 -- what should this be ?@@ -146,22 +203,26 @@                 -- 5 3 or 4, whichever would show the most decimal places ?                 -- I think 1 or 4, whichever would show the most decimal places                 p = maxprecisionwithpoint-      amountstr <- runInteractionDefault $ askFor (printf "amount  %d" n) defaultamountstr validateamount+          defargs'' = tailDef [] defargs'+      amt <- runInteractionDefault $ askFor (printf "amount  %d" n) defamountstr validateamount+      when (amt=="<") $ throwIO RestartEntryException+      let (amountstr,comment) = (strip a, strip $ dropWhile (==';') b) where (a,b) = break (==';') amt       let a  = fromparse $ runParser (amountp <|> return missingamt) ctx     "" amountstr           a' = fromparse $ runParser (amountp <|> return missingamt) nullctx "" amountstr-          wasdefaultamtused = Just (showAmount a) == defaultamountstr-          defaultcommodityadded | acommodity a == acommodity a' = Nothing+          wasdefamtused = Just (showAmount a) == defamountstr+          defcommodityadded | acommodity a == acommodity a' = Nothing                                 | otherwise                     = Just $ acommodity a           p = nullposting{paccount=stripbrackets account                          ,pamount=mixed a+                         ,pcomment=comment                          ,ptype=postingtype account                          }-          st' = if wasdefaultamtused+          st' = if wasdefamtused                  then st                  else st{psHistory=historicalps', psSuggestHistoricalAmount=False}-      when (isJust defaultcommodityadded) $-           liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust defaultcommodityadded)-      getPostings st' (enteredps ++ [p])+      when (isJust defcommodityadded) $+           liftIO $ hPutStrLn stderr $ printf "using default commodity (%s)" (fromJust defcommodityadded)+      getPostingsLoop st' (enteredps ++ [p]) defargs''     where       j = psJournal st       historicalps = psHistory st@@ -174,17 +235,18 @@       postingtype ('[':_) = BalancedVirtualPosting       postingtype ('(':_) = VirtualPosting       postingtype _ = RegularPosting-      stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse       validateamount = Just $ \s -> (null s && not (null enteredrealps))-                                   || isRight (runParser (amountp >> many spacenonewline >> eof) ctx "" s)+                                    || s == "<"+                                    || (isRight (runParser (amountp >> many spacenonewline >> optional (char ';' >> many anyChar) >> eof) ctx "" s)+                                        && s /= ".")  -- | Prompt for and read a string value, optionally with a default value -- and a validator. A validator causes the prompt to repeat until the--- input is valid. May also raise an EOF exception if control-d is pressed.+-- input is valid. May also raise an EOF exception if control-d or control-c is pressed. askFor :: String -> Maybe String -> Maybe (String -> Bool) -> InputT IO String askFor prompt def validator = do   l <- fmap (maybe eofErr id)-            $ getInputLine $ prompt ++ maybe "" showdef def ++ ": "+            $ getInputLine $ prompt ++ " ? " ++ maybe "" showdef def ++ ": "   let input = if null l then fromMaybe l def else l   case validator of     Just valid -> if valid input@@ -192,8 +254,9 @@                    else askFor prompt def validator     Nothing -> return input     where-        showdef s = " [" ++ s ++ "]"-        eofErr = C.throw $ mkIOError eofErrorType "end of input" Nothing Nothing+        showdef "" = ""+        showdef s = "[" ++ s ++ "]"+        eofErr = E.throw $ mkIOError eofErrorType "end of input" Nothing Nothing  -- | Append this transaction to the journal's file, and to the journal's -- transaction list.@@ -224,8 +287,10 @@ registerFromString s = do   d <- getCurrentDay   j <- readJournal' s-  return $ postingsReportAsText opts $ postingsReport opts (queryFromOpts d opts) j-      where opts = defreportopts{empty_=True}+  return $ postingsReportAsText opts $ postingsReport ropts (queryFromOpts d ropts) j+      where+        ropts = defreportopts{empty_=True}+        opts = defcliopts{reportopts_=ropts}  -- | Return a similarity measure, from 0 to 1, for two strings. -- This is Simon White's letter pairs algorithm from@@ -285,3 +350,11 @@                            -- can contain spaces.                         $ \s -> return $ map simpleCompletion                                         $ filter (s `isPrefixOf`) cc++capitalize :: String -> String+capitalize "" = ""+capitalize (c:cs) = toUpper c : cs++headTailDef :: a -> [a] -> (a,[a])+headTailDef defhead as = (headDef defhead as, tailDef [] as)+

@@ -34,7 +34,7 @@       i = intervalFromOpts opts       interval | i == NoInterval = Days 1                | otherwise = i-      span = queryDateSpan (effective_ opts) q `orDatesFrom` journalDateSpan j+      span = queryDateSpan (date2_ opts) q `orDatesFrom` journalDateSpan j       spans = filter (DateSpan Nothing Nothing /=) $ splitSpan interval span       spanps = [(s, filter (isPostingInDateSpan s) ps) | s <- spans]       -- same as Register

@@ -7,7 +7,7 @@  module Hledger.Cli.Options where-import Control.Exception as C+import qualified Control.Exception as C import Data.List import Data.List.Split import Data.Maybe@@ -19,7 +19,7 @@ import System.Directory import System.Environment import Test.HUnit-import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec as P import Text.Printf  import Hledger@@ -143,7 +143,7 @@  ,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 ["date2","aux-date","effective"]     (\opts -> setboolopt "date2" opts) "use transactions' secondary 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"  ]@@ -189,7 +189,7 @@  ,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  ["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"@@ -213,7 +213,10 @@   modeHelp = "(or postings) show matched postings and running total"  ,modeArgs = ([], Just commandargsflag)  ,modeGroupFlags = Group {-     groupUnnamed = []+     groupUnnamed = [+      flagOpt (show defaultWidthWithFlag) ["width","w"] (\s opts -> Right $ setopt "width" s opts) "N" "increase or set the output width (default: 80)"+     ,flagNone ["related","r"] (\opts -> setboolopt "related" opts) "show the other postings in the transactions of those that would have been shown"+     ]     ,groupHidden = []     ,groupNamed = [(generalflagstitle, generalflags1)]     }@@ -293,6 +296,7 @@     ,alias_           :: [String]     ,debug_           :: Bool     ,no_new_accounts_ :: Bool           -- add+    ,width_           :: Maybe String   -- register     ,reportopts_      :: ReportOpts  } deriving (Show) @@ -305,6 +309,7 @@     def     def     def+    def  instance Default CliOpts where def = defcliopts @@ -322,6 +327,7 @@              ,alias_           = map stripquotes $ listofstringopt "alias" rawopts              ,debug_           = boolopt "debug" rawopts              ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add+             ,width_           = maybestringopt "width" rawopts    -- register              ,reportopts_ = defreportopts {                              begin_     = maybesmartdateopt d "begin" rawopts                             ,end_       = maybesmartdateopt d "end" rawopts@@ -331,7 +337,7 @@                             ,cost_      = boolopt "cost" rawopts                             ,depth_     = maybeintopt "depth" rawopts                             ,display_   = maybedisplayopt d rawopts-                            ,effective_ = boolopt "effective" rawopts+                            ,date2_     = boolopt "date2" rawopts                             ,empty_     = boolopt "empty" rawopts                             ,no_elide_  = boolopt "no-elide" rawopts                             ,real_      = boolopt "real" rawopts@@ -344,6 +350,7 @@                             ,quarterly_ = boolopt "quarterly" rawopts                             ,yearly_    = boolopt "yearly" rawopts                             ,format_    = maybestringopt "format" rawopts+                            ,related_   = boolopt "related" rawopts  -- register                             ,query_     = unwords $ listofstringopt "args" rawopts                             }              }@@ -441,10 +448,13 @@   case formatFromOpts ropts of     Left err -> optserror $ "could not parse format option: "++err     Right _ -> return ()+  case widthFromOpts opts of+    Left err -> optserror $ "could not parse width option: "++err+    Right _ -> return ()   return opts --- | Parse any format option provided, possibly raising an error, or get--- the default value.+-- | Parse the format option if provided, possibly returning an error,+-- otherwise get the default value. formatFromOpts :: ReportOpts -> Either String [FormatString] formatFromOpts = maybe (Right defaultBalanceFormatString) parseFormatString . format_ @@ -456,6 +466,35 @@     , FormatField True (Just 2) Nothing DepthSpacerField     , FormatField True Nothing Nothing AccountField     ]++data OutputWidth = TotalWidth Width | FieldWidths [Width] deriving Show+data Width = Width Int | Auto deriving Show++defaultWidth         = 80+defaultWidthWithFlag = 120++-- | Parse the width option if provided, possibly returning an error,+-- otherwise get the default value.+widthFromOpts :: CliOpts -> Either String OutputWidth+widthFromOpts CliOpts{width_=Nothing} = Right $ TotalWidth $ Width defaultWidth+widthFromOpts CliOpts{width_=Just ""} = Right $ TotalWidth $ Width defaultWidthWithFlag+widthFromOpts CliOpts{width_=Just s}  = parseWidth s++parseWidth :: String -> Either String OutputWidth+parseWidth s = case (runParser outputwidth () "(unknown)") s of+    Left  e -> Left $ show e+    Right x -> Right x++outputwidth :: GenParser Char st OutputWidth+outputwidth =+  try (do w <- width+          ws <- many1 (char ',' >> width)+          return $ FieldWidths $ w:ws)+  <|> TotalWidth `fmap` width++width :: GenParser Char st Width+width = (string "auto" >> return Auto)+    <|> (Width . read) `fmap` many1 digit  -- | Get the (tilde-expanded, absolute) journal file path from options, an environment variable, or a default. journalFilePathFromOpts :: CliOpts -> IO String

@@ -7,7 +7,7 @@ module Hledger.Cli.Register (   register  ,postingsReportAsText- ,showPostingWithBalanceForVty+ -- ,showPostingWithBalanceForVty  ,tests_Hledger_Cli_Register ) where @@ -24,12 +24,12 @@  -- | Print a (posting) register report. register :: CliOpts -> Journal -> IO ()-register CliOpts{reportopts_=ropts} j = do+register opts@CliOpts{reportopts_=ropts} j = do   d <- getCurrentDay-  putStr $ postingsReportAsText ropts $ postingsReport ropts (queryFromOpts d ropts) j+  putStr $ postingsReportAsText opts $ postingsReport ropts (queryFromOpts d ropts) j  -- | Render a register report as plain text suitable for console output.-postingsReportAsText :: ReportOpts -> PostingsReport -> String+postingsReportAsText :: CliOpts -> PostingsReport -> String postingsReportAsText opts = unlines . map (postingsReportItemAsText opts) . snd  tests_postingsReportAsText = [@@ -38,35 +38,50 @@     j <- readJournal'       "2009/01/01 * медвежья шкура\n  расходы:покупки  100\n  актив:наличные\n"     let opts = defreportopts-    (postingsReportAsText opts $ postingsReport opts (queryFromOpts (parsedate "2008/11/26") opts) j) `is` unlines-      ["2009/01/01 медвежья шкура       расходы:покупки                 100          100"-      ,"                                актив:наличные                 -100            0"]+    (postingsReportAsText defcliopts $ postingsReport opts (queryFromOpts (parsedate "2008/11/26") opts) j) `is` unlines+      ["2009/01/01 медвежья шкура       расходы:покупки                100           100"+      ,"                                актив:наличные                -100             0"]  ] --- | Render one register report line item as plain text. Eg:+-- | Render one register report line item as plain text. Layout is like so: -- @--- date (10)  description (20)     account (22)            amount (11)  balance (12)--- DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa  AAAAAAAAAAA AAAAAAAAAAAA--- ^ displayed for first postings^---   only, otherwise blank+-- <----------------------------- width (default: 80) ---------------------------->+-- date (10)  description (50%)     account (50%)         amount (12)  balance (12)+-- DDDDDDDDDD dddddddddddddddddddd  aaaaaaaaaaaaaaaaaaa  AAAAAAAAAAAA  AAAAAAAAAAAA+--+-- date and description are shown for the first posting of a transaction only. -- @-postingsReportItemAsText :: ReportOpts -> PostingsReportItem -> String-postingsReportItemAsText _ (dd, p, b) = concatTopPadded [datedesc, pstr, " ", bal]+postingsReportItemAsText :: CliOpts -> PostingsReportItem -> String+postingsReportItemAsText opts (mdate, mdesc, p, b) =+  concatTopPadded [date, " ", desc, "  ", acct, "  ", amt, "  ", bal]     where-      datedesc = case dd of Nothing -> replicate datedescwidth ' '-                            Just (da, de) -> printf "%s %s " date desc-                                where-                                  date = showDate da-                                  desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String-          where-            descwidth = datedescwidth - datewidth - 2-            datedescwidth = 32-            datewidth = 10-      pstr = showPostingForRegister p-      bal = padleft 12 (showMixedAmountWithoutPrice b)+      totalwidth = case widthFromOpts opts of+           Left _                       -> defaultWidth -- shouldn't happen+           Right (TotalWidth (Width w)) -> w+           Right (TotalWidth Auto)      -> defaultWidth -- XXX+           Right (FieldWidths _)        -> defaultWidth -- XXX+      datewidth = 10+      amtwidth = 12+      balwidth = 12+      remaining = totalwidth - (datewidth + 1 + 2 + amtwidth + 2 + balwidth)+      (descwidth, acctwidth) | even r    = (r', r')+                             | otherwise = (r', r'+1)+        where r = remaining - 2+              r' = r `div` 2+      date = maybe (replicate datewidth ' ') (printf ("%-"++show datewidth++"s") . showDate) mdate+      desc = maybe (replicate descwidth ' ') (printf ("%-"++show descwidth++"s") . take descwidth . elideRight descwidth) mdesc+      acct = printf ("%-"++(show acctwidth)++"s") a+        where+          a = bracket $ elideAccountName awidth $ paccount p+          (bracket, awidth) = case ptype p of+                               BalancedVirtualPosting -> (\s -> "["++s++"]", acctwidth-2)+                               VirtualPosting -> (\s -> "("++s++")", acctwidth-2)+                               _ -> (id,acctwidth)+      amt = padleft amtwidth $ showMixedAmountWithoutPrice $ pamount p+      bal = padleft balwidth $ showMixedAmountWithoutPrice b  -- XXX-showPostingWithBalanceForVty showtxninfo p b = postingsReportItemAsText defreportopts $ mkpostingsReportItem showtxninfo p b+-- showPostingWithBalanceForVty showtxninfo p b = postingsReportItemAsText defreportopts $ mkpostingsReportItem showtxninfo p b  tests_Hledger_Cli_Register :: Test tests_Hledger_Cli_Register = TestList

@@ -1,3 +1,5 @@+-- {-# OPTIONS_GHC -F -pgmF htfpp #-}+{-# LANGUAGE CPP #-} {- |  A simple test runner for hledger's built-in unit tests.@@ -13,9 +15,19 @@ import Hledger import Hledger.Cli +#ifdef TESTS --- | Run unit tests and exit with success or failure.+import Test.Framework+import {-@ HTF_TESTS @-} Hledger.Read.JournalReader++-- | Run HTF unit tests and exit with success or failure. test' :: CliOpts -> IO ()+test' _opts = htfMain htf_importedTests++#else++-- | Run HUnit unit tests and exit with success or failure.+test' :: CliOpts -> IO () test' opts = do   results <- runTests opts   if errors results > 0 || failures results > 0@@ -39,3 +51,5 @@  -- | All or pattern-matched tests, in the original suites to show hierarchical names. hierarchicalTests opts = filterTests (matchesAccount (queryFromOpts nulldate $ reportopts_ opts) . testName) tests_Hledger_Cli++#endif

@@ -34,7 +34,7 @@ import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff)) import Test.HUnit import Text.Printf-#if __GLASGOW_HASKELL__ >= 706+#if MIN_VERSION_directory(1,2,0) import System.Time (ClockTime(TOD)) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) #endif@@ -103,13 +103,12 @@ fileModificationTime f     | null f = getClockTime     | otherwise = (do--- getModificationTime returned a ClockTime till GHC 7.6 (directory 1.2), now it's UTCTime-#if __GLASGOW_HASKELL__ < 706-        clo <- getModificationTime f-#else+#if MIN_VERSION_directory(1,2,0)         utc <- getModificationTime f         let nom = utcTimeToPOSIXSeconds utc         let clo = TOD (read $ takeWhile (`elem` "0123456789") $ show nom) 0 -- XXX read+#else+        clo <- getModificationTime f #endif         return clo         )@@ -142,7 +141,7 @@ -- indicating whether we did anything. writeFileWithBackupIfChanged :: FilePath -> String -> IO Bool writeFileWithBackupIfChanged f t = do-  s <- readFile f+  s <- readFile' f   if t == s then return False             else backUpFile f >> writeFile f t >> return True @@ -152,7 +151,7 @@ writeFileWithBackup f t = backUpFile f >> writeFile f t  readFileStrictly :: FilePath -> IO String-readFileStrictly f = readFile f >>= \s -> C.evaluate (length s) >> return s+readFileStrictly f = readFile' f >>= \s -> C.evaluate (length s) >> return s  -- | Back up this file with a (incrementing) numbered suffix, or give an error. backUpFile :: FilePath -> IO ()

@@ -1,6 +1,6 @@ name:           hledger -- also in cpp-options below-version: 0.19.3+version: 0.20 category:       Finance synopsis:       The main command-line interface for the hledger accounting tool. description:@@ -18,7 +18,7 @@ homepage:       http://hledger.org bug-reports:    http://code.google.com/p/hledger/issues stability:      beta-tested-with:    GHC==7.0.4, GHC==7.2.2, GHC==7.4.1, GHC==7.6.1+tested-with:    GHC==7.2.2, GHC==7.4.2, GHC==7.6.1 cabal-version:  >= 1.8 build-type:     Simple -- data-dir:       data@@ -41,7 +41,7 @@     Default:       True  library-  cpp-options:    -DVERSION="0.19.3"+  cpp-options:    -DVERSION="0.20"   ghc-options:    -W   -- should be the same as below   exposed-modules:@@ -62,7 +62,7 @@                   Hledger.Cli.Stats   -- should be the same as below   build-depends:-                  hledger-lib == 0.19.3+                  hledger-lib == 0.20                  ,base >= 4.3 && < 5                  -- ,cabal-file-th                  ,containers@@ -110,13 +110,13 @@                   Hledger.Cli.Print                   Hledger.Cli.Register                   Hledger.Cli.Stats-  cpp-options:    -DVERSION="0.19.3"+  cpp-options:    -DVERSION="0.20"   ghc-options:    -W   if flag(threaded)        ghc-options:   -threaded  -- should be the same as above   build-depends:-                  hledger-lib == 0.19.3+                  hledger-lib == 0.20                  ,base >= 4.3 && < 5                  ,containers                  ,cmdargs >= 0.10 && < 0.11