diff --git a/Hledger/Cli.hs b/Hledger/Cli.hs --- a/Hledger/Cli.hs +++ b/Hledger/Cli.hs @@ -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 diff --git a/Hledger/Cli/Add.hs b/Hledger/Cli/Add.hs --- a/Hledger/Cli/Add.hs +++ b/Hledger/Cli/Add.hs @@ -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) + diff --git a/Hledger/Cli/Histogram.hs b/Hledger/Cli/Histogram.hs --- a/Hledger/Cli/Histogram.hs +++ b/Hledger/Cli/Histogram.hs @@ -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 diff --git a/Hledger/Cli/Options.hs b/Hledger/Cli/Options.hs --- a/Hledger/Cli/Options.hs +++ b/Hledger/Cli/Options.hs @@ -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 diff --git a/Hledger/Cli/Register.hs b/Hledger/Cli/Register.hs --- a/Hledger/Cli/Register.hs +++ b/Hledger/Cli/Register.hs @@ -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 diff --git a/Hledger/Cli/Tests.hs b/Hledger/Cli/Tests.hs --- a/Hledger/Cli/Tests.hs +++ b/Hledger/Cli/Tests.hs @@ -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 diff --git a/Hledger/Cli/Utils.hs b/Hledger/Cli/Utils.hs --- a/Hledger/Cli/Utils.hs +++ b/Hledger/Cli/Utils.hs @@ -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 () diff --git a/hledger.cabal b/hledger.cabal --- a/hledger.cabal +++ b/hledger.cabal @@ -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