diff --git a/Commands/Add.hs b/Commands/Add.hs
--- a/Commands/Add.hs
+++ b/Commands/Add.hs
@@ -27,7 +27,7 @@
hPutStrLn stderr
"Enter one or more transactions, which will be added to your ledger file.\n\
\To complete a transaction, enter . as account name. To quit, enter control-d."
- getAndAddTransactions l args `catch` (\e -> if isEOFError e then return () else ioError e)
+ getAndAddTransactions l args `catch` (\e -> unless (isEOFError e) $ ioError e)
-- | Read a number of ledger transactions from the command line,
-- prompting, validating, displaying and appending them to the ledger
@@ -45,7 +45,7 @@
datestr <- askFor "date"
(Just $ showDate today)
(Just $ \s -> null s ||
- (isRight $ parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
+ isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
description <- if null args
then askFor "description" Nothing (Just $ not . null)
else do
@@ -54,7 +54,7 @@
return description
let historymatches = transactionsSimilarTo l description
bestmatch | null historymatches = Nothing
- | otherwise = Just $ snd $ head $ historymatches
+ | otherwise = Just $ snd $ head historymatches
bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch
date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr
getpostingsandvalidate = do
@@ -68,7 +68,7 @@
hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:"
getpostingsandvalidate
either (const retry) return $ balanceLedgerTransaction t
- when (not $ null historymatches)
+ unless (null historymatches)
(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)
@@ -103,15 +103,15 @@
postingtype ('(':_) = VirtualPosting
postingtype _ = RegularPosting
stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse
- validateamount = Just $ \s -> (null s && (not $ null enteredrealps))
- || (isRight $ parse (someamount>>many spacenonewline>>eof) "" s)
+ validateamount = Just $ \s -> (null s && not (null enteredrealps))
+ || isRight (parse (someamount>>many spacenonewline>>eof) "" 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.
askFor :: String -> Maybe String -> Maybe (String -> Bool) -> IO String
askFor prompt def validator = do
- hPutStr stderr $ prompt ++ (maybe "" showdef def) ++ ": "
+ hPutStr stderr $ prompt ++ maybe "" showdef def ++ ": "
hFlush stderr
l <- getLine
let input = if null l then fromMaybe l def else l
@@ -166,14 +166,14 @@
compareStrings (_:[]) "" = 0
compareStrings "" (_:[]) = 0
compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0
-compareStrings s1 s2 = 2.0 * (fromIntegral i) / (fromIntegral u)
+compareStrings s1 s2 = 2.0 * fromIntegral i / fromIntegral u
where
i = length $ intersect pairs1 pairs2
u = length pairs1 + length pairs2
pairs1 = wordLetterPairs $ uppercase s1
pairs2 = wordLetterPairs $ uppercase s2
wordLetterPairs = concatMap letterPairs . words
-letterPairs (a:b:rest) = [a,b]:(letterPairs (b:rest))
+letterPairs (a:b:rest) = [a,b] : letterPairs (b:rest)
letterPairs _ = []
compareLedgerDescriptions s t = compareStrings s' t'
@@ -185,27 +185,9 @@
transactionsSimilarTo l s =
sortBy compareRelevanceAndRecency
$ filter ((> threshold).fst)
- $ [(compareLedgerDescriptions s $ ltdescription t, t) | t <- ts]
+ [(compareLedgerDescriptions s $ ltdescription t, t) | t <- ts]
where
compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,ltdate t2) (n1,ltdate t1)
ts = ledger_txns $ rawledger l
threshold = 0
-{- doctests
-
-@
-$ echo "2009/13/1"|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a bad date is not accepted
-date : date :
-@
-
-@
-$ echo|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a blank date is ok
-date : description:
-@
-
-@
-$ printf "\n\n"|hledger -f /dev/null add 2>&1|tail -1|sed -e's/\[[^]]*\]//g' # a blank description should fail
-date : description: description:
-@
-
--}
diff --git a/Commands/All.hs b/Commands/All.hs
--- a/Commands/All.hs
+++ b/Commands/All.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -cpp #-}
+{-# LANGUAGE CPP #-}
{-|
The Commands package defines all the commands offered by the hledger
@@ -18,7 +18,7 @@
#ifdef VTY
module Commands.UI,
#endif
-#ifdef HAPPS
+#ifdef WEB
module Commands.Web,
#endif
)
@@ -33,6 +33,6 @@
#ifdef VTY
import Commands.UI
#endif
-#ifdef HAPPS
+#ifdef WEB
import Commands.Web
#endif
diff --git a/Commands/Balance.hs b/Commands/Balance.hs
--- a/Commands/Balance.hs
+++ b/Commands/Balance.hs
@@ -1,6 +1,6 @@
-{-|
+{-|
-A ledger-compatible @balance@ command.
+A ledger-compatible @balance@ command.
ledger's balance command is easy to use but not easy to describe
precisely. In the examples below we'll use sample.ledger, which has the
@@ -109,12 +109,12 @@
-- | Print a balance report.
balance :: [Opt] -> [String] -> Ledger -> IO ()
-balance opts args l = putStr $ showBalanceReport opts args l
+balance opts args = putStr . showBalanceReport opts args
-- | Generate a balance report with the specified options for this ledger.
showBalanceReport :: [Opt] -> [String] -> Ledger -> String
showBalanceReport opts _ l = acctsstr ++ totalstr
- where
+ where
acctsstr = unlines $ map showacct interestingaccts
where
showacct = showInterestingAccount l interestingaccts
@@ -122,8 +122,8 @@
acctnames = sort $ tail $ flatten $ treemap aname accttree
accttree = ledgerAccountTree (depthFromOpts opts) l
totalstr | NoTotal `elem` opts = ""
- | not (Empty `elem` opts) && isZeroMixedAmount total = ""
- | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmount total
+ | notElem Empty opts && isZeroMixedAmount total = ""
+ | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmountWithoutPrice total
where
total = sum $ map abalance $ ledgerTopAccounts l
@@ -131,14 +131,14 @@
showInterestingAccount :: Ledger -> [AccountName] -> AccountName -> String
showInterestingAccount l interestingaccts a = concatTopPadded [amt, " ", depthspacer ++ partialname]
where
- amt = padleft 20 $ showMixedAmount $ abalance $ ledgerAccount l a
- -- the depth spacer (indent) is two spaces for each interesting parent
+ amt = padleft 20 $ showMixedAmountWithoutPrice $ abalance $ ledgerAccount l a
parents = parentAccountNames a
interestingparents = filter (`elem` interestingaccts) parents
- depthspacer = replicate (2 * length interestingparents) ' '
+ depthspacer = replicate (indentperlevel * length interestingparents) ' '
+ indentperlevel = 2
-- the partial name is the account's leaf name, prefixed by the
-- names of any boring parents immediately above
- partialname = accountNameFromComponents $ (reverse $ map accountLeafName ps) ++ [accountLeafName a]
+ partialname = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]
where ps = takeWhile boring parents where boring = not . (`elem` interestingparents)
-- | Is the named account considered interesting for this ledger's balance report ?
@@ -154,6 +154,6 @@
notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumTransactions $ atransactions acct
numinterestingsubs = length $ filter isInterestingTree subtrees
where
- isInterestingTree t = treeany (isInteresting opts l . aname) t
+ isInterestingTree = treeany (isInteresting opts l . aname)
subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a
diff --git a/Commands/Convert.hs b/Commands/Convert.hs
--- a/Commands/Convert.hs
+++ b/Commands/Convert.hs
@@ -1,124 +1,316 @@
{-|
-
Convert account data in CSV format (eg downloaded from a bank) to ledger
-format, and print it on stdout.
-
-Usage: hledger convert CSVFILE ACCOUNTNAME RULESFILE
-
-ACCOUNTNAME is the base account to use for transactions. RULESFILE
-provides some rules to help convert the data. It should contain paragraphs
-separated by one blank line. The first paragraph is a single line of five
-comma-separated numbers, which are the csv field positions corresponding
-to the ledger transaction's date, status, code, description, and amount.
-All other paragraphs specify one or more regular expressions, followed by
-the ledger account to use when a transaction's description matches any of
-them. A regexp may optionally have a replacement pattern specified after =.
-Here's an example rules file:
-
-> 0,2,3,4,1
->
-> ATM DEPOSIT
-> assets:bank:checking
->
-> (TO|FROM) SAVINGS
-> assets:bank:savings
->
-> ITUNES
-> BLKBSTR=BLOCKBUSTER
-> expenses:entertainment
-
-Roadmap:
-Support for other formats will be added. To update a ledger file, pipe the
-output into the import command. The rules will move to a hledger config
-file. When no rule matches, accounts will be guessed based on similarity
-to descriptions in the current ledger, with interactive prompting and
-optional rule saving.
-
+format, and print it on stdout. See the manual for more details.
-}
module Commands.Convert where
-import Data.List.Split (splitOn)
-import Options -- (Opt,Debug)
-import Ledger.Types (Ledger,AccountName)
-import Ledger.Utils (strip)
-import System.IO (stderr, hPutStrLn)
-import Text.CSV (parseCSVFromFile)
-import Text.Printf (printf)
+import Options (Opt(Debug))
+import Version (versionstr)
+import Ledger.Types (Ledger,AccountName,LedgerTransaction(..),Posting(..),PostingType(..))
+import Ledger.Utils (strip, spacenonewline, restofline)
+import Ledger.Parse (someamount, emptyCtx, ledgeraccountname)
+import Ledger.Amount (nullmixedamt)
+import System.IO (stderr)
+import Text.CSV (parseCSVFromFile, printCSV)
+import Text.Printf (hPrintf)
import Text.RegexPR (matchRegexPR)
import Data.Maybe
-import Ledger.Dates (firstJust, showDate)
+import Ledger.Dates (firstJust, showDate, parsedate)
import Locale (defaultTimeLocale)
import Data.Time.Format (parseTime)
-import Control.Monad (when)
+import Control.Monad (when, guard)
+import Safe (readDef, readMay)
+import System.Directory (doesFileExist)
+import System.FilePath.Posix (takeBaseName, replaceExtension)
+import Text.ParserCombinators.Parsec
convert :: [Opt] -> [String] -> Ledger -> IO ()
convert opts args _ = do
- when (length args /= 3) (error "please specify a csv file, base account, and import rules file.")
- let [csvfile,baseacct,rulesfile] = args
+ when (null args) $ error "please specify a csv data file."
+ let csvfile = head args
+ csvparse <- parseCSVFromFile 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
+ writeFile rulesfile initialRulesFileContent
+ else
+ hPrintf stderr "using conversion rules file %s\n" rulesfile
rulesstr <- readFile rulesfile
- (fieldpositions,rules) <- parseRules rulesstr
- parse <- parseCSVFromFile csvfile
- let records = case parse of
+ let rules = case parseCsvRules rulesfile rulesstr of
Left e -> error $ show e
- Right rs -> reverse rs
- mapM_ (print_ledger_txn (Debug `elem` opts) (baseacct,fieldpositions,rules)) records
+ Right r -> r
+ when debug $ hPrintf stderr "rules: %s\n" (show rules)
+ mapM_ (printTxn debug rules) records
+rulesFileFor :: FilePath -> FilePath
+rulesFileFor csvfile = replaceExtension csvfile ".rules"
-type Rule = (
- [(String, Maybe String)] -- list of patterns and optional replacements
- ,AccountName -- account name to use for a matched transaction
+initialRulesFileContent :: String
+initialRulesFileContent =
+ "# csv conversion rules file generated by hledger "++versionstr++"\n" ++
+ "# Add rules to this file for more accurate conversion, see\n"++
+ "# http://hledger.org/MANUAL.html#convert\n" ++
+ "\n" ++
+ "base-account assets:bank:checking\n" ++
+ "date-field 0\n" ++
+ "description-field 4\n" ++
+ "amount-field 1\n" ++
+ "currency $\n" ++
+ "\n" ++
+ "# account-assigning rules\n" ++
+ "\n" ++
+ "SPECTRUM\n" ++
+ "expenses:health:gym\n" ++
+ "\n" ++
+ "ITUNES\n" ++
+ "BLKBSTR=BLOCKBUSTER\n" ++
+ "expenses:entertainment\n" ++
+ "\n" ++
+ "(TO|FROM) SAVINGS\n" ++
+ "assets:bank:savings\n"
+
+{- |
+A set of data definitions and account-matching patterns sufficient to
+convert a particular CSV data file into meaningful ledger transactions. See above.
+-}
+data CsvRules = CsvRules {
+ dateField :: Maybe FieldPosition,
+ statusField :: Maybe FieldPosition,
+ codeField :: Maybe FieldPosition,
+ descriptionField :: Maybe FieldPosition,
+ amountField :: Maybe FieldPosition,
+ currencyField :: Maybe FieldPosition,
+ baseCurrency :: Maybe String,
+ baseAccount :: AccountName,
+ accountRules :: [AccountRule]
+} deriving (Show)
+
+nullrules = CsvRules {
+ dateField=Nothing,
+ statusField=Nothing,
+ codeField=Nothing,
+ descriptionField=Nothing,
+ amountField=Nothing,
+ currencyField=Nothing,
+ baseCurrency=Nothing,
+ baseAccount="unknown",
+ accountRules=[]
+}
+
+type FieldPosition = Int
+
+type AccountRule = (
+ [(String, Maybe String)] -- list of regex match patterns with optional replacements
+ ,AccountName -- account name to use for a transaction matching this rule
)
-parseRules :: String -> IO ([Int],[Rule])
-parseRules s = do
- let ls = map strip $ lines s
- let paras = splitOn [""] ls
- let fieldpositions = map read $ splitOn "," $ head $ head paras
- let rules = [(map parsePatRepl $ init ls, last ls) | ls <- tail paras]
- return (fieldpositions,rules)
+type CsvRecord = [String]
-parsePatRepl :: String -> (String, Maybe String)
-parsePatRepl l = case splitOn "=" l of
- (p:r:_) -> (p, Just r)
- _ -> (l, Nothing)
+-- rules file parser
-print_ledger_txn :: Bool -> (String,[Int],[Rule]) -> [String] -> IO ()
-print_ledger_txn debug (baseacct,fieldpositions,rules) record@(_:_:_:_:_:[]) = do
- let [date,_,number,description,amount] = map (record !!) fieldpositions
- amount' = strnegate amount where strnegate ('-':s) = s
- strnegate s = '-':s
- unknownacct | (read amount' :: Double) < 0 = "income:unknown"
+parseCsvRules :: FilePath -> String -> Either ParseError CsvRules
+parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
+
+csvrulesfile :: GenParser Char CsvRules CsvRules
+csvrulesfile = do
+ many blankorcommentline
+ many definitions
+ r <- getState
+ ars <- many accountrule
+ many blankorcommentline
+ 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' [
+ datefield
+ ,statusfield
+ ,codefield
+ ,descriptionfield
+ ,amountfield
+ ,currencyfield
+ ,basecurrency
+ ,baseaccount
+ ,commentline
+ ] "definition"
+ return ()
+
+datefield = do
+ string "date-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{dateField=readMay v}
+
+codefield = do
+ string "code-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{codeField=readMay v}
+
+statusfield = do
+ string "status-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{statusField=readMay v}
+
+descriptionfield = do
+ string "description-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{descriptionField=readMay v}
+
+amountfield = do
+ string "amount-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{amountField=readMay v}
+
+currencyfield = do
+ string "currency-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{currencyField=readMay v}
+
+basecurrency = do
+ string "currency"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{baseCurrency=Just v}
+
+baseaccount = do
+ string "base-account"
+ many1 spacenonewline
+ v <- ledgeraccountname
+ optional newline
+ r <- getState
+ setState r{baseAccount=v}
+
+accountrule :: GenParser Char CsvRules AccountRule
+accountrule = do
+ blanklines
+ many blankorcommentline
+ pats <- many1 matchreplacepattern
+ guard $ length pats >= 2
+ let pats' = init pats
+ acct = either (fail.show) id $ runParser ledgeraccountname () "" $ fst $ last pats
+ many commentline
+ return (pats',acct)
+
+blanklines = many1 blankline >> return ()
+
+blankline = many spacenonewline >> newline >> return () "blank line"
+
+commentchar = oneOf ";#"
+
+commentline = many spacenonewline >> commentchar >> restofline >> return () "comment line"
+
+blankorcommentline = choice' [blankline, commentline]
+
+matchreplacepattern = do
+ notFollowedBy commentchar
+ matchpat <- many1 (noneOf "=\n")
+ replpat <- optionMaybe $ do {char '='; many $ noneOf "\n"}
+ newline
+ return (matchpat,replpat)
+
+printTxn :: Bool -> CsvRules -> CsvRecord -> IO ()
+printTxn debug rules rec = do
+ when debug $ hPrintf stderr "csv: %s" (printCSV [rec])
+ putStr $ show $ transactionFromCsvRecord rules rec
+
+-- csv record conversion
+
+transactionFromCsvRecord :: CsvRules -> CsvRecord -> LedgerTransaction
+transactionFromCsvRecord rules fields =
+ let
+ date = parsedate $ normaliseDate $ maybe "1900/1/1" (fields !!) (dateField rules)
+ status = maybe False (null . strip . (fields !!)) (statusField rules)
+ code = maybe "" (fields !!) (codeField rules)
+ desc = maybe "" (fields !!) (descriptionField rules)
+ comment = ""
+ precomment = ""
+ amountstr = maybe "" (fields !!) (amountField rules)
+ amountstr' = strnegate amountstr where strnegate ('-':s) = s
+ strnegate s = '-':s
+ currency = maybe (fromMaybe "" $ baseCurrency rules) (fields !!) (currencyField rules)
+ amountstr'' = currency ++ amountstr'
+ amountparse = runParser someamount emptyCtx "" amountstr''
+ amount = either (const nullmixedamt) id amountparse
+ unknownacct | (readDef 0 amountstr' :: Double) < 0 = "income:unknown"
| otherwise = "expenses:unknown"
- (acct,desc) = choose_acct_desc rules (unknownacct,description)
- when (debug) $ hPutStrLn stderr $ printf "using %s for %s" desc description
- putStrLn $ printf "%s%s %s" (fixdate date) (if not (null number) then printf " (%s)" number else "") desc
- putStrLn $ printf " %-30s %15s" acct (printf "$%s" amount' :: String)
- putStrLn $ printf " %s\n" baseacct
-print_ledger_txn True _ record = do
- hPutStrLn stderr $ printf "ignoring %s" $ show record
-print_ledger_txn _ _ _ = return ()
+ (acct,newdesc) = identify (accountRules rules) unknownacct desc
+ in
+ LedgerTransaction {
+ ltdate=date,
+ lteffectivedate=Nothing,
+ ltstatus=status,
+ ltcode=code,
+ ltdescription=newdesc,
+ ltcomment=comment,
+ ltpreceding_comment_lines=precomment,
+ ltpostings=[
+ Posting {
+ pstatus=False,
+ paccount=acct,
+ pamount=amount,
+ pcomment="",
+ ptype=RegularPosting
+ },
+ Posting {
+ pstatus=False,
+ paccount=baseAccount rules,
+ pamount=(-amount),
+ pcomment="",
+ ptype=RegularPosting
+ }
+ ]
+ }
-choose_acct_desc :: [Rule] -> (String,String) -> (String,String)
-choose_acct_desc rules (acct,desc) | null matchingrules = (acct,desc)
- | otherwise = (a,d)
+-- | Convert some date string with unknown format to YYYY/MM/DD.
+normaliseDate :: String -> String
+normaliseDate s = maybe "0000/00/00" showDate $
+ firstJust
+ [parseTime defaultTimeLocale "%Y/%m/%e" s
+ -- can't parse a month without leading 0, try adding one
+ ,parseTime defaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s)
+ ,parseTime defaultTimeLocale "%Y-%m-%e" s
+ ,parseTime defaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s)
+ ,parseTime defaultTimeLocale "%m/%e/%Y" s
+ ,parseTime defaultTimeLocale "%m/%e/%Y" ('0':s)
+ ,parseTime defaultTimeLocale "%m-%e-%Y" s
+ ,parseTime defaultTimeLocale "%m-%e-%Y" ('0':s)
+ ]
+
+-- | Apply account matching rules to a transaction description to obtain
+-- the most appropriate account and a new description.
+identify :: [AccountRule] -> String -> String -> (String,String)
+identify rules defacct desc | null matchingrules = (defacct,desc)
+ | otherwise = (acct,newdesc)
where
- matchingrules = filter ismatch rules :: [Rule]
+ matchingrules = filter ismatch rules :: [AccountRule]
where ismatch = any (isJust . flip matchregex desc . fst) . fst
- (prs,a) = head matchingrules
+ (prs,acct) = head matchingrules
mrs = filter (isJust . fst) $ map (\(p,r) -> (matchregex p desc, r)) prs
(m,repl) = head mrs
matched = fst $ fst $ fromJust m
- d = fromMaybe matched repl
-
-matchregex s = matchRegexPR ("(?i)"++s)
+ newdesc = fromMaybe matched repl
-fixdate :: String -> String
-fixdate s = maybe "0000/00/00" showDate $
- firstJust
- [parseTime defaultTimeLocale "%Y/%m/%d" s
- ,parseTime defaultTimeLocale "%Y-%m-%d" s
- ,parseTime defaultTimeLocale "%m/%d/%Y" s
- ,parseTime defaultTimeLocale "%m-%d-%Y" s
- ]
+matchregex = matchRegexPR . ("(?i)" ++)
diff --git a/Commands/Histogram.hs b/Commands/Histogram.hs
--- a/Commands/Histogram.hs
+++ b/Commands/Histogram.hs
@@ -17,7 +17,7 @@
-- | Print a histogram of some statistic per reporting interval, such as
-- number of transactions per day.
histogram :: [Opt] -> [String] -> Ledger -> IO ()
-histogram opts args l = putStr $ showHistogram opts args l
+histogram opts args = putStr . showHistogram opts args
showHistogram :: [Opt] -> [String] -> Ledger -> String
showHistogram opts args l = concatMap (printDayWith countBar) daytxns
@@ -29,13 +29,14 @@
days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan
daytxns = [(s, filter (isTransactionInDateSpan s) ts) | s <- days]
-- same as Register
+ -- should count raw transactions, not posting transactions
ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l
filterempties
| Empty `elem` opts = id
| otherwise = filter (not . isZeroMixedAmount . tamount)
- matchapats t = matchpats apats $ taccount t
+ matchapats = matchpats apats . taccount
(apats,_) = parsePatternArgs args
- filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth)
+ filterdepth | interval == NoInterval = filter (\t -> accountNameLevel (taccount t) <= depth)
| otherwise = id
depth = depthFromOpts opts
@@ -43,6 +44,6 @@
countBar ts = replicate (length ts) barchar
-total ts = show $ sumTransactions ts
+total = show . sumTransactions
-- totalBar ts = replicate (sumTransactions ts) barchar
diff --git a/Commands/Print.hs b/Commands/Print.hs
--- a/Commands/Print.hs
+++ b/Commands/Print.hs
@@ -14,14 +14,16 @@
-- | Print ledger transactions in standard format.
print' :: [Opt] -> [String] -> Ledger -> IO ()
-print' opts args l = putStr $ showLedgerTransactions opts args l
+print' opts args = putStr . showLedgerTransactions opts args
showLedgerTransactions :: [Opt] -> [String] -> Ledger -> String
-showLedgerTransactions opts args l = concatMap showLedgerTransaction $ filteredtxns
+showLedgerTransactions opts args l = concatMap (showLedgerTransactionForPrint effective) txns
where
- filteredtxns = ledger_txns $
- filterRawLedgerPostingsByDepth depth $
- filterRawLedgerTransactionsByAccount apats $
- rawledger l
+ txns = sortBy (comparing ltdate) $
+ ledger_txns $
+ filterRawLedgerPostingsByDepth depth $
+ filterRawLedgerTransactionsByAccount apats $
+ rawledger l
depth = depthFromOpts opts
+ effective = Effective `elem` opts
(apats,_) = parsePatternArgs args
diff --git a/Commands/Register.hs b/Commands/Register.hs
--- a/Commands/Register.hs
+++ b/Commands/Register.hs
@@ -6,6 +6,7 @@
module Commands.Register
where
+import Data.Function (on)
import Prelude hiding (putStr)
import Ledger
import Options
@@ -14,7 +15,7 @@
-- | Print a register report.
register :: [Opt] -> [String] -> Ledger -> IO ()
-register opts args l = putStr $ showRegisterReport opts args l
+register opts args = putStr . showRegisterReport opts args
{- |
Generate the register report. Each ledger entry is displayed as two or
@@ -33,8 +34,8 @@
| otherwise = showtxns summaryts nulltxn startbal
where
interval = intervalFromOpts opts
- ts = sortBy (comparing tdate) $ filterempties $ filter matchapats $ filterdepth $ ledgerTransactions l
- filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth)
+ ts = sortBy (comparing tdate) $ filterempties $ filtertxns apats $ filterdepth $ ledgerTransactions l
+ filterdepth | interval == NoInterval = filter (\t -> accountNameLevel (taccount t) <= depth)
| otherwise = id
filterempties
| Empty `elem` opts = id
@@ -42,7 +43,6 @@
(precedingts, ts') = break (matchdisplayopt dopt) ts
(displayedts, _) = span (matchdisplayopt dopt) ts'
startbal = sumTransactions precedingts
- matchapats t = matchpats apats $ taccount t
(apats,_) = parsePatternArgs args
matchdisplayopt Nothing _ = True
matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t
@@ -75,7 +75,7 @@
| null ts = []
| otherwise = summaryts'
where
- txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++(showDate $ addDays (-1) e')}
+ txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++ showDate (addDays (-1) e')}
b' = fromMaybe (tdate $ head ts) b
e' = fromMaybe (tdate $ last ts) e
summaryts'
@@ -100,17 +100,21 @@
showtxns (t:ts) tprev bal = this ++ showtxns ts t bal'
where
this = showtxn (t `issame` tprev) t bal'
- issame t1 t2 = tnum t1 == tnum t2
+ issame = (==) `on` tnum
bal' = bal + tamount t
-- | Show one transaction line and balance with or without the entry details.
showtxn :: Bool -> Transaction -> MixedAmount -> String
showtxn omitdesc t b = concatBottomPadded [entrydesc ++ p ++ " ", bal] ++ "\n"
where
- entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc
- date = showDate $ da
- desc = printf "%-20s" $ elideRight 20 de :: String
- p = showPosting $ Posting s a amt "" tt
- bal = padleft 12 (showMixedAmountOrZero b)
+ ledger3ishlayout = False
+ datedescwidth = if ledger3ishlayout then 34 else 32
+ entrydesc = if omitdesc then replicate datedescwidth ' ' else printf "%s %s " date desc
+ date = showDate da
+ datewidth = 10
+ descwidth = datedescwidth - datewidth - 2
+ desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String
+ p = showPostingWithoutPrice $ Posting s a amt "" tt
+ bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)
Transaction{tstatus=s,tdate=da,tdescription=de,taccount=a,tamount=amt,ttype=tt} = t
diff --git a/Commands/Stats.hs b/Commands/Stats.hs
--- a/Commands/Stats.hs
+++ b/Commands/Stats.hs
@@ -1,4 +1,4 @@
-{-|
+{-|
Print some statistics for the ledger.
@@ -19,11 +19,11 @@
putStr $ showStats opts args l today
showStats :: [Opt] -> [String] -> Ledger -> Day -> String
-showStats _ _ l today =
- heading ++ (unlines $ map (\(a,b) -> printf fmt a b) stats)
+showStats _ _ l today =
+ heading ++ unlines (map (uncurry (printf fmt)) stats)
where
heading = underline $ printf "Ledger statistics as of %s" (show today)
- fmt = "%-" ++ (show w1) ++ "s: %-" ++ (show w2) ++ "s"
+ fmt = "%-" ++ show w1 ++ "s: %-" ++ show w2 ++ "s"
w1 = maximum $ map (length . fst) stats
w2 = maximum $ map (length . show . snd) stats
stats = [
@@ -42,7 +42,7 @@
-- Days since reconciliation : %(reconcileelapsed)s
-- Days since last transaction : %(recentelapsed)s
]
- where
+ where
ts = sortBy (comparing ltdate) $ ledger_txns $ rawledger l
lastdate | null ts = Nothing
| otherwise = Just $ ltdate $ last ts
@@ -57,9 +57,9 @@
txnrate | days==0 = 0
| otherwise = fromIntegral tnum / fromIntegral days :: Double
tnum30 = length $ filter withinlast30 ts
- withinlast30 t = (d>=(addDays (-30) today) && (d<=today)) where d = ltdate t
+ withinlast30 t = d >= addDays (-30) today && (d<=today) where d = ltdate t
txnrate30 = fromIntegral tnum30 / 30 :: Double
tnum7 = length $ filter withinlast7 ts
- withinlast7 t = (d>=(addDays (-7) today) && (d<=today)) where d = ltdate t
+ withinlast7 t = d >= addDays (-7) today && (d<=today) where d = ltdate t
txnrate7 = fromIntegral tnum7 / 7 :: Double
diff --git a/Commands/UI.hs b/Commands/UI.hs
--- a/Commands/UI.hs
+++ b/Commands/UI.hs
@@ -7,7 +7,6 @@
module Commands.UI
where
import Graphics.Vty
-import qualified Data.ByteString.Char8 as B
import Ledger
import Options
import Commands.Balance
@@ -22,8 +21,8 @@
-- | The application state when running the ui command.
data AppState = AppState {
av :: Vty -- ^ the vty context
- ,aw :: Int -- ^ window width
- ,ah :: Int -- ^ window height
+ ,aw :: Int -- ^ window width
+ ,ah :: Int -- ^ window height
,amsg :: String -- ^ status message
,aopts :: [Opt] -- ^ command-line opts
,aargs :: [String] -- ^ command-line args
@@ -51,13 +50,13 @@
ui :: [Opt] -> [String] -> Ledger -> IO ()
ui opts args l = do
v <- mkVty
- (w,h) <- getSize v
+ DisplayRegion w h <- display_bounds $ terminal v
let opts' = SubTotal:opts
- let a = enter BalanceScreen $
+ let a = enter BalanceScreen
AppState {
av=v
- ,aw=w
- ,ah=h
+ ,aw=fromIntegral w
+ ,ah=fromIntegral h
,amsg=helpmsg
,aopts=opts'
,aargs=args
@@ -69,16 +68,15 @@
-- | Update the screen, wait for the next event, repeat.
go :: AppState -> IO ()
-go a@AppState{av=av,aw=_,ah=_,abuf=_,amsg=_,aopts=opts,aargs=_,aledger=_} = do
- when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a)
- k <- getEvent av
+go a@AppState{av=av,aopts=opts} = do
+ when (notElem DebugNoUI opts) $ update av (renderScreen a)
+ k <- next_event av
case k of
EvResize x y -> go $ resize x y a
EvKey (KASCII 'l') [MCtrl] -> refresh av >> go a{amsg=helpmsg}
EvKey (KASCII 'b') [] -> go $ resetTrailAndEnter BalanceScreen a
EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter RegisterScreen a
EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter PrintScreen a
- -- EvKey (KASCII 'l') [] -> go $ resetTrailAndEnter LedgerScreen a
EvKey KRight [] -> go $ drilldown a
EvKey KEnter [] -> go $ drilldown a
EvKey KLeft [] -> go $ backout a
@@ -129,7 +127,6 @@
cy = y `mod` ph
sy = y - cy
-
updateCursorY, updateScrollY, updatePosY :: (Int -> Int) -> AppState -> AppState
updateCursorY f a = setCursorY (f $ cursorY a) a
updateScrollY f a = setScrollY (f $ scrollY a) a
@@ -142,7 +139,7 @@
cy' = min cy (y-2)
moveToTop :: AppState -> AppState
-moveToTop a = setPosY 0 a
+moveToTop = setPosY 0
moveToBottom :: AppState -> AppState
moveToBottom a = setPosY (length $ abuf a) a
@@ -215,9 +212,8 @@
enter scr@BalanceScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
enter scr@RegisterScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
enter scr@PrintScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
--- enter scr@LedgerScreen a = updateData $ pushLoc Loc{scr=scr,sy=0,cy=0} a
-resetTrailAndEnter scr a = enter scr $ clearLocs a
+resetTrailAndEnter scr = enter scr . clearLocs
-- | Regenerate the display data appropriate for the current screen.
updateData :: AppState -> AppState
@@ -226,7 +222,6 @@
BalanceScreen -> a{abuf=lines $ showBalanceReport opts [] l, aargs=[]}
RegisterScreen -> a{abuf=lines $ showRegisterReport opts args l}
PrintScreen -> a{abuf=lines $ showLedgerTransactions opts args l}
- -- LedgerScreen -> a{abuf=lines $ rawledgertext l}
backout :: AppState -> AppState
backout a | screen a == BalanceScreen = a
@@ -238,7 +233,6 @@
BalanceScreen -> enter RegisterScreen a{aargs=[currentAccountName a]}
RegisterScreen -> scrollToLedgerTransaction e $ enter PrintScreen a
PrintScreen -> a
- -- LedgerScreen -> a{abuf=lines $ rawledgertext l}
where e = currentLedgerTransaction a
-- | Get the account name currently highlighted by the cursor on the
@@ -255,10 +249,9 @@
(indented, nonindented) = span (" " `isPrefixOf`) $ reverse namestohere
thisbranch = indented ++ take 1 nonindented
anamecomponents = reverse $ map strip $ dropsiblings thisbranch
-
dropsiblings :: [AccountName] -> [AccountName]
dropsiblings [] = []
- dropsiblings (x:xs) = [x] ++ dropsiblings xs'
+ dropsiblings (x:xs) = x : dropsiblings xs'
where
xs' = dropWhile moreindented xs
moreindented = (>= myindent) . indentof
@@ -270,7 +263,7 @@
scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState
scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a
where
- entryfirstline = head $ lines $ showLedgerTransaction $ e
+ entryfirstline = head $ lines $ showLedgerTransaction e
halfph = pageHeight a `div` 2
y = fromMaybe 0 $ findIndex (== entryfirstline) buf
sy = max 0 $ y - halfph
@@ -283,9 +276,9 @@
currentLedgerTransaction a@AppState{aledger=l,abuf=buf} = entryContainingTransaction a t
where
t = safehead nulltxn $ filter ismatch $ ledgerTransactions l
- ismatch t = tdate t == (parsedate $ take 10 datedesc)
- && (take 70 $ showtxn False t nullmixedamt) == (datedesc ++ acctamt)
- datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ [safehead "" rest] ++ reverse above
+ ismatch t = tdate t == parsedate (take 10 datedesc)
+ && take 70 (showtxn False t nullmixedamt) == (datedesc ++ acctamt)
+ datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ safehead "" rest : reverse above
acctamt = drop 32 $ safehead "" rest
safehead d ls = if null ls then d else head ls
(above,rest) = splitAt y buf
@@ -294,63 +287,62 @@
-- | Get the entry which contains the given transaction.
-- Will raise an error if there are problems.
entryContainingTransaction :: AppState -> Transaction -> LedgerTransaction
-entryContainingTransaction AppState{aledger=l} t = (ledger_txns $ rawledger l) !! tnum t
+entryContainingTransaction AppState{aledger=l} t = ledger_txns (rawledger l) !! tnum t
-- renderers
renderScreen :: AppState -> Picture
renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
- pic {pCursor = Cursor cx cy,
- pImage = mainimg
- <->
- renderStatus w msg
- }
+ Picture {pic_cursor = Cursor (fromIntegral cx) (fromIntegral cy)
+ ,pic_image = mainimg
+ <->
+ renderStatus w msg
+ ,pic_background = Background ' ' def_attr
+ }
where
(cx, cy) = (0, cursorY a)
sy = scrollY a
- -- trying for more speed
- mainimg = (vertcat $ map (render defaultattr) above)
- <->
- (render currentlineattr thisline)
- <->
- (vertcat $ map (render defaultattr) below)
- render attr = renderBS attr . B.pack
- (thisline,below) | null rest = (blankline,[])
- | otherwise = (head rest, tail rest)
- (above,rest) = splitAt cy linestorender
- linestorender = map padclipline $ take (h-1) $ drop sy $ buf ++ replicate h blankline
- padclipline l = take w $ l ++ blankline
- blankline = replicate w ' '
-- mainimg = (renderString attr $ unlines $ above)
-- <->
-- (renderString reverseattr $ thisline)
-- <->
-- (renderString attr $ unlines $ below)
--- (above,(thisline:below))
+-- (above,(thisline:below))
-- | null ls = ([],[""])
-- | otherwise = splitAt y ls
-- ls = lines $ fitto w (h-1) $ unlines $ drop as $ buf
+-- trying for more speed
+ mainimg = vert_cat (map (string defaultattr) above)
+ <->
+ string currentlineattr thisline
+ <->
+ vert_cat (map (string defaultattr) below)
+ (thisline,below) | null rest = (blankline,[])
+ | otherwise = (head rest, tail rest)
+ (above,rest) = splitAt cy linestorender
+ linestorender = map padclipline $ take (h-1) $ drop sy $ buf ++ replicate h blankline
+ padclipline = take w . (++ blankline)
+ blankline = replicate w ' '
padClipString :: Int -> Int -> String -> [String]
padClipString h w s = rows
where
rows = map padclipline $ take h $ lines s ++ replicate h blankline
- padclipline l = take w $ l ++ blankline
+ padclipline = take w . (++ blankline)
blankline = replicate w ' '
renderString :: Attr -> String -> Image
-renderString attr s = vertcat $ map (renderBS attr . B.pack) rows
+renderString attr s = vert_cat $ map (string attr) rows
where
rows = lines $ fitto w h s
- w = maximum $ map length $ ls
+ w = maximum $ map length ls
h = length ls
ls = lines s
renderStatus :: Int -> String -> Image
-renderStatus w s = renderBS statusattr (B.pack $ take w (s ++ repeat ' '))
-
+renderStatus w = string statusattr . take w . (++ repeat ' ')
--- the all-important theming engine
+-- the all-important theming engine!
theme = Restrained
@@ -360,32 +352,22 @@
currentlineattr,
statusattr
) = case theme of
- Restrained -> (attr
- ,setBold attr
- ,setRV attr
+ Restrained -> (def_attr
+ ,def_attr `with_style` bold
+ ,def_attr `with_style` reverse_video
)
- Colorful -> (setRV attr
- ,setFG white $ setBG red $ attr
- ,setFG black $ setBG green $ attr
+ Colorful -> (def_attr `with_style` reverse_video
+ ,def_attr `with_fore_color` white `with_back_color` red
+ ,def_attr `with_fore_color` black `with_back_color` green
)
- Blood -> (setRV attr
- ,setFG white $ setBG red $ attr
- ,setRV attr
+ Blood -> (def_attr `with_style` reverse_video
+ ,def_attr `with_fore_color` white `with_back_color` red
+ ,def_attr `with_style` reverse_video
)
-halfbrightattr = setHalfBright attr
-reverseattr = setRV attr
-redattr = setFG red attr
-greenattr = setFG green attr
-reverseredattr = setRV $ setFG red attr
-reversegreenattr= setRV $ setFG green attr
-
--- pic { pCursor = Cursor x y,
--- pImage = renderFill pieceA ' ' w y
--- <->
--- renderHFill pieceA ' ' x <|> renderChar pieceA '@' <|> renderHFill pieceA ' ' (w - x - 1)
--- <->
--- renderFill pieceA ' ' w (h - y - 1)
--- <->
--- renderStatus w msg
--- }
+halfbrightattr = def_attr `with_style` dim
+reverseattr = def_attr `with_style` reverse_video
+redattr = def_attr `with_fore_color` red
+greenattr = def_attr `with_fore_color` green
+reverseredattr = def_attr `with_style` reverse_video `with_fore_color` red
+reversegreenattr= def_attr `with_style` reverse_video `with_fore_color` green
diff --git a/Commands/Web.hs b/Commands/Web.hs
--- a/Commands/Web.hs
+++ b/Commands/Web.hs
@@ -1,155 +1,340 @@
+{-# LANGUAGE FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -F -pgmFtrhsx #-}
{-|
-A happs-based web UI for hledger.
+A web-based UI.
-}
module Commands.Web
where
+import Control.Applicative.Error (Failing(Success,Failure))
import Control.Concurrent
-import Happstack.Server
+import Control.Monad.Reader (ask)
+import Data.IORef (newIORef, atomicModifyIORef)
+import HSP hiding (Request,catch)
+import HSP.HTML (renderAsHTML)
+--import qualified HSX.XMLGenerator (XML)
+import Hack.Contrib.Constants (_TextHtmlUTF8)
+import Hack.Contrib.Response (set_content_type)
+import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))
import Happstack.State.Control (waitForTermination)
-import System.Cmd (system)
-import System.Info (os)
-import System.Exit
import Network.HTTP (urlEncode, urlDecode)
-import Text.XHtml hiding (dir)
-
-import Ledger
+import Network.Loli (loli, io, get, post, html, text, public)
+--import Network.Loli.Middleware.IOConfig (ioconfig)
+import Network.Loli.Type (AppUnit)
+import Network.Loli.Utils (update)
import Options hiding (value)
+import System.Directory (getModificationTime)
+import System.IO.Storage (withStore, putValue, getValue)
+import System.Process (readProcess)
+import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
+import Text.ParserCombinators.Parsec (parse)
+-- import Text.XHtml hiding (dir, text, param, label)
+-- import Text.XHtml.Strict ((<<),(+++),(!))
+import qualified HSP (Request(..))
+import qualified Hack (Env, http)
+import qualified Hack.Contrib.Request (inputs, params, path)
+import qualified Hack.Contrib.Response (redirect)
+-- import qualified Text.XHtml.Strict as H
+
+import Commands.Add (addTransaction)
import Commands.Balance
-import Commands.Register
-import Commands.Print
import Commands.Histogram
-import Utils (filterAndCacheLedgerWithOpts)
+import Commands.Print
+import Commands.Register
+import Ledger
+import Utils (openBrowserOn, readLedgerWithOpts)
+-- import Debug.Trace
+-- strace :: Show a => a -> a
+-- strace a = trace (show a) a
-tcpport = 5000
+tcpport = 5000 :: Int
+homeurl = printf "http://localhost:%d/" tcpport
web :: [Opt] -> [String] -> Ledger -> IO ()
web opts args l = do
- t <- getCurrentLocalTime -- how to get this per request ?
if Debug `elem` opts
then do
-- just run the server in the foreground
putStrLn $ printf "starting web server on port %d in debug mode" tcpport
- simpleHTTP nullConf{port=tcpport} $ webHandlers opts args l t
+ server opts args l
else do
-- start the server (in background, so we can..) then start the web browser
- putStrLn $ printf "starting web server on port %d" tcpport
- tid <- forkIO $ simpleHTTP nullConf{port=tcpport} $ webHandlers opts args l t
+ printf "starting web interface on port %d\n" tcpport
+ tid <- forkIO $ server opts args l
putStrLn "starting web browser"
- openBrowserOn $ printf "http://localhost:%d/" tcpport
+ openBrowserOn homeurl
waitForTermination
putStrLn "shutting down web server..."
killThread tid
putStrLn "shutdown complete"
-webHandlers :: [Opt] -> [String] -> Ledger -> LocalTime -> ServerPartT IO Response
-webHandlers opts args l t = msum
- [
- methodSP GET $ view showBalanceReport
- ,dir "balance" $ view showBalanceReport
- ,dir "register" $ view showRegisterReport
- ,dir "print" $ view showLedgerTransactions
- ,dir "histogram" $ view showHistogram
- ]
- where
- view f = withDataFn rqdata $ render f
- render f (a,p) = renderPage (a,p) $ f opts' args' l'
- where
- opts' = opts ++ [Period p]
- args' = args ++ (map urlDecode $ words a)
- -- re-filter the full ledger with the new opts
- l' = filterAndCacheLedgerWithOpts opts' args' t (rawledgertext l) (rawledger l)
- rqdata = do
- a <- look "a" `mplus` return "" -- filter patterns
- p <- look "p" `mplus` return "" -- reporting period
- return (a,p)
- renderPage :: (String, String) -> String -> ServerPartT IO Response
- renderPage (a,p) s = do
- r <- askRq
- return $ setHeader "Content-Type" "text/html" $ toResponse $ renderHtml $ hledgerview r a p s
+getenv = ask
+response = update
+redirect u c = response $ Hack.Contrib.Response.redirect u c
-{-
-
-
-
-
- %s
--}
-hledgerview :: Request -> String -> String -> String -> Html
-hledgerview r a p' s = body << topbar r a p' +++ pre << s
+reqparam :: Hack.Env -> String -> [String]
+reqparam env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
-topbar :: Request -> String -> String -> Html
-topbar r a p' = concatHtml
- [thediv ! [thestyle "float:right; text-align:right;"] << searchform r a p'
- ,thediv ! [thestyle "width:100%; font-weight:bold;"] << navlinks r a p']
+ledgerFileModifiedTime :: Ledger -> IO ClockTime
+ledgerFileModifiedTime l
+ | null path = getClockTime
+ | otherwise = getModificationTime path `Prelude.catch` \_ -> getClockTime
+ where path = filepath $ rawledger l
-searchform :: Request -> String -> String -> Html
-searchform r a p' =
- form ! [action u] << concatHtml
- [spaceHtml +++ stringToHtml "filter by:" +++ spaceHtml
- ,textfield "a" ! [size s, value a]
- ,spaceHtml
- ,spaceHtml +++ stringToHtml "reporting period:" +++ spaceHtml
- ,textfield "p" ! [size s, value p']
- ,resetlink]
- where
- -- another way to get them
- -- a = fromMaybe "" $ queryValue "a" r
- -- p = fromMaybe "" $ queryValue "p" r
- u = dropWhile (=='/') $ rqUri r
- s = "20"
- resetlink | null a && null p' = noHtml
- | otherwise = spaceHtml +++ anchor ! [href u] << stringToHtml "reset"
+ledgerFileReadTime :: Ledger -> ClockTime
+ledgerFileReadTime l = filereadtime $ rawledger l
-navlinks :: Request -> String -> String -> Html
-navlinks _ a p' =
- concatHtml $ intersperse sep $ map linkto ["balance", "register", "print", "histogram"]
+reload :: Ledger -> IO Ledger
+reload l = do
+ l' <- readLedgerWithOpts [] [] (filepath $ rawledger l)
+ putValue "hledger" "ledger" l'
+ return l'
+
+reloadIfChanged :: [Opt] -> [String] -> Ledger -> IO Ledger
+reloadIfChanged opts _ l = do
+ tmod <- ledgerFileModifiedTime l
+ let tread = ledgerFileReadTime l
+ newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
+ -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)
+ if newer
+ then do
+ when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (filepath $ rawledger l)
+ reload l
+ else return l
+
+-- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger
+-- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (rawledgertext l) (rawledger l)
+
+server :: [Opt] -> [String] -> Ledger -> IO ()
+server opts args l =
+ -- server initialisation
+ withStore "hledger" $ do -- IO ()
+ putValue "hledger" "ledger" l
+ -- XXX hack-happstack abstraction leak
+ hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"
+ runWithConfig (ServerConf tcpport hostname) $ -- (Env -> IO Response) -> IO ()
+ \env -> do -- IO Response
+ -- general request handler
+ printf $ "request\n"
+ let a = intercalate "+" $ reqparam env "a"
+ p = intercalate "+" $ reqparam env "p"
+ opts' = opts ++ [Period p]
+ args' = args ++ (map urlDecode $ words a)
+ l' <- fromJust `fmap` getValue "hledger" "ledger"
+ l'' <- reloadIfChanged opts' args' l'
+ -- declare path-specific request handlers
+ let command :: [String] -> ([Opt] -> [String] -> Ledger -> String) -> AppUnit
+ command msgs f = string msgs $ f opts' args' l''
+ (loli $ -- State Loli () -> (Env -> IO Response)
+ do
+ get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()
+ get "/register" $ command [] showRegisterReport
+ get "/histogram" $ command [] showHistogram
+ get "/journal" $ ledgerpage [] l'' (showLedgerTransactions opts' args')
+ post "/journal" $ handleAddform l''
+ get "/env" $ getenv >>= (text . show)
+ get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params)
+ get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs)
+ public (Just "Commands/Web") ["/static"]
+ get "/" $ redirect ("journal") Nothing
+ ) env
+
+ledgerpage :: [String] -> Ledger -> (Ledger -> String) -> AppUnit
+ledgerpage msgs l f = do
+ env <- getenv
+ l' <- io $ reloadIfChanged [] [] l
+ hsp msgs $ const <% addform env %>
<% f l' %> <% s %>
+
+-- | A loli directive to serve a hsp template wrapped in the hledger web
+-- layout. The hack environment is passed in to every hsp template as an
+-- argument, since I don't see how to get it within the hsp monad.
+-- A list of messages is also passed, eg for form errors.
+hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
+hsp msgs f = do
+ env <- getenv
+ let contenthsp = f env
+ pagehsp = hledgerpage env msgs title contenthsp
+ html =<< (io $ do
+ hspenv <- hackEnvToHspEnv env
+ (_,xml) <- runHSP html4Strict pagehsp hspenv
+ return $ addDoctype $ applyFixups $ renderAsHTML xml)
+ response $ set_content_type _TextHtmlUTF8
where
- sep = stringToHtml " | "
- linkto s = anchor ! [href (s++q)] << s
- q' = intercalate "&" $
- (if null a then [] else [(("a="++).urlEncode) a]) ++
- (if null p' then [] else [(("p="++).urlEncode) p'])
- q = if null q' then "" else '?':q'
+ title = ""
+ addDoctype = ("\n" ++)
+ applyFixups = gsubRegexPR "\\[NBSP\\]" " "
+ hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
+ hackEnvToHspEnv env = do
+ x <- newIORef 0
+ let req = HSP.Request (reqparam env) (Hack.http env)
+ num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
+ return $ HSPEnv req num
--- queryValues :: String -> Request -> [String]
--- queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r
+-- htmlToHsp :: Html -> HSP XML
+-- htmlToHsp h = return $ cdata $ showHtml h
--- queryValue :: String -> Request -> Maybe String
--- queryValue q r = case filter ((==q).fst) $ rqInputs r of
--- [] -> Nothing
--- is -> Just $ B.unpack $ inputValue $ snd $ head is
+-- views
--- | Attempt to open a web browser on the given url, all platforms.
-openBrowserOn :: String -> IO ExitCode
-openBrowserOn u = trybrowsers browsers u
+hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
+hledgerpage env msgs title content =
+
+
+ <% title %>
+
+
+ <% navbar env %>
+ <% intercalate ", " msgs %>
+ <% content %>
+
+
+
+navbar :: Hack.Env -> HSP XML
+navbar env =
+
+
+getParamOrNull p = fromMaybe "" `fmap` getParam p
+
+navlinks :: Hack.Env -> HSP XML
+navlinks _ = do
+ a <- getParamOrNull "a"
+ p <- getParamOrNull "p"
+ let addparams=(++(printf "?a=%s&p=%s" (urlEncode a) (urlEncode p)))
+ link s = <% s %>
+
+ <% link "journal" %> |
+ <% link "register" %> |
+ <% link "balance" %>
+
+
+searchform :: Hack.Env -> HSP XML
+searchform env = do
+ a <- getParamOrNull "a"
+ p <- getParamOrNull "p"
+ let resetlink | null a && null p = [NBSP]reset
+ where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
+
+
+addform :: Hack.Env -> HSP XML
+addform env = do
+ let inputs = Hack.Contrib.Request.inputs env
+ date = fromMaybe "" $ lookup "date" inputs
+ desc = fromMaybe "" $ lookup "desc" inputs
+
+
+transactionfields :: Int -> Hack.Env -> HSP XML
+transactionfields n env = do
+ let inputs = Hack.Contrib.Request.inputs env
+ acct = fromMaybe "" $ lookup acctvar inputs
+ amt = fromMaybe "" $ lookup amtvar inputs
+
+
+ [NBSP][NBSP]
+ Account:
+
where
- trybrowsers (b:bs) u = do
- e <- system $ printf "%s %s" b u
- case e of
- ExitSuccess -> return ExitSuccess
- ExitFailure _ -> trybrowsers bs u
- trybrowsers [] u = do
- putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers
- putStrLn $ printf "Please open your browser and visit %s" u
- return $ ExitFailure 127
- browsers | os=="darwin" = ["open"]
- | os=="mingw32" = ["start","firefox","safari","opera","iexplore"]
- | otherwise = ["sensible-browser","firefox"]
- -- jeffz: write a ffi binding for it using the Win32 package as a basis
- -- start by adding System/Win32/Shell.hsc and follow the style of any
- -- other module in that directory for types, headers, error handling and
- -- what not.
- -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL);
- -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL);
+ numbered = (++ show n)
+ acctvar = numbered "acct"
+ amtvar = numbered "amt"
+
+handleAddform :: Ledger -> AppUnit
+handleAddform l = do
+ env <- getenv
+ d <- io getCurrentDay
+ handle $ validate env d
+ where
+ validate :: Hack.Env -> Day -> Failing LedgerTransaction
+ validate env today =
+ let inputs = Hack.Contrib.Request.inputs env
+ date = fromMaybe "" $ lookup "date" inputs
+ desc = fromMaybe "" $ lookup "desc" inputs
+ acct1 = fromMaybe "" $ lookup "acct1" inputs
+ amt1 = fromMaybe "" $ lookup "amt1" inputs
+ acct2 = fromMaybe "" $ lookup "acct2" inputs
+ amt2 = fromMaybe "" $ lookup "amt2" inputs
+ validateDate "" = ["missing date"]
+ validateDate _ = []
+ validateDesc "" = ["missing description"]
+ validateDesc _ = []
+ validateAcct1 "" = ["missing account 1"]
+ validateAcct1 _ = []
+ validateAmt1 "" = ["missing amount 1"]
+ validateAmt1 _ = []
+ validateAcct2 "" = ["missing account 2"]
+ validateAcct2 _ = []
+ validateAmt2 _ = []
+ amt1' = either (const missingamt) id $ parse someamount "" amt1
+ amt2' = either (const missingamt) id $ parse someamount "" amt2
+ t = LedgerTransaction {
+ ltdate = parsedate $ fixSmartDateStr today date
+ ,lteffectivedate=Nothing
+ ,ltstatus=False
+ ,ltcode=""
+ ,ltdescription=desc
+ ,ltcomment=""
+ ,ltpostings=[
+ Posting False acct1 amt1' "" RegularPosting
+ ,Posting False acct2 amt2' "" RegularPosting
+ ]
+ ,ltpreceding_comment_lines=""
+ }
+ (t', berr) = case balanceLedgerTransaction t of
+ Right t'' -> (t'', [])
+ Left e -> (t, [e])
+ errs = concat [
+ validateDate date
+ ,validateDesc desc
+ ,validateAcct1 acct1
+ ,validateAmt1 amt1
+ ,validateAcct2 acct2
+ ,validateAmt2 amt2
+ ] ++ berr
+ in
+ case null errs of
+ False -> Failure errs
+ True -> Success t'
+
+ handle :: Failing LedgerTransaction -> AppUnit
+ handle (Failure errs) = hsp errs addform
+ handle (Success t) = do
+ io $ addTransaction l t >> reload l
+ ledgerpage [msg] l (showLedgerTransactions [] [])
+ where msg = printf "Added transaction:\n%s" (show t)
diff --git a/Ledger/AccountName.hs b/Ledger/AccountName.hs
--- a/Ledger/AccountName.hs
+++ b/Ledger/AccountName.hs
@@ -29,28 +29,28 @@
accountNameLevel :: AccountName -> Int
accountNameLevel "" = 0
-accountNameLevel a = (length $ filter (==acctsepchar) a) + 1
+accountNameLevel a = length (filter (==acctsepchar) a) + 1
-- | ["a:b:c","d:e"] -> ["a","a:b","a:b:c","d","d:e"]
expandAccountNames :: [AccountName] -> [AccountName]
-expandAccountNames as = nub $ concat $ map expand as
- where expand as = map accountNameFromComponents (tail $ inits $ accountNameComponents as)
+expandAccountNames as = nub $ concatMap expand as
+ where expand = map accountNameFromComponents . tail . inits . accountNameComponents
-- | ["a:b:c","d:e"] -> ["a","d"]
topAccountNames :: [AccountName] -> [AccountName]
topAccountNames as = [a | a <- expandAccountNames as, accountNameLevel a == 1]
parentAccountName :: AccountName -> AccountName
-parentAccountName a = accountNameFromComponents $ init $ accountNameComponents a
+parentAccountName = accountNameFromComponents . init . accountNameComponents
parentAccountNames :: AccountName -> [AccountName]
parentAccountNames a = parentAccountNames' $ parentAccountName a
where
parentAccountNames' "" = []
- parentAccountNames' a = [a] ++ (parentAccountNames' $ parentAccountName a)
+ parentAccountNames' a = a : parentAccountNames' (parentAccountName a)
isAccountNamePrefixOf :: AccountName -> AccountName -> Bool
-p `isAccountNamePrefixOf` s = ((p ++ [acctsepchar] ) `isPrefixOf` s)
+isAccountNamePrefixOf = isPrefixOf . (++ [acctsepchar])
isSubAccountNameOf :: AccountName -> AccountName -> Bool
s `isSubAccountNameOf` p =
@@ -160,7 +160,7 @@
where
elideparts :: Int -> [String] -> [String] -> [String]
elideparts width done ss
- | (length $ accountNameFromComponents $ done++ss) <= width = done++ss
+ | length (accountNameFromComponents $ done++ss) <= width = done++ss
| length ss > 1 = elideparts width (done++[take 2 $ head ss]) (tail ss)
| otherwise = done++ss
diff --git a/Ledger/Amount.hs b/Ledger/Amount.hs
--- a/Ledger/Amount.hs
+++ b/Ledger/Amount.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE StandaloneDeriving #-}
{-|
An 'Amount' is some quantity of money, shares, or anything else.
@@ -16,25 +17,28 @@
A 'MixedAmount' is zero or more simple amounts:
@
- $50, EUR 3, AAPL 500
- 16h, $13.55, oranges 6
+ $50 + EUR 3
+ 16h + $13.55 + AAPL 500 + 6 oranges
@
-Not implemented:
-Commodities may be convertible or not. A mixed amount containing only
-convertible commodities can be converted to a simple amount. Arithmetic
-examples:
+Amounts often have a price per unit, or conversion rate, in terms of
+another commodity. If present, this is displayed after \@:
@
- $1 - $5 = $-4
- $1 + EUR 0.76 = $2
- EUR0.76 + $1 = EUR 1.52
- EUR0.76 - $1 = 0
- ($5, 2h) + $1 = ($6, 2h)
- ($50, EUR 3, AAPL 500) + ($13.55, oranges 6) = $67.51, AAPL 500, oranges 6
- ($50, EUR 3) * $-1 = $-53.96
- ($50, AAPL 500) * $-1 = error
-@
+ EUR 3 \@ $1.35
+@
+
+A normalised mixed amount has at most one amount in each commodity-price,
+and no zero amounts (or it has just a single zero amount and no others.)
+
+In principle we can convert an amount to any other commodity to which we
+have a known sequence of conversion rates; in practice we only do one
+conversion step (eg to show cost basis with -B).
+
+We can do limited arithmetic with simple or mixed amounts: either
+price-preserving arithmetic with similarly-priced amounts, or
+price-discarding arithmetic which ignores and discards prices.
+
-}
module Ledger.Amount
@@ -46,6 +50,7 @@
instance Show Amount where show = showAmount
instance Show MixedAmount where show = showMixedAmount
+deriving instance Show HistoricalPrice
instance Num Amount where
abs (Amount c q p) = Amount c (abs q) p
@@ -71,14 +76,19 @@
negateAmountPreservingPrice a = (-a){price=price a}
--- | Apply a binary arithmetic operator to two amounts - converting to the
--- second one's commodity, adopting the lowest precision, and discarding
--- any price information. (Using the second commodity is best since sum
--- and other folds start with a no-commodity amount.)
+-- | Apply a binary arithmetic operator to two amounts, converting to the
+-- second one's commodity (and display precision), discarding any price
+-- information. (Using the second commodity is best since sum and other
+-- folds start with a no-commodity amount.)
amountop :: (Double -> Double -> Double) -> Amount -> Amount -> Amount
amountop op a@(Amount _ _ _) (Amount bc bq _) =
- Amount bc ((quantity $ convertAmountTo bc a) `op` bq) Nothing
+ Amount bc (quantity (convertAmountTo bc a) `op` bq) Nothing
+-- | Convert an amount to the specified commodity using the appropriate
+-- exchange rate (which is currently always 1).
+convertAmountTo :: Commodity -> Amount -> Amount
+convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing
+
-- | Convert an amount to the commodity of its saved price, if any.
costOfAmount :: Amount -> Amount
costOfAmount a@(Amount _ _ Nothing) = a
@@ -87,11 +97,6 @@
| otherwise = Amount pc (pq*q) Nothing
where (Amount pc pq _) = head $ amounts price
--- | Convert an amount to the specified commodity using the appropriate
--- exchange rate (which is currently always 1).
-convertAmountTo :: Commodity -> Amount -> Amount
-convertAmountTo c2 (Amount c1 q _) = Amount c2 (q * conversionRate c1 c2) Nothing
-
-- | Get the string representation of an amount, based on its commodity's
-- display settings.
showAmount :: Amount -> String
@@ -106,6 +111,10 @@
price = case pri of (Just pamt) -> " @ " ++ showMixedAmount pamt
Nothing -> ""
+-- | Get the string representation of an amount, without any \@ price.
+showAmountWithoutPrice :: Amount -> String
+showAmountWithoutPrice a = showAmount a{price=Nothing}
+
-- | Get the string representation (of the number part of) of an amount
showAmount' :: Amount -> String
showAmount' (Amount (Commodity {comma=comma,precision=p}) q _) = quantity
@@ -116,22 +125,22 @@
-- | Add thousands-separating commas to a decimal number string
punctuatethousands :: String -> String
punctuatethousands s =
- sign ++ (addcommas int) ++ frac
+ sign ++ addcommas int ++ frac
where
(sign,num) = break isDigit s
(int,frac) = break (=='.') num
addcommas = reverse . concat . intersperse "," . triples . reverse
triples [] = []
- triples l = [take 3 l] ++ (triples $ drop 3 l)
+ triples l = take 3 l : triples (drop 3 l)
-- | Does this amount appear to be zero when displayed with its given precision ?
isZeroAmount :: Amount -> Bool
-isZeroAmount a = null $ filter (`elem` "123456789") $ showAmount a
+isZeroAmount = null . filter (`elem` "123456789") . showAmountWithoutPrice
-- | Is this amount "really" zero, regardless of the display precision ?
-- Since we are using floating point, for now just test to some high precision.
isReallyZeroAmount :: Amount -> Bool
-isReallyZeroAmount a = null $ filter (`elem` "123456789") $ printf "%.10f" $ quantity a
+isReallyZeroAmount = null . filter (`elem` "123456789") . printf "%.10f" . quantity
-- | Access a mixed amount's components.
amounts :: MixedAmount -> [Amount]
@@ -162,9 +171,18 @@
showMixedAmount m = concat $ intersperse "\n" $ map showfixedwidth as
where
(Mixed as) = normaliseMixedAmount m
- width = maximum $ map (length . show) $ as
+ width = maximum $ map (length . show) as
showfixedwidth = printf (printf "%%%ds" width) . show
+-- | Get the string representation of a mixed amount, but without
+-- any \@ prices.
+showMixedAmountWithoutPrice :: MixedAmount -> String
+showMixedAmountWithoutPrice m = concat $ intersperse "\n" $ map showfixedwidth as
+ where
+ (Mixed as) = normaliseMixedAmountIgnoringPrice m
+ width = maximum $ map (length . show) as
+ showfixedwidth = printf (printf "%%%ds" width) . showAmountWithoutPrice
+
-- | Get the string representation of a mixed amount, and if it
-- appears to be all zero just show a bare 0, ledger-style.
showMixedAmountOrZero :: MixedAmount -> String
@@ -172,13 +190,20 @@
| isZeroMixedAmount a = "0"
| otherwise = showMixedAmount a
+-- | Get the string representation of a mixed amount, or a bare 0,
+-- without any \@ prices.
+showMixedAmountOrZeroWithoutPrice :: MixedAmount -> String
+showMixedAmountOrZeroWithoutPrice a
+ | isZeroMixedAmount a = "0"
+ | otherwise = showMixedAmountWithoutPrice a
+
-- | Simplify a mixed amount by combining any component amounts which have
--- the same commodity and the same price. Also removes redundant zero amounts
--- and adds a single zero amount if there are no amounts at all.
+-- the same commodity and the same price. Also removes zero amounts,
+-- or adds a single zero amount if there are no amounts at all.
normaliseMixedAmount :: MixedAmount -> MixedAmount
normaliseMixedAmount (Mixed as) = Mixed as''
where
- as'' = map sumAmountsPreservingPrice $ group $ sort as'
+ as'' = map sumSamePricedAmountsPreservingPrice $ group $ sort as'
sort = sortBy cmpsymbolandprice
cmpsymbolandprice a1 a2 = compare (sym a1,price a1) (sym a2,price a2)
group = groupBy samesymbolandprice
@@ -186,11 +211,29 @@
sym = symbol . commodity
as' | null nonzeros = [head $ zeros ++ [nullamt]]
| otherwise = nonzeros
- (zeros,nonzeros) = partition isZeroAmount as
+ (zeros,nonzeros) = partition isReallyZeroAmount as
-sumAmountsPreservingPrice [] = nullamt
-sumAmountsPreservingPrice as = (sum as){price=price $ head as}
+sumSamePricedAmountsPreservingPrice [] = nullamt
+sumSamePricedAmountsPreservingPrice as = (sum as){price=price $ head as}
+-- | Simplify a mixed amount by combining any component amounts which have
+-- the same commodity, ignoring and discarding their unit prices if any.
+-- Also removes zero amounts, or adds a single zero amount if there are no
+-- amounts at all.
+normaliseMixedAmountIgnoringPrice :: MixedAmount -> MixedAmount
+normaliseMixedAmountIgnoringPrice (Mixed as) = Mixed as''
+ where
+ as'' = map sumAmountsDiscardingPrice $ group $ sort as'
+ group = groupBy samesymbol where samesymbol a1 a2 = sym a1 == sym a2
+ sort = sortBy (comparing sym)
+ sym = symbol . commodity
+ as' | null nonzeros = [head $ zeros ++ [nullamt]]
+ | otherwise = nonzeros
+ where (zeros,nonzeros) = partition isZeroAmount as
+
+sumAmountsDiscardingPrice [] = nullamt
+sumAmountsDiscardingPrice as = (sum as){price=Nothing}
+
-- | Convert a mixed amount's component amounts to the commodity of their
-- saved price, if any.
costOfMixedAmount :: MixedAmount -> MixedAmount
@@ -206,5 +249,5 @@
-- | A temporary value for parsed transactions which had no amount specified.
missingamt :: MixedAmount
-missingamt = Mixed [Amount (Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0}) 0 Nothing]
+missingamt = Mixed [Amount Commodity {symbol="AUTO",side=L,spaced=False,comma=False,precision=0} 0 Nothing]
diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs
--- a/Ledger/Dates.hs
+++ b/Ledger/Dates.hs
@@ -30,7 +30,7 @@
showDate :: Day -> String
-showDate d = formatTime defaultTimeLocale "%Y/%m/%d" d
+showDate = formatTime defaultTimeLocale "%Y/%m/%d"
getCurrentDay :: IO Day
getCurrentDay = do
@@ -38,7 +38,7 @@
return $ localDay (zonedTimeToLocalTime t)
elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a
-elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2
+elapsedSeconds t1 = realToFrac . diffUTCTime t1
-- | Split a DateSpan into one or more consecutive spans at the specified interval.
splitSpan :: Interval -> DateSpan -> [DateSpan]
@@ -60,8 +60,8 @@
where
splitspan' start next (DateSpan (Just b) (Just e))
| b >= e = []
- | otherwise = [DateSpan (Just s) (Just n)]
- ++ splitspan' start next (DateSpan (Just n) (Just e))
+ | otherwise = DateSpan (Just s) (Just n)
+ : splitspan' start next (DateSpan (Just n) (Just e))
where s = start b
n = next s
splitspan' _ _ _ = error "won't happen, avoids warnings"
@@ -242,7 +242,7 @@
lastthisnextthing
]
(y,m,d) <- choice $ map try dateparsers
- return $ (y,m,d)
+ return (y,m,d)
datesepchar = oneOf "/-."
@@ -259,20 +259,21 @@
ymd = do
y <- many1 digit
datesepchar
- m <- many1 digit
- guard (read m <= 12)
+ m <- try (count 2 digit) <|> count 1 digit
+ guard (read m >= 1 && (read m <= 12))
+ -- when (read m < 1 || (read m > 12)) $ fail "bad month number specified"
datesepchar
- d <- many1 digit
- guard (read d <= 31)
- return (y,m,d)
+ d <- try (count 2 digit) <|> count 1 digit
+ when (read d < 1 || (read d > 31)) $ fail "bad day number specified"
+ return $ (y,m,d)
ym :: GenParser Char st SmartDate
ym = do
y <- many1 digit
guard (read y > 12)
datesepchar
- m <- many1 digit
- guard (read m <= 12)
+ m <- try (count 2 digit) <|> count 1 digit
+ guard (read m >= 1 && (read m <= 12))
return (y,m,"")
y :: GenParser Char st SmartDate
@@ -289,11 +290,11 @@
md :: GenParser Char st SmartDate
md = do
- m <- many1 digit
- guard (read m <= 12)
+ m <- try (count 2 digit) <|> count 1 digit
+ guard (read m >= 1 && (read m <= 12))
datesepchar
- d <- many1 digit
- guard (read d <= 31)
+ d <- try (count 2 digit) <|> count 1 digit
+ when (read d < 1 || (read d > 31)) $ fail "bad day number specified"
return ("",m,d)
months = ["january","february","march","april","may","june",
@@ -302,14 +303,14 @@
weekdays = ["monday","tuesday","wednesday","thursday","friday","saturday","sunday"]
weekdayabbrevs = ["mon","tue","wed","thu","fri","sat","sun"]
-monthIndex s = maybe 0 (+1) $ (lowercase s) `elemIndex` months
-monIndex s = maybe 0 (+1) $ (lowercase s) `elemIndex` monthabbrevs
+monthIndex s = maybe 0 (+1) $ lowercase s `elemIndex` months
+monIndex s = maybe 0 (+1) $ lowercase s `elemIndex` monthabbrevs
month :: GenParser Char st SmartDate
month = do
m <- choice $ map (try . string) months
let i = monthIndex m
- return $ ("",show i,"")
+ return ("",show i,"")
mon :: GenParser Char st SmartDate
mon = do
@@ -330,7 +331,7 @@
,string "next"
]
many spacenonewline -- make the space optional for easier scripting
- p <- choice $ [
+ p <- choice [
string "day"
,string "week"
,string "month"
@@ -347,7 +348,7 @@
intervalanddateperiodexpr rdate,
intervalperiodexpr,
dateperiodexpr rdate,
- (return $ (NoInterval,DateSpan Nothing Nothing))
+ (return (NoInterval,DateSpan Nothing Nothing))
]
intervalanddateperiodexpr :: Day -> GenParser Char st (Interval, DateSpan)
@@ -420,4 +421,4 @@
nulldatespan = DateSpan Nothing Nothing
-mkdatespan b e = DateSpan (Just $ parsedate b) (Just $ parsedate e)
+mkdatespan b = DateSpan (Just $ parsedate b) . Just . parsedate
diff --git a/Ledger/IO.hs b/Ledger/IO.hs
--- a/Ledger/IO.hs
+++ b/Ledger/IO.hs
@@ -7,13 +7,14 @@
import Control.Monad.Error
import Ledger.Ledger (cacheLedger)
import Ledger.Parse (parseLedger)
-import Ledger.RawLedger (canonicaliseAmounts,filterRawLedger)
-import Ledger.Types (DateSpan(..),RawLedger,Ledger(..))
+import Ledger.RawLedger (canonicaliseAmounts,filterRawLedger,rawLedgerSelectingDate)
+import Ledger.Types (FilterSpec(..),WhichDate(..),DateSpan(..),RawLedger(..),Ledger(..))
import Ledger.Utils (getCurrentLocalTime)
import System.Directory (getHomeDirectory)
import System.Environment (getEnv)
import System.IO
import System.FilePath (())
+import System.Time (getClockTime)
ledgerenvvar = "LEDGER"
@@ -21,36 +22,22 @@
ledgerdefaultfilename = ".ledger"
timelogdefaultfilename = ".timelog"
--- | A tuple of arguments specifying how to filter a raw ledger file:
---
--- - only include transactions in this date span
---
--- - only include if cleared\/uncleared\/don't care
---
--- - only include if real\/don't care
---
--- - convert all amounts to cost basis
---
--- - only include if matching these account patterns
---
--- - only include if matching these description patterns
-
-type IOArgs = (DateSpan
- ,Maybe Bool
- ,Bool
- ,Bool
- ,[String]
- ,[String]
- )
-
-noioargs = (DateSpan Nothing Nothing, Nothing, False, False, [], [])
+nullfilterspec = FilterSpec {
+ datespan=DateSpan Nothing Nothing
+ ,cleared=Nothing
+ ,real=False
+ ,costbasis=False
+ ,acctpats=[]
+ ,descpats=[]
+ ,whichdate=ActualDate
+ }
-- | Get the user's default ledger file path.
myLedgerPath :: IO String
myLedgerPath =
getEnv ledgerenvvar `catch`
(\_ -> do
- home <- getHomeDirectory
+ home <- getHomeDirectory `catch` (\_ -> return "")
return $ home ledgerdefaultfilename)
-- | Get the user's default timelog file path.
@@ -71,15 +58,16 @@
-- | Read a ledger from this file, with no filtering, or give an error.
readLedger :: FilePath -> IO Ledger
-readLedger = readLedgerWithIOArgs noioargs
+readLedger = readLedgerWithFilterSpec nullfilterspec
--- | Read a ledger from this file, filtering according to the io args,
+-- | Read a ledger from this file, filtering according to the filter spec.,
-- | or give an error.
-readLedgerWithIOArgs :: IOArgs -> FilePath -> IO Ledger
-readLedgerWithIOArgs ioargs f = do
- s <- readFile f
+readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger
+readLedgerWithFilterSpec fspec f = do
+ s <- readFile f
+ t <- getClockTime
rl <- rawLedgerFromString s
- return $ filterAndCacheLedger ioargs s rl
+ return $ filterAndCacheLedger fspec s rl{filepath=f, filereadtime=t}
-- | Read a RawLedger from the given string, using the current time as
-- reference time, or give a parse error.
@@ -89,10 +77,15 @@
liftM (either error id) $ runErrorT $ parseLedger t "(string)" s
-- | Convert a RawLedger to a canonicalised, cached and filtered Ledger.
-filterAndCacheLedger :: IOArgs -> String -> RawLedger -> Ledger
-filterAndCacheLedger (span,cleared,real,costbasis,apats,dpats) rawtext rl =
- (cacheLedger apats
- $ filterRawLedger span dpats cleared real
+filterAndCacheLedger :: FilterSpec -> String -> RawLedger -> Ledger
+filterAndCacheLedger (FilterSpec{datespan=datespan,cleared=cleared,real=real,
+ costbasis=costbasis,acctpats=acctpats,
+ descpats=descpats,whichdate=whichdate})
+ rawtext
+ rl =
+ (cacheLedger acctpats
+ $ filterRawLedger datespan descpats cleared real
+ $ rawLedgerSelectingDate whichdate
$ canonicaliseAmounts costbasis rl
){rawledgertext=rawtext}
diff --git a/Ledger/Ledger.hs b/Ledger/Ledger.hs
--- a/Ledger/Ledger.hs
+++ b/Ledger/Ledger.hs
@@ -39,7 +39,7 @@
> Node {rootLabel = Account top with 0 txns and 0 balance, subForest = [...
> > accounttreeat l (account l "assets")
> Just (Node {rootLabel = Account assets with 0 txns and $-1 balance, ...
-> > datespan l
+> > datespan l -- disabled
> DateSpan (Just 2008-01-01) (Just 2009-01-01)
> > rawdatespan l
> DateSpan (Just 2008-01-01) (Just 2009-01-01)
@@ -65,9 +65,9 @@
instance Show Ledger where
show l = printf "Ledger with %d transactions, %d accounts\n%s"
- ((length $ ledger_txns $ rawledger l) +
- (length $ modifier_txns $ rawledger l) +
- (length $ periodic_txns $ rawledger l))
+ (length (ledger_txns $ rawledger l) +
+ length (modifier_txns $ rawledger l) +
+ length (periodic_txns $ rawledger l))
(length $ accountnames l)
(showtree $ accountnametree l)
@@ -91,7 +91,7 @@
groupTransactions ts = (ant,txnsof,exclbalof,inclbalof)
where
txnanames = sort $ nub $ map taccount ts
- ant = accountNameTreeFrom $ expandAccountNames $ txnanames
+ ant = accountNameTreeFrom $ expandAccountNames txnanames
allanames = flatten ant
txnmap = Map.union (transactionsByAccount ts) (Map.fromList [(a,[]) | a <- allanames])
balmap = Map.fromList $ flatten $ calculateBalances ant txnsof
@@ -127,27 +127,27 @@
-- m' = Map.insert "top" sortedts m
filtertxns :: [String] -> [Transaction] -> [Transaction]
-filtertxns apats ts = filter (matchpats apats . taccount) ts
+filtertxns apats = filter (matchpats apats . taccount)
-- | List a ledger's account names.
ledgerAccountNames :: Ledger -> [AccountName]
-ledgerAccountNames l = drop 1 $ flatten $ accountnametree l
+ledgerAccountNames = drop 1 . flatten . accountnametree
-- | Get the named account from a ledger.
ledgerAccount :: Ledger -> AccountName -> Account
-ledgerAccount l a = (accountmap l) ! a
+ledgerAccount = (!) . accountmap
-- | List a ledger's accounts, in tree order
ledgerAccounts :: Ledger -> [Account]
-ledgerAccounts l = drop 1 $ flatten $ ledgerAccountTree 9999 l
+ledgerAccounts = drop 1 . flatten . ledgerAccountTree 9999
-- | List a ledger's top-level accounts, in tree order
ledgerTopAccounts :: Ledger -> [Account]
-ledgerTopAccounts l = map root $ branches $ ledgerAccountTree 9999 l
+ledgerTopAccounts = map root . branches . ledgerAccountTree 9999
-- | Accounts in ledger whose name matches the pattern, in tree order.
ledgerAccountsMatching :: [String] -> Ledger -> [Account]
-ledgerAccountsMatching pats l = filter (matchpats pats . aname) $ accounts l
+ledgerAccountsMatching pats = filter (matchpats pats . aname) . accounts
-- | List a ledger account's immediate subaccounts
ledgerSubAccounts :: Ledger -> Account -> [Account]
@@ -156,7 +156,7 @@
-- | List a ledger's "transactions", ie postings with transaction info attached.
ledgerTransactions :: Ledger -> [Transaction]
-ledgerTransactions l = rawLedgerTransactions $ rawledger l
+ledgerTransactions = rawLedgerTransactions . rawledger
-- | Get a ledger's tree of accounts to the specified depth.
ledgerAccountTree :: Int -> Ledger -> Tree Account
@@ -206,8 +206,8 @@
accounttreeat :: Ledger -> Account -> Maybe (Tree Account)
accounttreeat = ledgerAccountTreeAt
-datespan :: Ledger -> DateSpan
-datespan = ledgerDateSpan
+-- datespan :: Ledger -> DateSpan
+-- datespan = ledgerDateSpan
rawdatespan :: Ledger -> DateSpan
rawdatespan = rawLedgerDateSpan . rawledger
diff --git a/Ledger/LedgerTransaction.hs b/Ledger/LedgerTransaction.hs
--- a/Ledger/LedgerTransaction.hs
+++ b/Ledger/LedgerTransaction.hs
@@ -14,17 +14,18 @@
import Ledger.Amount
-instance Show LedgerTransaction where show = showLedgerTransaction
+instance Show LedgerTransaction where show = showLedgerTransactionUnelided
instance Show ModifierTransaction where
- show t = "= " ++ (mtvalueexpr t) ++ "\n" ++ unlines (map show (mtpostings t))
+ show t = "= " ++ mtvalueexpr t ++ "\n" ++ unlines (map show (mtpostings t))
instance Show PeriodicTransaction where
- show t = "~ " ++ (ptperiodicexpr t) ++ "\n" ++ unlines (map show (ptpostings t))
+ show t = "~ " ++ ptperiodicexpr t ++ "\n" ++ unlines (map show (ptpostings t))
nullledgertxn :: LedgerTransaction
nullledgertxn = LedgerTransaction {
ltdate=parsedate "1900/1/1",
+ lteffectivedate=Nothing,
ltstatus=False,
ltcode="",
ltdescription="",
@@ -50,31 +51,38 @@
@
-}
showLedgerTransaction :: LedgerTransaction -> String
-showLedgerTransaction = showLedgerTransaction' True
+showLedgerTransaction = showLedgerTransaction' True False
showLedgerTransactionUnelided :: LedgerTransaction -> String
-showLedgerTransactionUnelided = showLedgerTransaction' False
+showLedgerTransactionUnelided = showLedgerTransaction' False False
-showLedgerTransaction' :: Bool -> LedgerTransaction -> String
-showLedgerTransaction' elide t =
- unlines $ [description] ++ (showpostings $ ltpostings t) ++ [""]
+showLedgerTransactionForPrint :: Bool -> LedgerTransaction -> String
+showLedgerTransactionForPrint effective = showLedgerTransaction' False effective
+
+showLedgerTransaction' :: Bool -> Bool -> LedgerTransaction -> String
+showLedgerTransaction' elide effective t =
+ unlines $ [description] ++ showpostings (ltpostings t) ++ [""]
where
- description = concat [date, status, code, desc] -- , comment]
- date = showdate $ ltdate t
+ description = concat [date, status, code, desc, comment]
+ date | effective = showdate $ fromMaybe (ltdate t) $ lteffectivedate t
+ | otherwise = showdate (ltdate t) ++ maybe "" showedate (lteffectivedate t)
status = if ltstatus t then " *" else ""
- code = if (length $ ltcode t) > 0 then (printf " (%s)" $ ltcode t) else ""
- desc = " " ++ ltdescription t
- showdate d = printf "%-10s" (showDate d)
+ code = if length (ltcode t) > 0 then printf " (%s)" $ ltcode t else ""
+ desc = ' ' : ltdescription t
+ comment = if null com then "" else " ; " ++ com where com = ltcomment t
+ showdate = printf "%-10s" . showDate
+ showedate = printf "=%s" . showdate
showpostings ps
| elide && length ps > 1 && isLedgerTransactionBalanced t
= map showposting (init ps) ++ [showpostingnoamt (last ps)]
| otherwise = map showposting ps
where
- showposting p = showacct p ++ " " ++ (showamount $ pamount p) ++ (showcomment $ pcomment p)
- showpostingnoamt p = rstrip $ showacct p ++ " " ++ (showcomment $ pcomment p)
- showacct p = " " ++ showstatus p ++ (printf "%-34s" $ showAccountName (Just 34) (ptype p) (paccount p))
+ showposting p = showacct p ++ " " ++ showamount (pamount p) ++ showcomment (pcomment p)
+ showpostingnoamt p = rstrip $ showacct p ++ " " ++ showcomment (pcomment p)
+ showacct p = " " ++ showstatus p ++ printf (printf "%%-%ds" w) (showAccountName Nothing (ptype p) (paccount p))
+ w = maximum $ map (length . paccount) ps
showamount = printf "%12s" . showMixedAmount
- showcomment s = if (length s) > 0 then " ; "++s else ""
+ showcomment s = if null s then "" else " ; "++s
showstatus p = if pstatus p then "* " else ""
-- | Show an account name, clipped to the given width if any, and
@@ -101,11 +109,12 @@
-- return an error message instead.
balanceLedgerTransaction :: LedgerTransaction -> Either String LedgerTransaction
balanceLedgerTransaction t@LedgerTransaction{ltpostings=ps}
- | length missingamounts > 1 = Left $ printerr "could not balance this transaction, too many missing amounts"
+ | length missingamounts' > 1 = Left $ printerr "could not balance this transaction, too many missing amounts"
| not $ isLedgerTransactionBalanced t' = Left $ printerr nonzerobalanceerror
| otherwise = Right t'
where
(withamounts, missingamounts) = partition hasAmount $ filter isReal ps
+ (_, missingamounts') = partition hasAmount ps
t' = t{ltpostings=ps'}
ps' | length missingamounts == 1 = map balance ps
| otherwise = ps
@@ -116,3 +125,9 @@
printerr s = printf "%s:\n%s" s (showLedgerTransactionUnelided t)
nonzerobalanceerror = "could not balance this transaction, amounts do not add up to zero"
+
+-- | Convert the primary date to either the actual or effective date.
+ledgerTransactionWithDate :: WhichDate -> LedgerTransaction -> LedgerTransaction
+ledgerTransactionWithDate ActualDate t = t
+ledgerTransactionWithDate EffectiveDate t = t{ltdate=fromMaybe (ltdate t) (lteffectivedate t)}
+
diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs
--- a/Ledger/Parse.hs
+++ b/Ledger/Parse.hs
@@ -6,14 +6,13 @@
module Ledger.Parse
where
-import Prelude hiding (readFile, putStr, print)
-import Control.Monad.Error
+import Prelude hiding (readFile, putStr, putStrLn, print, getContents)
+import Control.Monad.Error (ErrorT(..), MonadIO, liftIO, throwError, catchError)
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Char
import Text.ParserCombinators.Parsec.Combinator
import System.Directory
import System.IO.UTF8
-import System.IO (stdin)
import Ledger.Utils
import Ledger.Types
import Ledger.Dates
@@ -65,16 +64,16 @@
-- let's get to it
parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO RawLedger
-parseLedgerFile t "-" = liftIO (hGetContents stdin) >>= parseLedger t "-"
+parseLedgerFile t "-" = liftIO getContents >>= parseLedger t "-"
parseLedgerFile t f = liftIO (readFile f) >>= parseLedger t f
-- | Parses the contents of a ledger file, or gives an error. Requires
-- the current (local) time to calculate any unfinished timelog sessions,
-- we pass it in for repeatability.
parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO RawLedger
-parseLedger reftime inname intxt = do
+parseLedger reftime inname intxt =
case runParser ledgerFile emptyCtx inname intxt of
- Right m -> liftM (rawLedgerConvertTimeLog reftime) $ m `ap` (return rawLedgerEmpty)
+ Right m -> liftM (rawLedgerConvertTimeLog reftime) $ m `ap` return rawLedgerEmpty
Left err -> throwError $ show err
@@ -113,9 +112,9 @@
let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n"
return $ do contents <- expandPath outerPos filename >>= readFileE outerPos
case runParser ledgerFile outerState filename contents of
- Right l -> l `catchError` (\err -> throwError $ inIncluded ++ err)
+ Right l -> l `catchError` (throwError . (inIncluded ++))
Left perr -> throwError $ inIncluded ++ show perr
- where readFileE outerPos filename = ErrorT $ do (liftM Right $ readFile filename) `catch` leftError
+ where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError
where leftError err = return $ Left $ currentPos ++ whileReading ++ show err
currentPos = show outerPos
whileReading = " reading " ++ show filename ++ ":\n"
@@ -252,14 +251,21 @@
return ()
ledgercomment :: GenParser Char st String
-ledgercomment =
- try (do
- char ';'
- many spacenonewline
- many (noneOf "\n")
- )
- <|> return "" "comment"
+ledgercomment = do
+ many1 $ char ';'
+ many spacenonewline
+ many (noneOf "\n")
+ "comment"
+ledgercommentline :: GenParser Char st String
+ledgercommentline = do
+ many spacenonewline
+ s <- ledgercomment
+ optional newline
+ eof
+ return s
+ "comment"
+
ledgerModifierTransaction :: GenParser Char LedgerFileCtx ModifierTransaction
ledgerModifierTransaction = do
char '=' "modifier transaction"
@@ -280,13 +286,13 @@
ledgerHistoricalPrice = do
char 'P' "historical price"
many spacenonewline
- date <- ledgerdate
- many spacenonewline
- symbol1 <- commoditysymbol
+ date <- try (do {LocalTime d _ <- ledgerdatetime; return d}) <|> ledgerdate -- a time is ignored
+ many1 spacenonewline
+ symbol <- commoditysymbol
many spacenonewline
- (Mixed [Amount c q _]) <- someamount
+ price <- someamount
restofline
- return $ HistoricalPrice date symbol1 (symbol c) q
+ return $ HistoricalPrice date symbol price
-- like ledgerAccountBegin, updates the LedgerFileCtx
ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))
@@ -304,24 +310,24 @@
ledgerTransaction :: GenParser Char LedgerFileCtx LedgerTransaction
ledgerTransaction = do
date <- ledgerdate "transaction"
+ edate <- try (ledgereffectivedate "effective date") <|> return Nothing
status <- ledgerstatus
code <- ledgercode
- description <- liftM rstrip (many1 (noneOf ";\n") "description")
- comment <- ledgercomment
+ description <- many1 spacenonewline >> liftM rstrip (many1 (noneOf ";\n") "description")
+ comment <- ledgercomment <|> return ""
restofline
postings <- ledgerpostings
- let t = LedgerTransaction date status code description comment postings ""
+ let t = LedgerTransaction date edate status code description comment postings ""
case balanceLedgerTransaction t of
Right t' -> return t'
Left err -> fail err
ledgerdate :: GenParser Char LedgerFileCtx Day
-ledgerdate = try ledgerfulldate <|> ledgerpartialdate
+ledgerdate = (try ledgerfulldate <|> ledgerpartialdate) "full or partial date"
ledgerfulldate :: GenParser Char LedgerFileCtx Day
ledgerfulldate = do
(y,m,d) <- ymd
- many spacenonewline
return $ fromGregorian (read y) (read m) (read d)
-- | Match a partial M/D date in a ledger. Warning, this terminates the
@@ -329,7 +335,6 @@
ledgerpartialdate :: GenParser Char LedgerFileCtx Day
ledgerpartialdate = do
(_,m,d) <- md
- many spacenonewline
y <- getYear
when (y==Nothing) $ fail "partial date found, but no default year specified"
return $ fromGregorian (fromJust y) (read m) (read d)
@@ -337,25 +342,46 @@
ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime
ledgerdatetime = do
day <- ledgerdate
+ many1 spacenonewline
h <- many1 digit
char ':'
m <- many1 digit
s <- optionMaybe $ do
char ':'
many1 digit
- many spacenonewline
let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s)
return $ LocalTime day tod
+ledgereffectivedate :: GenParser Char LedgerFileCtx (Maybe Day)
+ledgereffectivedate = do
+ char '='
+ edate <- ledgerdate
+ return $ Just edate
+
ledgerstatus :: GenParser Char st Bool
-ledgerstatus = try (do { char '*' "status"; many1 spacenonewline; return True } ) <|> return False
+ledgerstatus = try (do { many1 spacenonewline; char '*' "status"; return True } ) <|> return False
ledgercode :: GenParser Char st String
-ledgercode = try (do { char '(' "code"; code <- anyChar `manyTill` char ')'; many1 spacenonewline; return code } ) <|> return ""
+ledgercode = try (do { many1 spacenonewline; char '(' "code"; code <- anyChar `manyTill` char ')'; return code } ) <|> return ""
+-- Complicated to handle intermixed comment lines.. please make me better.
ledgerpostings :: GenParser Char LedgerFileCtx [Posting]
-ledgerpostings = many1 $ try ledgerposting
+ledgerpostings = do
+ ctx <- getState
+ let parses p = isRight . parseWithCtx ctx p
+ ls <- many1 $ try linebeginningwithspaces
+ let ls' = filter (not . (ledgercommentline `parses`)) ls
+ guard (not $ null ls')
+ return $ map (fromparse . parseWithCtx ctx ledgerposting) ls'
+ "postings"
+linebeginningwithspaces :: GenParser Char st String
+linebeginningwithspaces = do
+ sp <- many1 spacenonewline
+ c <- nonspace
+ cs <- restofline
+ return $ sp ++ (c:cs) ++ "\n"
+
ledgerposting :: GenParser Char LedgerFileCtx Posting
ledgerposting = do
many1 spacenonewline
@@ -364,7 +390,7 @@
let (ptype, account') = (postingTypeFromAccountName account, unbracket account)
amount <- postingamount
many spacenonewline
- comment <- ledgercomment
+ comment <- ledgercomment <|> return ""
restofline
return (Posting status account' amount comment ptype)
@@ -395,8 +421,7 @@
postingamount =
try (do
many1 spacenonewline
- a <- someamount <|> return missingamt
- return a
+ someamount <|> return missingamt
) <|> return missingamt
someamount :: GenParser Char st MixedAmount
@@ -474,7 +499,7 @@
let digitorcomma = digit <|> char ','
first <- digit
rest <- many digitorcomma
- frac <- try (do {char '.'; many digit >>= return}) <|> return ""
+ frac <- try (do {char '.'; many digit}) <|> return ""
return (first:rest,frac)
numberpartsstartingwithpoint :: GenParser Char st (String,String)
@@ -525,8 +550,8 @@
code <- oneOf "bhioO"
many1 spacenonewline
datetime <- ledgerdatetime
- comment <- liftM2 (++) getParentAccount restofline
- return $ TimeLogEntry (read [code]) datetime comment
+ comment <- optionMaybe (many1 spacenonewline >> liftM2 (++) getParentAccount restofline)
+ return $ TimeLogEntry (read [code]) datetime (fromMaybe "" comment)
-- misc parsing
diff --git a/Ledger/Posting.hs b/Ledger/Posting.hs
--- a/Ledger/Posting.hs
+++ b/Ledger/Posting.hs
@@ -22,15 +22,31 @@
nullrawposting = Posting False "" nullmixedamt "" RegularPosting
showPosting :: Posting -> String
-showPosting (Posting _ a amt _ ttype) =
- concatTopPadded [showaccountname a ++ " ", showamount amt]
+showPosting (Posting _ a amt com ttype) =
+ concatTopPadded [showaccountname a ++ " ", showamount amt, comment]
where
- showaccountname = printf "%-22s" . bracket . elideAccountName width
+ ledger3ishlayout = False
+ acctnamewidth = if ledger3ishlayout then 25 else 22
+ showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width
(bracket,width) = case ttype of
- BalancedVirtualPosting -> (\s -> "["++s++"]", 20)
- VirtualPosting -> (\s -> "("++s++")", 20)
- _ -> (id,22)
+ BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)
+ VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)
+ _ -> (id,acctnamewidth)
showamount = padleft 12 . showMixedAmountOrZero
+ comment = if null com then "" else " ; " ++ com
+-- XXX refactor
+showPostingWithoutPrice (Posting _ a amt com ttype) =
+ concatTopPadded [showaccountname a ++ " ", showamount amt, comment]
+ where
+ ledger3ishlayout = False
+ acctnamewidth = if ledger3ishlayout then 25 else 22
+ showaccountname = printf ("%-"++(show acctnamewidth)++"s") . bracket . elideAccountName width
+ (bracket,width) = case ttype of
+ BalancedVirtualPosting -> (\s -> "["++s++"]", acctnamewidth-2)
+ VirtualPosting -> (\s -> "("++s++")", acctnamewidth-2)
+ _ -> (id,acctnamewidth)
+ showamount = padleft 12 . showMixedAmountOrZeroWithoutPrice
+ comment = if null com then "" else " ; " ++ com
isReal :: Posting -> Bool
isReal p = ptype p == RegularPosting
diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs
--- a/Ledger/RawLedger.hs
+++ b/Ledger/RawLedger.hs
@@ -8,11 +8,13 @@
module Ledger.RawLedger
where
import qualified Data.Map as Map
-import Data.Map ((!))
+import Data.Map (findWithDefault, (!))
+import System.Time (ClockTime(TOD))
import Ledger.Utils
import Ledger.Types
import Ledger.AccountName
import Ledger.Amount
+import Ledger.LedgerTransaction (ledgerTransactionWithDate)
import Ledger.Transaction
import Ledger.Posting
import Ledger.TimeLog
@@ -20,9 +22,9 @@
instance Show RawLedger where
show l = printf "RawLedger with %d transactions, %d accounts: %s"
- ((length $ ledger_txns l) +
- (length $ modifier_txns l) +
- (length $ periodic_txns l))
+ (length (ledger_txns l) +
+ length (modifier_txns l) +
+ length (periodic_txns l))
(length accounts)
(show accounts)
-- ++ (show $ rawLedgerTransactions l)
@@ -36,26 +38,27 @@
, historical_prices = []
, final_comment_lines = []
, filepath = ""
+ , filereadtime = TOD 0 0
}
addLedgerTransaction :: LedgerTransaction -> RawLedger -> RawLedger
-addLedgerTransaction t l0 = l0 { ledger_txns = t : (ledger_txns l0) }
+addLedgerTransaction t l0 = l0 { ledger_txns = t : ledger_txns l0 }
addModifierTransaction :: ModifierTransaction -> RawLedger -> RawLedger
-addModifierTransaction mt l0 = l0 { modifier_txns = mt : (modifier_txns l0) }
+addModifierTransaction mt l0 = l0 { modifier_txns = mt : modifier_txns l0 }
addPeriodicTransaction :: PeriodicTransaction -> RawLedger -> RawLedger
-addPeriodicTransaction pt l0 = l0 { periodic_txns = pt : (periodic_txns l0) }
+addPeriodicTransaction pt l0 = l0 { periodic_txns = pt : periodic_txns l0 }
addHistoricalPrice :: HistoricalPrice -> RawLedger -> RawLedger
-addHistoricalPrice h l0 = l0 { historical_prices = h : (historical_prices l0) }
+addHistoricalPrice h l0 = l0 { historical_prices = h : historical_prices l0 }
addTimeLogEntry :: TimeLogEntry -> RawLedger -> RawLedger
-addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : (open_timelog_entries l0) }
+addTimeLogEntry tle l0 = l0 { open_timelog_entries = tle : open_timelog_entries l0 }
rawLedgerTransactions :: RawLedger -> [Transaction]
rawLedgerTransactions = txnsof . ledger_txns
- where txnsof ts = concat $ map flattenLedgerTransaction $ zip ts [1..]
+ where txnsof ts = concatMap flattenLedgerTransaction $ zip ts [1..]
rawLedgerAccountNamesUsed :: RawLedger -> [AccountName]
rawLedgerAccountNamesUsed = accountNamesFromTransactions . rawLedgerTransactions
@@ -64,13 +67,13 @@
rawLedgerAccountNames = sort . expandAccountNames . rawLedgerAccountNamesUsed
rawLedgerAccountNameTree :: RawLedger -> Tree AccountName
-rawLedgerAccountNameTree l = accountNameTreeFrom $ rawLedgerAccountNames l
+rawLedgerAccountNameTree = accountNameTreeFrom . rawLedgerAccountNames
-- | Remove ledger transactions we are not interested in.
-- Keep only those which fall between the begin and end dates, and match
-- the description pattern, and are cleared or real if those options are active.
filterRawLedger :: DateSpan -> [String] -> Maybe Bool -> Bool -> RawLedger -> RawLedger
-filterRawLedger span pats clearedonly realonly =
+filterRawLedger span pats clearedonly realonly =
filterRawLedgerPostingsByRealness realonly .
filterRawLedgerTransactionsByClearedStatus clearedonly .
filterRawLedgerTransactionsByDate span .
@@ -78,71 +81,97 @@
-- | Keep only ledger transactions whose description matches the description patterns.
filterRawLedgerTransactionsByDescription :: [String] -> RawLedger -> RawLedger
-filterRawLedgerTransactionsByDescription pats (RawLedger ms ps ts tls hs f fp) =
- RawLedger ms ps (filter matchdesc ts) tls hs f fp
+filterRawLedgerTransactionsByDescription pats (RawLedger ms ps ts tls hs f fp ft) =
+ RawLedger ms ps (filter matchdesc ts) tls hs f fp ft
where matchdesc = matchpats pats . ltdescription
--- | Keep only ledger transactions which fall between begin and end dates.
+-- | Keep only ledger transactions which fall between begin and end dates.
-- We include transactions on the begin date and exclude transactions on the end
-- date, like ledger. An empty date string means no restriction.
filterRawLedgerTransactionsByDate :: DateSpan -> RawLedger -> RawLedger
-filterRawLedgerTransactionsByDate (DateSpan begin end) (RawLedger ms ps ts tls hs f fp) =
- RawLedger ms ps (filter matchdate ts) tls hs f fp
- where
- matchdate t = (maybe True (ltdate t>=) begin) && (maybe True (ltdate t<) end)
+filterRawLedgerTransactionsByDate (DateSpan begin end) (RawLedger ms ps ts tls hs f fp ft) =
+ RawLedger ms ps (filter matchdate ts) tls hs f fp ft
+ where
+ matchdate t = maybe True (ltdate t>=) begin && maybe True (ltdate t<) end
-- | Keep only ledger transactions which have the requested
-- cleared/uncleared status, if there is one.
filterRawLedgerTransactionsByClearedStatus :: Maybe Bool -> RawLedger -> RawLedger
filterRawLedgerTransactionsByClearedStatus Nothing rl = rl
-filterRawLedgerTransactionsByClearedStatus (Just val) (RawLedger ms ps ts tls hs f fp) =
- RawLedger ms ps (filter ((==val).ltstatus) ts) tls hs f fp
+filterRawLedgerTransactionsByClearedStatus (Just val) (RawLedger ms ps ts tls hs f fp ft) =
+ RawLedger ms ps (filter ((==val).ltstatus) ts) tls hs f fp ft
-- | Strip out any virtual postings, if the flag is true, otherwise do
-- no filtering.
filterRawLedgerPostingsByRealness :: Bool -> RawLedger -> RawLedger
filterRawLedgerPostingsByRealness False l = l
-filterRawLedgerPostingsByRealness True (RawLedger mts pts ts tls hs f fp) =
- RawLedger mts pts (map filtertxns ts) tls hs f fp
+filterRawLedgerPostingsByRealness True (RawLedger mts pts ts tls hs f fp ft) =
+ RawLedger mts pts (map filtertxns ts) tls hs f fp ft
where filtertxns t@LedgerTransaction{ltpostings=ps} = t{ltpostings=filter isReal ps}
-- | Strip out any postings to accounts deeper than the specified depth
-- (and any ledger transactions which have no postings as a result).
filterRawLedgerPostingsByDepth :: Int -> RawLedger -> RawLedger
-filterRawLedgerPostingsByDepth depth (RawLedger mts pts ts tls hs f fp) =
- RawLedger mts pts (filter (not . null . ltpostings) $ map filtertxns ts) tls hs f fp
- where filtertxns t@LedgerTransaction{ltpostings=ps} =
+filterRawLedgerPostingsByDepth depth (RawLedger mts pts ts tls hs f fp ft) =
+ RawLedger mts pts (filter (not . null . ltpostings) $ map filtertxns ts) tls hs f fp ft
+ where filtertxns t@LedgerTransaction{ltpostings=ps} =
t{ltpostings=filter ((<= depth) . accountNameLevel . paccount) ps}
-- | Keep only ledger transactions which affect accounts matched by the account patterns.
filterRawLedgerTransactionsByAccount :: [String] -> RawLedger -> RawLedger
-filterRawLedgerTransactionsByAccount apats (RawLedger ms ps ts tls hs f fp) =
- RawLedger ms ps (filter (any (matchpats apats . paccount) . ltpostings) ts) tls hs f fp
+filterRawLedgerTransactionsByAccount apats (RawLedger ms ps ts tls hs f fp ft) =
+ RawLedger ms ps (filter (any (matchpats apats . paccount) . ltpostings) ts) tls hs f fp ft
+-- | Convert this ledger's transactions' primary date to either their
+-- actual or effective date.
+rawLedgerSelectingDate :: WhichDate -> RawLedger -> RawLedger
+rawLedgerSelectingDate ActualDate rl = rl
+rawLedgerSelectingDate EffectiveDate rl =
+ rl{ledger_txns=map (ledgerTransactionWithDate EffectiveDate) $ ledger_txns rl}
+
-- | Give all a ledger's amounts their canonical display settings. That
-- is, in each commodity, amounts will use the display settings of the
-- first amount detected, and the greatest precision of the amounts
--- detected. Also, amounts are converted to cost basis if that flag is
--- active.
+-- detected.
+-- Also, missing unit prices are added if known from the price history.
+-- Also, amounts are converted to cost basis if that flag is active.
+-- XXX refactor
canonicaliseAmounts :: Bool -> RawLedger -> RawLedger
-canonicaliseAmounts costbasis l@(RawLedger ms ps ts tls hs f fp) = RawLedger ms ps (map fixledgertransaction ts) tls hs f fp
- where
- fixledgertransaction (LedgerTransaction d s c de co ts pr) = LedgerTransaction d s c de co (map fixrawposting ts) pr
- fixrawposting (Posting s ac a c t) = Posting s ac (fixmixedamount a) c t
- fixmixedamount (Mixed as) = Mixed $ map fixamount as
- fixamount = fixcommodity . (if costbasis then costOfAmount else id)
- fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! (symbol $ commodity a)
- canonicalcommoditymap =
- Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols,
+canonicaliseAmounts costbasis rl@(RawLedger ms ps ts tls hs f fp ft) = RawLedger ms ps (map fixledgertransaction ts) tls hs f fp ft
+ where
+ fixledgertransaction (LedgerTransaction d ed s c de co ts pr) = LedgerTransaction d ed s c de co (map fixrawposting ts) pr
+ where
+ fixrawposting (Posting s ac a c t) = Posting s ac (fixmixedamount a) c t
+ fixmixedamount (Mixed as) = Mixed $ map fixamount as
+ fixamount = (if costbasis then costOfAmount else id) . fixprice . fixcommodity
+ fixcommodity a = a{commodity=c} where c = canonicalcommoditymap ! symbol (commodity a)
+ canonicalcommoditymap =
+ Map.fromList [(s,firstc{precision=maxp}) | s <- commoditysymbols,
let cs = commoditymap ! s,
let firstc = head cs,
let maxp = maximum $ map precision cs
]
- commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols]
- commoditieswithsymbol s = filter ((s==) . symbol) commodities
- commoditysymbols = nub $ map symbol commodities
- commodities = map commodity $ concatMap (amounts . tamount) $ rawLedgerTransactions l
+ commoditymap = Map.fromList [(s,commoditieswithsymbol s) | s <- commoditysymbols]
+ commoditieswithsymbol s = filter ((s==) . symbol) commodities
+ commoditysymbols = nub $ map symbol commodities
+ commodities = map commodity (concatMap (amounts . tamount) (rawLedgerTransactions rl)
+ ++ concatMap (amounts . hamount) (historical_prices rl))
+ fixprice :: Amount -> Amount
+ fixprice a@Amount{price=Just _} = a
+ fixprice a@Amount{commodity=c} = a{price=rawLedgerHistoricalPriceFor rl d c}
+ -- | Get the price for a commodity on the specified day from the price database, if known.
+ -- Does only one lookup step, ie will not look up the price of a price.
+ rawLedgerHistoricalPriceFor :: RawLedger -> Day -> Commodity -> Maybe MixedAmount
+ rawLedgerHistoricalPriceFor rl d Commodity{symbol=s} = do
+ let ps = reverse $ filter ((<= d).hdate) $ filter ((s==).hsymbol) $ sortBy (comparing hdate) $ historical_prices rl
+ case ps of (HistoricalPrice{hamount=a}:_) -> Just $ canonicaliseCommodities a
+ _ -> Nothing
+ where
+ canonicaliseCommodities (Mixed as) = Mixed $ map canonicaliseCommodity as
+ where canonicaliseCommodity a@Amount{commodity=Commodity{symbol=s}} =
+ a{commodity=findWithDefault (error "programmer error: canonicaliseCommodity failed") s canonicalcommoditymap}
+
-- | Get just the amounts from a ledger, in the order parsed.
rawLedgerAmounts :: RawLedger -> [MixedAmount]
rawLedgerAmounts = map tamount . rawLedgerTransactions
@@ -162,7 +191,6 @@
}
where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0
-
-- | The (fully specified) date span containing all the raw ledger's transactions,
-- or DateSpan Nothing Nothing if there are none.
rawLedgerDateSpan :: RawLedger -> DateSpan
@@ -183,5 +211,5 @@
match "" = True
match pat = containsRegex (abspat pat) str
negateprefix = "not:"
- isnegativepat pat = negateprefix `isPrefixOf` pat
+ isnegativepat = (negateprefix `isPrefixOf`)
abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat
diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs
--- a/Ledger/TimeLog.hs
+++ b/Ledger/TimeLog.hs
@@ -38,7 +38,7 @@
entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [LedgerTransaction]
entriesFromTimeLogEntries _ [] = []
entriesFromTimeLogEntries now [i]
- | odate > idate = [entryFromTimeLogInOut i o'] ++ entriesFromTimeLogEntries now [i',o]
+ | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now [i',o]
| otherwise = [entryFromTimeLogInOut i o]
where
o = TimeLogEntry Out end ""
@@ -48,8 +48,8 @@
o' = o{tldatetime=itime{localDay=idate, localTimeOfDay=TimeOfDay 23 59 59}}
i' = i{tldatetime=itime{localDay=addDays 1 idate, localTimeOfDay=midnight}}
entriesFromTimeLogEntries now (i:o:rest)
- | odate > idate = [entryFromTimeLogInOut i o'] ++ entriesFromTimeLogEntries now (i':o:rest)
- | otherwise = [entryFromTimeLogInOut i o] ++ entriesFromTimeLogEntries now rest
+ | odate > idate = entryFromTimeLogInOut i o' : entriesFromTimeLogEntries now (i':o:rest)
+ | otherwise = entryFromTimeLogInOut i o : entriesFromTimeLogEntries now rest
where
(itime,otime) = (tldatetime i,tldatetime o)
(idate,odate) = (localDay itime,localDay otime)
@@ -67,6 +67,7 @@
where
t = LedgerTransaction {
ltdate = idate,
+ lteffectivedate = Nothing,
ltstatus = True,
ltcode = "",
ltdescription = showtime itod ++ "-" ++ showtime otod,
diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs
--- a/Ledger/Transaction.hs
+++ b/Ledger/Transaction.hs
@@ -13,7 +13,6 @@
import Ledger.Dates
import Ledger.Utils
import Ledger.Types
-import Ledger.Dates
import Ledger.LedgerTransaction (showAccountName)
import Ledger.Amount
@@ -30,11 +29,11 @@
-- is attached to the transactions to preserve their grouping - it should
-- be unique per entry.
flattenLedgerTransaction :: (LedgerTransaction, Int) -> [Transaction]
-flattenLedgerTransaction (LedgerTransaction d s _ desc _ ps _, n) =
+flattenLedgerTransaction (LedgerTransaction d _ s _ desc _ ps _, n) =
[Transaction n s d desc (paccount p) (pamount p) (ptype p) | p <- ps]
accountNamesFromTransactions :: [Transaction] -> [AccountName]
-accountNamesFromTransactions ts = nub $ map taccount ts
+accountNamesFromTransactions = nub . map taccount
sumTransactions :: [Transaction] -> MixedAmount
sumTransactions = sum . map tamount
diff --git a/Ledger/Types.hs b/Ledger/Types.hs
--- a/Ledger/Types.hs
+++ b/Ledger/Types.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
{-|
Most data types are defined here to avoid import cycles. See the
@@ -26,10 +27,14 @@
where
import Ledger.Utils
import qualified Data.Map as Map
+import System.Time (ClockTime)
+import Data.Typeable (Typeable)
type SmartDate = (String,String,String)
+data WhichDate = ActualDate | EffectiveDate
+
data DateSpan = DateSpan (Maybe Day) (Maybe Day) deriving (Eq,Show,Ord)
data Interval = NoInterval | Daily | Weekly | Monthly | Quarterly | Yearly
@@ -51,7 +56,7 @@
data Amount = Amount {
commodity :: Commodity,
quantity :: Double,
- price :: Maybe MixedAmount -- ^ optional per-unit price for this amount at the time of entry
+ price :: Maybe MixedAmount -- ^ unit price/conversion rate for this amount at posting time
} deriving (Eq)
newtype MixedAmount = Mixed [Amount] deriving (Eq)
@@ -79,6 +84,7 @@
data LedgerTransaction = LedgerTransaction {
ltdate :: Day,
+ lteffectivedate :: Maybe Day,
ltstatus :: Bool,
ltcode :: String,
ltdescription :: String,
@@ -97,10 +103,9 @@
data HistoricalPrice = HistoricalPrice {
hdate :: Day,
- hsymbol1 :: String,
- hsymbol2 :: String,
- hprice :: Double
- } deriving (Eq,Show)
+ hsymbol :: String,
+ hamount :: MixedAmount
+ } deriving (Eq) -- & Show (in Amount.hs)
data RawLedger = RawLedger {
modifier_txns :: [ModifierTransaction],
@@ -109,13 +114,25 @@
open_timelog_entries :: [TimeLogEntry],
historical_prices :: [HistoricalPrice],
final_comment_lines :: String,
- filepath :: FilePath
+ filepath :: FilePath,
+ filereadtime :: ClockTime
} deriving (Eq)
+-- | A generic, pure specification of how to filter raw ledger transactions.
+data FilterSpec = FilterSpec {
+ datespan :: DateSpan -- ^ only include transactions in this date span
+ ,cleared :: Maybe Bool -- ^ only include if cleared\/uncleared\/don't care
+ ,real :: Bool -- ^ only include if real\/don't care
+ ,costbasis :: Bool -- ^ convert all amounts to cost basis
+ ,acctpats :: [String] -- ^ only include if matching these account patterns
+ ,descpats :: [String] -- ^ only include if matching these description patterns
+ ,whichdate :: WhichDate -- ^ which dates to use (transaction or effective)
+ }
+
data Transaction = Transaction {
tnum :: Int,
tstatus :: Bool, -- ^ posting status
- tdate :: Day, -- ^ ledger transaction date
+ tdate :: Day, -- ^ transaction date
tdescription :: String, -- ^ ledger transaction description
taccount :: AccountName, -- ^ posting account
tamount :: MixedAmount, -- ^ posting amount
@@ -133,5 +150,5 @@
rawledger :: RawLedger,
accountnametree :: Tree AccountName,
accountmap :: Map.Map AccountName Account
- }
+ } deriving Typeable
diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs
--- a/Ledger/Utils.hs
+++ b/Ledger/Utils.hs
@@ -54,14 +54,10 @@
dropws = dropWhile (`elem` " \t")
elideLeft width s =
- case length s > width of
- True -> ".." ++ (reverse $ take (width - 2) $ reverse s)
- False -> s
+ if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s
elideRight width s =
- case length s > width of
- True -> take (width - 2) s ++ ".."
- False -> s
+ if length s > width then take (width - 2) s ++ ".." else s
underline :: String -> String
underline s = s' ++ replicate (length s) '-' ++ "\n"
@@ -130,14 +126,14 @@
-- | Clip a multi-line string to the specified width and height from the top left.
cliptopleft :: Int -> Int -> String -> String
-cliptopleft w h s = intercalate "\n" $ take h $ map (take w) $ lines s
+cliptopleft w h = intercalate "\n" . take h . map (take w) . lines
-- | Clip and pad a multi-line string to fill the specified width and height.
fitto :: Int -> Int -> String -> String
fitto w h s = intercalate "\n" $ take h $ rows ++ repeat blankline
where
rows = map (fit w) $ lines s
- fit w s = take w $ s ++ repeat ' '
+ fit w = take w . (++ repeat ' ')
blankline = replicate w ' '
-- math
@@ -206,14 +202,14 @@
-- | is predicate true in any node of tree ?
treeany :: (a -> Bool) -> Tree a -> Bool
-treeany f t = (f $ root t) || (any (treeany f) $ branches t)
+treeany f t = f (root t) || any (treeany f) (branches t)
-- treedrop -- remove the leaves which do fulfill predicate.
-- treedropall -- do this repeatedly.
-- | show a compact ascii representation of a tree
showtree :: Show a => Tree a -> String
-showtree = unlines . filter (containsRegex "[^ |]") . lines . drawTree . treemap show
+showtree = unlines . filter (containsRegex "[^ \\|]") . lines . drawTree . treemap show
-- | show a compact ascii representation of a forest
showforest :: Show a => Forest a -> String
@@ -236,16 +232,19 @@
-- parsing
parsewith :: Parser a -> String -> Either ParseError a
-parsewith p ts = parse p "" ts
+parsewith p = parse p ""
+parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a
+parseWithCtx ctx p = runParser p ctx ""
+
fromparse :: Either ParseError a -> a
-fromparse = either (\e -> error $ "parse error at "++(show e)) id
+fromparse = either (\e -> error $ "parse error at "++ show e) id
nonspace :: GenParser Char st Char
nonspace = satisfy (not . isSpace)
spacenonewline :: GenParser Char st Char
-spacenonewline = satisfy (\c -> c `elem` " \v\f\t")
+spacenonewline = satisfy (`elem` " \v\f\t")
restofline :: GenParser Char st String
restofline = anyChar `manyTill` newline
diff --git a/Options.hs b/Options.hs
--- a/Options.hs
+++ b/Options.hs
@@ -1,4 +1,4 @@
-{-# OPTIONS_GHC -cpp #-}
+{-# LANGUAGE CPP #-}
{-|
Command-line options for the application.
-}
@@ -7,7 +7,7 @@
where
import System.Console.GetOpt
import System.Environment
-import Ledger.IO (IOArgs,myLedgerPath,myTimelogPath)
+import Ledger.IO (myLedgerPath,myTimelogPath)
import Ledger.Utils
import Ledger.Types
import Ledger.Dates
@@ -17,10 +17,10 @@
progname = "hledger"
timeprogname = "hours"
-usagehdr = (
+usagehdr =
"Usage: hledger [OPTIONS] [COMMAND [PATTERNS]]\n" ++
" hours [OPTIONS] [COMMAND [PATTERNS]]\n" ++
- " hledger convert CSVFILE ACCOUNTNAME RULESFILE\n" ++
+ " hledger convert CSVFILE\n" ++
"\n" ++
"hledger uses your ~/.ledger or $LEDGER file (or another specified with -f),\n" ++
"while hours uses your ~/.timelog or $TIMELOG file.\n" ++
@@ -28,16 +28,16 @@
"COMMAND is one of (may be abbreviated):\n" ++
" add - prompt for new transactions and add them to the ledger\n" ++
" balance - show accounts, with balances\n" ++
- " convert - convert CSV data to ledger format and print on stdout\n" ++
- " histogram - show transaction counts per day or other interval\n" ++
+ " convert - read CSV bank data and display in ledger format\n" ++
+ " histogram - show a barchart of transactions per day or other interval\n" ++
" print - show transactions in ledger format\n" ++
" register - show transactions as a register with running balance\n" ++
" stats - show various statistics for a ledger\n" ++
#ifdef VTY
- " ui - run a simple curses-based text ui\n" ++
+ " ui - run a simple text-based UI\n" ++
#endif
-#ifdef HAPPS
- " web - run a simple web ui\n" ++
+#ifdef WEB
+ " web - run a simple web-based UI\n" ++
#endif
" test - run self-tests\n" ++
"\n" ++
@@ -48,38 +48,39 @@
"DATES can be y/m/d or ledger-style smart dates like \"last month\".\n" ++
"\n" ++
"Options:"
- )
+
usageftr = ""
usage = usageInfo usagehdr options ++ usageftr
-- | Command-line options we accept.
options :: [OptDescr Opt]
options = [
- Option ['f'] ["file"] (ReqArg File "FILE") "use a different ledger/timelog file; - means stdin"
- ,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" ++
+ Option "f" ["file"] (ReqArg File "FILE") "use a different ledger/timelog file; - means stdin"
+ ,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" ++
+ ,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 ['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 [] ["no-total"] (NoArg NoTotal) "balance report: hide the final total"
--- ,Option ['s'] ["subtotal"] (NoArg SubTotal) "balance report: show subaccounts"
- ,Option ['W'] ["weekly"] (NoArg WeeklyOpt) "register report: show weekly summary"
- ,Option ['M'] ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary"
- ,Option ['Q'] ["quarterly"] (NoArg QuarterlyOpt) "register report: show quarterly summary"
- ,Option ['Y'] ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary"
- ,Option ['h'] ["help"] (NoArg Help) "show this help"
- ,Option ['V'] ["version"] (NoArg Version) "show version information"
- ,Option ['v'] ["verbose"] (NoArg Verbose) "show verbose test output"
- ,Option [] ["binary-filename"] (NoArg BinaryFilename) "show the download filename for this hledger build"
- ,Option [] ["debug"] (NoArg Debug) "show some debug output"
- ,Option [] ["debug-no-ui"] (NoArg DebugNoUI) "run ui commands with no output"
+ ,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 "" ["no-total"] (NoArg NoTotal) "balance report: hide the final total"
+-- ,Option "s" ["subtotal"] (NoArg SubTotal) "balance report: show subaccounts"
+ ,Option "W" ["weekly"] (NoArg WeeklyOpt) "register report: show weekly summary"
+ ,Option "M" ["monthly"] (NoArg MonthlyOpt) "register report: show monthly summary"
+ ,Option "Q" ["quarterly"] (NoArg QuarterlyOpt) "register report: show quarterly summary"
+ ,Option "Y" ["yearly"] (NoArg YearlyOpt) "register report: show yearly summary"
+ ,Option "h" ["help"] (NoArg Help) "show this help"
+ ,Option "V" ["version"] (NoArg Version) "show version information"
+ ,Option "v" ["verbose"] (NoArg Verbose) "show verbose test output"
+ ,Option "" ["binary-filename"] (NoArg BinaryFilename) "show the download filename for this hledger build"
+ ,Option "" ["debug"] (NoArg Debug) "show extra debug output; implies verbose"
+ ,Option "" ["debug-no-ui"] (NoArg DebugNoUI) "run ui commands with no output"
]
-- | An option value from a command-line flag.
@@ -93,6 +94,7 @@
CostBasis |
Depth {value::String} |
Display {value::String} |
+ Effective |
Empty |
Real |
NoTotal |
@@ -111,16 +113,16 @@
-- these make me nervous
optsWithConstructor f opts = concatMap get opts
- where get o = if f v == o then [o] else [] where v = value o
+ where get o = [o | f v == o] where v = value o
optsWithConstructors fs opts = concatMap get opts
- where get o = if any (\f -> f == o) fs then [o] else []
+ where get o = [o | any (== o) fs]
optValuesForConstructor f opts = concatMap get opts
- where get o = if f v == o then [v] else [] where v = value o
+ where get o = [v | f v == o] where v = value o
optValuesForConstructors fs opts = concatMap get opts
- where get o = if any (\f -> f v == o) fs then [v] else [] where v = value o
+ where get o = [v | any (\f -> f v == o) fs] where v = value o
-- | Parse the command-line arguments into options, command name, and
-- command arguments. Any dates in the options are converted to explicit
@@ -131,7 +133,8 @@
let (os,as,es) = getOpt Permute options args
-- istimequery <- usingTimeProgramName
-- let os' = if istimequery then (Period "today"):os else os
- os'' <- fixOptDates os
+ os' <- fixOptDates os
+ let os'' = if Debug `elem` os' then Verbose:os' else os'
case (as,es) of
(cmd:args,[]) -> return (os'',cmd,args)
([],[]) -> return (os'',"",[])
@@ -148,7 +151,7 @@
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) ++ "]"
+ where fixbracketeddatestr s = "[" ++ fixSmartDateStr d (init $ tail s) ++ "]"
fixopt _ o = o
-- | Figure out the overall date span we should report on, based on any
@@ -213,7 +216,7 @@
ledgerFilePathFromOpts opts = do
istimequery <- usingTimeProgramName
f <- if istimequery then myTimelogPath else myLedgerPath
- return $ last $ f:(optValuesForConstructor File opts)
+ return $ last $ f : optValuesForConstructor File opts
-- | Gather filter pattern arguments into a list of account patterns and a
-- list of description patterns. We interpret pattern arguments as
@@ -227,13 +230,16 @@
(ds, as) = partition (descprefix `isPrefixOf`) args
ds' = map (drop (length descprefix)) ds
--- | Convert application options to more generic types for the library.
-optsToIOArgs :: [Opt] -> [String] -> LocalTime -> IOArgs
-optsToIOArgs opts args t = (dateSpanFromOpts (localDay t) opts
- ,clearedValueFromOpts opts
- ,Real `elem` opts
- ,CostBasis `elem` opts
- ,apats
- ,dpats
- ) where (apats,dpats) = parsePatternArgs args
+-- | 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
+ ,costbasis=CostBasis `elem` opts
+ ,acctpats=apats
+ ,descpats=dpats
+ ,whichdate = if Effective `elem` opts then EffectiveDate else ActualDate
+ }
+ where (apats,dpats) = parsePatternArgs args
diff --git a/README b/README
--- a/README
+++ b/README
@@ -1,215 +1,33 @@
-hledger User's Guide
-====================
-
-Welcome to hledger!
-
-hledger is a partial haskell clone of John Wiegley's "ledger" command-line
-accounting tool. hledger generates ledger-compatible register & balance
-reports from a plain text ledger file, allows precise batch-mode or
-interactive querying, and demonstrates a pure functional implementation of
-ledger. For more information, see http://hledger.org .
-
-Copyright (c) 2007-2009 Simon Michael and contributors.
-Released under GPL version 3 or later.
-
-Installation
-------------
-
-Platform binaries are not yet being published; you could try asking for
-one on the #ledger channel.
-
-Building hledger requires GHC 6.8 or later (http://haskell.org/ghc).
-hledger should work on any platform which GHC supports.
-Also, installing hledger's dependencies easily requires cabal-install
-version 0.6 or later (http://www.haskell.org/cabal/download.html).
-Once these tools are installed on your system, do::
-
- cabal update
- cabal install hledger [-fvty] [-fhapps]
-
-The vty and happs flags are optional; they enable hledger's "ui" and "web"
-commands respectively. vty is not available on the windows platform.
-
-Usage
------
-
-hledger looks for your ledger file at ~/.ledger by default. To use a
-different file, specify it with the LEDGER environment variable or -f
-option (which may be - for standard input). Basic usage is::
-
- hledger [OPTIONS] [COMMAND [PATTERNS]]
-
-COMMAND is one of balance, print, register, ui, web, test (defaulting to
-balance). PATTERNS are zero or more regular expressions used to filter by
-account name or transaction description. Here are some commands to try::
-
- export LEDGER=sample.ledger
- hledger --help # show usage & options
- hledger balance # all accounts with aggregated balances
- hledger bal --depth 1 # only top-level accounts
- hledger register # transaction register
- hledger reg income # transactions to/from an income account
- hledger reg checking # checking transactions
- hledger reg desc:shop # transactions with shop in the description
- hledger histogram # transactions per day, or other interval
- hledger ui # curses ui, if installed with -fvty
- hledger web # web ui, if installed with -fhapps
- hledger -f new.ledger add # record transactions from the command line
-
-Time reporting
---------------
-
-hledger will also read timelog files in timeclock.el format. If you
-invoke hledger via a symlink or copy named "hours", it looks for your
-timelog file (~/.timelog or $TIMELOG) by default.::
-
- hours [OPTIONS] [COMMAND [PATTERNS]]
-
-Timelog entries look like this::
-
- i 2009/03/31 22:21:45 some:project
- o 2009/04/01 02:00:34
-
-The clockin description is treated as an account name. Here are some
-queries to try::
-
- ln -s `which hledger` ~/bin/hours # set up "hours" in your path
- export TIMELOG=sample.timelog
- hours # show all time balances
- hours -p 'last week' # last week
- hours -p thismonth # the space is optional
- hours -p 'from 1/15' register project # project sessions since jan 15
- hours -p 'weekly' reg --depth 1 -E # weekly time summary
-
-Features
---------
-
-This version of hledger mimics a subset of ledger 3.x, and adds some
-features of its own. We currently support regular ledger entries, timelog
-entries, multiple commodities, virtual transactions, account and
-description filtering, and these commands and options::
-
- Commands:
- balance [REGEXP]... show balance totals for matching accounts
- register [REGEXP]... show register of matching transactions
- print [REGEXP]... print all matching entries
-
- Basic options:
- -h, --help show summarized help
- -f, --file FILE read ledger data from FILE
-
- Report filtering:
- -b, --begin DATE report on entries on or after this date
- -e, --end DATE report on entries prior to this date
- -p, --period EXPR report on entries during the specified period
- and/or with the specified reporting interval
- -C, --cleared report only on cleared entries
- -R, --real report only on real (non-virtual) transactions
-
- Output customization:
- -B, --basis, --cost report cost of commodities
- -d, --display EXPR display only transactions matching EXPR (limited support)
- -E, --empty show empty/zero things which are normally elided
- --no-total balance report: hide the final total
- -W, --weekly register report: show weekly summary
- -M, --monthly register report: show monthly summary
- -Y, --yearly register report: show yearly summary
+hledger
+=======
- Misc:
- -V, --version show version information
- -v, --verbose show verbose test output
- --debug show some debug output
- --debug-no-ui run ui commands with no output
+hledger is a computer program for easily tracking money, time, or other
+commodities, using standard accounting principles. It is quite limited in
+features, but reliable. For some, it is a bare-bones, less complex, less
+expensive alternative to Quicken or Microsoft Money.
-We handle (almost) the full period expression syntax, and very limited
-display expressions consisting of a simple date predicate. Also the
-following new commands are supported::
+hledger aims to help both computer experts and every-day users gain clarity in their finances and time management.
+I use it every day to:
- histogram show a barchart of transaction counts per interval
- add record transactions from the command line
- convert convert CSV bank data to ledger journal format
- ui a simple curses ui (only on unix platforms)
- web a simple web ui
- stats report some ledger statistics
- test run self-tests
+- track spending and income
+- see time reports by day/week/month/project
+- get accurate numbers for client billing and tax filing
+- track invoices
-ledger features not supported
-.............................
+Here is a **demo_** of the web interface.
-ledger features not currently supported include: modifier and periodic
-entries, and the following options and commands::
+Here is the **manual_**.
+For support and more technical info, see **`hledger for techies`_** or **`email me`_**.
- Basic options:
- -o, --output FILE write output to FILE
- -i, --init-file FILE initialize ledger using FILE (default: ~/.ledgerrc)
- -a, --account NAME use NAME for the default account (useful with QIF)
-
- Report filtering:
- -c, --current show only current and past entries (not future)
- --period-sort EXPR sort each report period's entries by EXPR
- -U, --uncleared consider only uncleared transactions
- -L, --actual consider only actual (non-automated) transactions
- -r, --related calculate report using related transactions
- --budget generate budget entries based on periodic entries
- --add-budget show all transactions plus the budget
- --unbudgeted show only unbudgeted transactions
- --forecast EXPR generate forecast entries while EXPR is true
- -l, --limit EXPR calculate only transactions matching EXPR
- -t, --amount EXPR use EXPR to calculate the displayed amount
- -T, --total EXPR use EXPR to calculate the displayed total
-
- Output customization:
- -n, --collapse Only show totals in the top-most accounts.
- -s, --subtotal other: show subtotals
- -P, --by-payee show summarized totals by payee
- -x, --comm-as-payee set commodity name as the payee, for reporting
- --dow show a days-of-the-week report
- -S, --sort EXPR sort report according to the value expression EXPR
- -w, --wide for the default register report, use 132 columns
- --head COUNT show only the first COUNT entries (negative inverts)
- --tail COUNT show only the last COUNT entries (negative inverts)
- --pager PAGER send all output through the given PAGER program
- -A, --average report average transaction amount
- -D, --deviation report deviation from the average
- -%, --percentage report balance totals as a percentile of the parent
- --totals in the "xml" report, include running total
- -j, --amount-data print only raw amount data (useful for scripting)
- -J, --total-data print only raw total data
- -y, --date-format STR use STR as the date format (default: %Y/%m/%d)
- -F, --format STR use STR as the format; for each report type, use:
- --balance-format --register-format --print-format
- --plot-amount-format --plot-total-format --equity-format
- --prices-format --wide-register-format
-
- Commodity reporting:
- --price-db FILE sets the price database to FILE (def: ~/.pricedb)
- -L, --price-exp MINS download quotes only if newer than MINS (def: 1440)
- -Q, --download download price information when needed
- -O, --quantity report commodity totals (this is the default)
- -V, --market report last known market value
- -g, --performance report gain/loss for each displayed transaction
- -G, --gain report net gain/loss
-
- Commands:
- xml [REGEXP]... print matching entries in XML format
- equity [REGEXP]... output equity entries for matching accounts
- prices [REGEXP]... display price history for matching commodities
- entry DATE PAYEE AMT output a derived entry, based on the arguments
+Download and try **`hledger for mac`_**, **`hledger for windows`_**, or **hledger for linux (`32 bit intel`_, `64 bit intel`_)**.
-Other differences
-.................
+.. (If you're reading this in plain text, see also README2, MANUAL etc., or http://hledger.org)
-* hledger calls the "note" field "description"
-* hledger recognises description and negative patterns by "desc:" and "not:" prefixes,
- unlike ledger 3's free-form parser
-* hledger keeps differently-priced amounts of the same commodity separate
-* hledger doesn't require a space before command-line option values, eg: -f-
-* hledger's weekly reporting intervals always start on mondays
-* hledger shows start and end dates of the intervals requested, not just the span containing data
-* hledger period expressions don't support "biweekly", "bimonthly", or "every N days/weeks/..."
-* hledger always shows timelog balances in hours
-* hledger splits multi-day timelog sessions at midnight
-* hledger register report always sorts transactions by date
-* hledger doesn't show description comments as part of the description
-* hledger print puts a blank line after the entry, not before it
-* hledger doesn't print trailing spaces after amount-elided postings
+.. _hledger for techies: README2.html
+.. _manual: MANUAL.html
+.. _demo: http://demo.hledger.org
+.. _hledger for mac: http://hledger.org/binaries/hledger-0.6-mac-i386.gz
+.. _hledger for windows: http://hledger.org/binaries/hledger-0.6-win-i386.zip
+.. _32 bit intel: http://hledger.org/binaries/hledger-0.6.1+9-linux-i386.gz
+.. _64 bit intel: http://hledger.org/binaries/hledger-0.6-linux-x86_64.gz
+.. _email me: mailto:simon@joyful.com
diff --git a/Setup.hs b/Setup.hs
--- a/Setup.hs
+++ b/Setup.hs
@@ -1,4 +1,12 @@
#!/usr/bin/env runhaskell
import Distribution.Simple
+import Distribution.Simple.LocalBuildInfo
+import Distribution.PackageDescription
+import System.FilePath
+import System.Process
-main = defaultMain
+main = defaultMainWithHooks $ simpleUserHooks{runTests=runTests'}
+
+runTests' :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO ()
+runTests' _ _ _ lbi = system testprog >> return ()
+ where testprog = buildDir lbi "hledger" "hledger test"
diff --git a/Tests.hs b/Tests.hs
--- a/Tests.hs
+++ b/Tests.hs
@@ -1,67 +1,18 @@
{- |
-hledger's test suite. Most tests are HUnit-based, and defined in the
-@tests@ list below. These tests are built in to hledger and can be run at
-any time with @hledger test@.
-In addition, we have tests in doctest format, which can be run with @make
-doctest@ in the hledger source tree. These have some advantages:
-
-- easier to read and write than hunit, for functional/shell tests
-
-- easier to read multi-line output from failing tests
-
-- can also appear in, and test, docs
-
-and disadvantages:
-
-- not included in hledger's built-in tests
-
-- not platform independent
-
-Here are the hledger doctests (some may reappear in other modules as
-examples):
-
-Run a few with c++ ledger first:
-
-@
-$ ledger -f sample.ledger balance
- $-1 assets
- $1 bank:saving
- $-2 cash
- $2 expenses
- $1 food
- $1 supplies
- $-2 income
- $-1 gifts
- $-1 salary
- $1 liabilities:debts
-@
+This module contains hledger's unit tests. These are built in to hledger,
+and can be run at any time by doing @hledger test@ (or, with a few more
+options, by doing @make unittest@ in the hledger source tree.)
-@
-$ ledger -f sample.ledger balance o
- $1 expenses:food
- $-2 income
- $-1 gifts
- $-1 salary
---------------------
- $-1
-@
+Other kinds of tests:
-Then hledger:
+hledger's functional tests are a set of shell/command-line tests defined
+by .test files in the tests\/ subdirectory. These can be run by doing
+@make functest@ in the hledger source tree.
-@
-$ hledger -f sample.ledger balance
- $-1 assets
- $1 bank:saving
- $-2 cash
- $2 expenses
- $1 food
- $1 supplies
- $-2 income
- $-1 gifts
- $-1 salary
- $1 liabilities:debts
-@
+hledger's doctests are shell tests defined in literal blocks in haddock
+documentation in the source, run by doing @make doctest@ in the hledger
+source tree. They are no longer used, but here is an example:
@
$ hledger -f sample.ledger balance o
@@ -73,128 +24,8 @@
$-1
@
-@
-$ hledger -f sample.ledger balance --depth 1
- $-1 assets
- $2 expenses
- $-2 income
- $1 liabilities
-@
-}
-{-
-@
-$ printf "2009/1/1 a\n b 1.1\n c -1\n" | runhaskell hledger.hs -f- reg 2>&1 ; true
-"-" (line 4, column 1):
-unexpected end of input
-could not balance this transaction, amounts do not add up to zero:
-2009/01/01 a
- b 1.1
- c -1
-
-@
-
-@
-$ printf "2009/1/1 x\n (virtual) 100\n a 1\n b\n" | runhaskell hledger.hs -f- print 2>&1 ; true
-2009/01/01 x
- (virtual) 100
- a 1
- b
-
-@
-
-Unicode input/output tests
-
--- layout of the balance command with unicode names
-@
-$ printf "2009-01-01 проверка\n τράπεζα 10 руб\n नकद\n" | hledger -f - bal
- 10 руб τράπεζα
- -10 руб नकद
-@
-
--- layout of the register command with unicode names
-@
-$ printf "2009-01-01 проверка\n τράπεζα 10 руб\n नकद\n" | hledger -f - reg
-2009/01/01 проверка τράπεζα 10 руб 10 руб
- नकद -10 руб 0
-@
-
--- layout of the print command with unicode names
-@
-$ printf "2009-01-01 проверка\n счёт:первый 1\n счёт:второй\n" | hledger -f - print
-2009/01/01 проверка
- счёт:первый 1
- счёт:второй
-
-@
-
--- search for unicode account names
-@
-$ printf "2009-01-01 проверка\n τράπεζα 10 руб\n नकद\n" | hledger -f - reg τράπ
-2009/01/01 проверка τράπεζα 10 руб 10 руб
-@
-
--- search for unicode descriptions (should choose only the first entry)
-@
-$ printf "2009-01-01 аура (cyrillic letters)\n bank 10\n cash\n2010-01-01 aypa (roman letters)\n bank 20\n cash\n" | hledger -f - reg desc:аура
-2009/01/01 аура (cyrillic let.. bank 10 10
- cash -10 0
-@
-
--- error message with unicode in ledger
--- not implemented yet
---@
-$ printf "2009-01-01 broken entry\n дебит 1\n кредит -2\n" | hledger -f - 2>&1 ; true
-hledger: could not balance this transaction, amounts do not add up to zero:
-2009/01/01 broken entry
- дебит 1
- кредит -2
-
-
---@
-
-@
-$ printf "2009-01-01 x\n a 2\n b (b) b -1\n c\n" | hledger -f - print 2>&1; true
-2009/01/01 x
- a 2
- b (b) b -1
- c
-
-@
-
-Nafai's bug
-@
-$ printf "2009/1/1 x\n a: 13\n b\n" | hledger -f - bal -E 2>&1; true
-"-" (line 2, column 1):
-unexpected " "
-accountname seems ill-formed: a:
-@
-
-Eliding, general layout
-@
-$ printf "2009/1/1 x\n aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa €1\n b\n" | hledger -f - bal 2>&1
- €1 aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa
- €-1 b
-@
-
---@
-$ printf "2009/1/1 x\n aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa €1\n b\n" | hledger -f - reg 2>&1
-2009/01/01 x aa:aa:aaaaaaaaaaaaaaaa €1 €1
- b €-1 0
-@
-
---@
-$ printf "2009/1/1 x\n aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa €1\n b\n" | hledger -f - print 2>&1
-2009/01/01 x
- aa:aaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa
- b
-@
-
--}
--- other test tools:
--- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/test-framework
--- http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HTF
-
module Tests
where
import qualified Data.Map as Map
@@ -203,6 +34,7 @@
import Text.ParserCombinators.Parsec
import Test.HUnit.Tools (runVerboseTests)
import System.Exit (exitFailure, exitWith, ExitCode(ExitSuccess)) -- base 3 compatible
+import System.Time (ClockTime(TOD))
import Commands.All
import Ledger
@@ -216,8 +48,8 @@
then exitFailure
else exitWith ExitSuccess
where
- runner | (Verbose `elem` opts) = runVerboseTests
- | otherwise = \t -> runTestTT t >>= return . (flip (,) 0)
+ runner | Verbose `elem` opts = runVerboseTests
+ | otherwise = liftM (flip (,) 0) . runTestTT
ts = TestList $ filter matchname $ concatMap tflatten tests
--ts = tfilter matchname $ TestList tests -- unflattened
matchname = matchpats args . tname
@@ -247,9 +79,6 @@
parseis :: (Show a, Eq a) => (Either ParseError a) -> a -> Assertion
parse `parseis` expected = either printParseError (`is` expected) parse
-parseWithCtx :: GenParser Char LedgerFileCtx a -> String -> Either ParseError a
-parseWithCtx p ts = runParser p emptyCtx "" ts
-
------------------------------------------------------------------------------
-- | Tests for any function or topic. Mostly ordered by test name.
tests :: [Test]
@@ -288,7 +117,7 @@
)
]
- ,"accountnames" ~: do
+ ,"accountnames" ~:
accountnames ledger7 `is`
["assets","assets:cash","assets:checking","assets:saving","equity","equity:opening balances",
"expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation",
@@ -308,10 +137,21 @@
(a1 + a3) `is` Amount (comm "$") 0 Nothing
(a2 + a3) `is` Amount (comm "$") (-2.46) Nothing
(a3 + a3) `is` Amount (comm "$") (-2.46) Nothing
- (sum [a2,a3]) `is` Amount (comm "$") (-2.46) Nothing
- (sum [a3,a3]) `is` Amount (comm "$") (-2.46) Nothing
- (sum [a1,a2,a3,-a3]) `is` Amount (comm "$") 0 Nothing
+ sum [a2,a3] `is` Amount (comm "$") (-2.46) Nothing
+ sum [a3,a3] `is` Amount (comm "$") (-2.46) Nothing
+ sum [a1,a2,a3,-a3] `is` Amount (comm "$") 0 Nothing
+ let dollar0 = dollar{precision=0}
+ (sum [Amount dollar 1.25 Nothing, Amount dollar0 (-1) Nothing, Amount dollar (-0.25) Nothing])
+ `is` (Amount dollar 0 Nothing)
+ ,"mixed amount arithmetic" ~: do
+ let dollar0 = dollar{precision=0}
+ (sum $ map (Mixed . (\a -> [a]))
+ [Amount dollar 1.25 Nothing,
+ Amount dollar0 (-1) Nothing,
+ Amount dollar (-0.25) Nothing])
+ `is` Mixed [Amount dollar 0 Nothing]
+
,"balance report tests" ~:
let (opts,args) `gives` es = do
l <- sampleledgerwithopts opts args
@@ -469,17 +309,17 @@
,"balanceLedgerTransaction" ~: do
assertBool "detect unbalanced entry, sign error"
(isLeft $ balanceLedgerTransaction
- (LedgerTransaction (parsedate "2007/01/28") False "" "test" ""
+ (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" ""
[Posting False "a" (Mixed [dollars 1]) "" RegularPosting,
Posting False "b" (Mixed [dollars 1]) "" RegularPosting
] ""))
assertBool "detect unbalanced entry, multiple missing amounts"
(isLeft $ balanceLedgerTransaction
- (LedgerTransaction (parsedate "2007/01/28") False "" "test" ""
+ (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" ""
[Posting False "a" missingamt "" RegularPosting,
Posting False "b" missingamt "" RegularPosting
] ""))
- let e = balanceLedgerTransaction (LedgerTransaction (parsedate "2007/01/28") False "" "test" ""
+ let e = balanceLedgerTransaction (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "test" ""
[Posting False "a" (Mixed [dollars 1]) "" RegularPosting,
Posting False "b" missingamt "" RegularPosting
] "")
@@ -490,19 +330,19 @@
Right e' -> (pamount $ last $ ltpostings e')
Left _ -> error "should not happen")
- ,"cacheLedger" ~: do
- (length $ Map.keys $ accountmap $ cacheLedger [] rawledger7) `is` 15
+ ,"cacheLedger" ~:
+ length (Map.keys $ accountmap $ cacheLedger [] rawledger7) `is` 15
,"canonicaliseAmounts" ~:
- "use the greatest precision" ~: do
- (rawLedgerPrecisions $ canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"]) `is` [2,2]
+ "use the greatest precision" ~:
+ rawLedgerPrecisions (canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"]) `is` [2,2]
- ,"commodities" ~: do
+ ,"commodities" ~:
commodities ledger7 `is` [Commodity {symbol="$", side=L, spaced=False, comma=False, precision=2}]
,"dateSpanFromOpts" ~: do
let todaysdate = parsedate "2008/11/26"
- let opts `gives` spans = show (dateSpanFromOpts todaysdate opts) `is` spans
+ 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)"
@@ -522,9 +362,9 @@
let now = utcToLocalTime tz now'
nowstr = showtime now
yesterday = prevday today
- clockin t a = TimeLogEntry In t a
- mktime d s = LocalTime d $ fromMaybe midnight $ parseTime defaultTimeLocale "%H:%M:%S" s
- showtime t = formatTime defaultTimeLocale "%H:%M" t
+ clockin = TimeLogEntry In
+ mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S"
+ showtime = formatTime defaultTimeLocale "%H:%M"
assertEntriesGiveStrings name es ss = assertEqual name ss (map ltdescription $ entriesFromTimeLogEntries now es)
assertEntriesGiveStrings "started yesterday, split session at midnight"
@@ -542,12 +382,12 @@
[clockin future ""]
[printf "%s-%s" futurestr futurestr]
- ,"expandAccountNames" ~: do
+ ,"expandAccountNames" ~:
expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`
["assets","assets:cash","assets:checking","expenses","expenses:vacation"]
,"intervalFromOpts" ~: do
- let opts `gives` interval = intervalFromOpts opts `is` interval
+ let gives = is . intervalFromOpts
[] `gives` NoInterval
[WeeklyOpt] `gives` Weekly
[MonthlyOpt] `gives` Monthly
@@ -567,43 +407,43 @@
,"isLedgerTransactionBalanced" ~: do
assertBool "detect balanced"
(isLedgerTransactionBalanced
- (LedgerTransaction (parsedate "2009/01/01") False "" "a" ""
+ (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting
] ""))
assertBool "detect unbalanced"
(not $ isLedgerTransactionBalanced
- (LedgerTransaction (parsedate "2009/01/01") False "" "a" ""
+ (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting
,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting
] ""))
assertBool "detect unbalanced, one posting"
(not $ isLedgerTransactionBalanced
- (LedgerTransaction (parsedate "2009/01/01") False "" "a" ""
+ (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting
] ""))
assertBool "one zero posting is considered balanced for now"
(isLedgerTransactionBalanced
- (LedgerTransaction (parsedate "2009/01/01") False "" "a" ""
+ (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""
[Posting False "b" (Mixed [dollars 0]) "" RegularPosting
] ""))
assertBool "virtual postings don't need to balance"
(isLedgerTransactionBalanced
- (LedgerTransaction (parsedate "2009/01/01") False "" "a" ""
+ (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting
,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting
] ""))
assertBool "balanced virtual postings need to balance among themselves"
(not $ isLedgerTransactionBalanced
- (LedgerTransaction (parsedate "2009/01/01") False "" "a" ""
+ (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting
,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting
] ""))
assertBool "balanced virtual postings need to balance among themselves (2)"
(isLedgerTransactionBalanced
- (LedgerTransaction (parsedate "2009/01/01") False "" "a" ""
+ (LedgerTransaction (parsedate "2009/01/01") Nothing False "" "a" ""
[Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting
,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting
,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting
@@ -618,35 +458,35 @@
,"default year" ~: do
rl <- rawLedgerFromString defaultyear_ledger_str
- (ltdate $ head $ ledger_txns rl) `is` fromGregorian 2009 1 1
+ ltdate (head $ ledger_txns rl) `is` fromGregorian 2009 1 1
return ()
,"ledgerFile" ~: do
- assertBool "ledgerFile should parse an empty file" $ (isRight $ parseWithCtx ledgerFile "")
+ assertBool "ledgerFile should parse an empty file" (isRight $ parseWithCtx emptyCtx ledgerFile "")
r <- rawLedgerFromString "" -- don't know how to get it from ledgerFile
assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ ledger_txns r
- ,"ledgerHistoricalPrice" ~: do
- parseWithCtx ledgerHistoricalPrice price1_str `parseis` price1
+ ,"ledgerHistoricalPrice" ~:
+ parseWithCtx emptyCtx ledgerHistoricalPrice price1_str `parseis` price1
,"ledgerTransaction" ~: do
- parseWithCtx ledgerTransaction entry1_str `parseis` entry1
+ parseWithCtx emptyCtx ledgerTransaction entry1_str `parseis` entry1
assertBool "ledgerTransaction should not parse just a date"
- $ isLeft $ parseWithCtx ledgerTransaction "2009/1/1\n"
+ $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1\n"
assertBool "ledgerTransaction should require some postings"
- $ isLeft $ parseWithCtx ledgerTransaction "2009/1/1 a\n"
- let t = parseWithCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n"
+ $ isLeft $ parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a\n"
+ let t = parseWithCtx emptyCtx ledgerTransaction "2009/1/1 a ;comment\n b 1\n"
assertBool "ledgerTransaction should not include a comment in the description"
$ either (const False) ((== "a") . ltdescription) t
,"ledgeraccountname" ~: do
- assertBool "ledgeraccountname parses a normal accountname" $ (isRight $ parsewith ledgeraccountname "a:b:c")
- assertBool "ledgeraccountname rejects an empty inner component" $ (isLeft $ parsewith ledgeraccountname "a::c")
- assertBool "ledgeraccountname rejects an empty leading component" $ (isLeft $ parsewith ledgeraccountname ":b:c")
- assertBool "ledgeraccountname rejects an empty trailing component" $ (isLeft $ parsewith ledgeraccountname "a:b:")
+ assertBool "ledgeraccountname parses a normal accountname" (isRight $ parsewith ledgeraccountname "a:b:c")
+ assertBool "ledgeraccountname rejects an empty inner component" (isLeft $ parsewith ledgeraccountname "a::c")
+ assertBool "ledgeraccountname rejects an empty leading component" (isLeft $ parsewith ledgeraccountname ":b:c")
+ assertBool "ledgeraccountname rejects an empty trailing component" (isLeft $ parsewith ledgeraccountname "a:b:")
- ,"ledgerposting" ~: do
- parseWithCtx ledgerposting rawposting1_str `parseis` rawposting1
+ ,"ledgerposting" ~:
+ parseWithCtx emptyCtx ledgerposting rawposting1_str `parseis` rawposting1
,"parsedate" ~: do
parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" sampledate
@@ -654,7 +494,7 @@
,"period expressions" ~: do
let todaysdate = parsedate "2008/11/26"
- let str `gives` result = (show $ parsewith (periodexpr todaysdate) str) `is` ("Right "++result)
+ let str `gives` result = show (parsewith (periodexpr todaysdate) str) `is` ("Right " ++ result)
"from aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
"aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
"every day from aug to oct" `gives` "(Daily,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
@@ -670,9 +510,9 @@
l <- sampleledgerwithopts [] args
showLedgerTransactions [] args l `is` unlines
["2008/06/03 * eat & shop"
- ," expenses:food $1"
- ," expenses:supplies $1"
- ," assets:cash"
+ ," expenses:food $1"
+ ," expenses:supplies $1"
+ ," assets:cash $-2"
,""
]
@@ -681,18 +521,18 @@
l <- sampleledger
showLedgerTransactions [Depth "2"] [] l `is` unlines
["2008/01/01 income"
- ," income:salary $-1"
+ ," income:salary $-1"
,""
,"2008/06/01 gift"
- ," income:gifts $-1"
+ ," income:gifts $-1"
,""
,"2008/06/03 * eat & shop"
- ," expenses:food $1"
- ," expenses:supplies $1"
- ," assets:cash"
+ ," expenses:food $1"
+ ," expenses:supplies $1"
+ ," assets:cash $-2"
,""
,"2008/12/31 * pay off"
- ," liabilities:debts $1"
+ ," liabilities:debts $1"
,""
]
@@ -780,8 +620,8 @@
,"register report with display expression" ~:
do
l <- sampleledger
- let displayexpr `gives` dates =
- registerdates (showRegisterReport [Display displayexpr] [] l) `is` dates
+ let gives displayexpr =
+ (registerdates (showRegisterReport [Display displayexpr] [] l) `is`)
"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"]
@@ -834,46 +674,58 @@
assertEqual "show a balanced transaction, eliding last amount"
(unlines
["2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
+ ," expenses:food:groceries $47.18"
," assets:checking"
,""
])
(showLedgerTransaction
- (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" ""
+ (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting
,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting
] ""))
+ assertEqual "show a balanced transaction, no eliding"
+ (unlines
+ ["2007/01/28 coopportunity"
+ ," expenses:food:groceries $47.18"
+ ," assets:checking $-47.18"
+ ,""
+ ])
+ (showLedgerTransactionUnelided
+ (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
+ [Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting
+ ,Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting
+ ] ""))
-- document some cases that arise in debug/testing:
assertEqual "show an unbalanced transaction, should not elide"
(unlines
["2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
- ," assets:checking $-47.19"
+ ," expenses:food:groceries $47.18"
+ ," assets:checking $-47.19"
,""
])
(showLedgerTransaction
- (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" ""
+ (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting
,Posting False "assets:checking" (Mixed [dollars (-47.19)]) "" RegularPosting
] ""))
assertEqual "show an unbalanced transaction with one posting, should not elide"
(unlines
["2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
+ ," expenses:food:groceries $47.18"
,""
])
(showLedgerTransaction
- (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" ""
+ (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting
] ""))
assertEqual "show a transaction with one posting and a missing amount"
(unlines
["2007/01/28 coopportunity"
- ," expenses:food:groceries "
+ ," expenses:food:groceries "
,""
])
(showLedgerTransaction
- (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" ""
+ (LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
[Posting False "expenses:food:groceries" missingamt "" RegularPosting
] ""))
@@ -892,7 +744,7 @@
," актив:наличные -100 0"]
,"smart dates" ~: do
- let str `gives` datestr = fixSmartDateStr (parsedate "2008/11/26") str `is` datestr
+ let gives = is . fixSmartDateStr (parsedate "2008/11/26")
"1999-12-02" `gives` "1999/12/02"
"1999.12.02" `gives` "1999/12/02"
"1999/3/2" `gives` "1999/03/02"
@@ -927,7 +779,7 @@
-- "next january" `gives` "2009/01/01"
,"splitSpan" ~: do
- let (interval,span) `gives` spans = splitSpan interval span `is` spans
+ let gives (interval, span) = (splitSpan interval span `is`)
(NoInterval,mkdatespan "2008/01/01" "2009/01/01") `gives`
[mkdatespan "2008/01/01" "2009/01/01"]
(Quarterly,mkdatespan "2008/01/01" "2009/01/01") `gives`
@@ -946,11 +798,11 @@
,"subAccounts" ~: do
l <- sampleledger
let a = ledgerAccount l "assets"
- (map aname $ ledgerSubAccounts l a) `is` ["assets:bank","assets:cash"]
+ map aname (ledgerSubAccounts l a) `is` ["assets:bank","assets:cash"]
,"summariseTransactionsInDateSpan" ~: do
- let (b,e,tnum,depth,showempty,ts) `gives` summaryts =
- summariseTransactionsInDateSpan (mkdatespan b e) tnum depth showempty ts `is` summaryts
+ let gives (b,e,tnum,depth,showempty,ts) =
+ (summariseTransactionsInDateSpan (mkdatespan b e) tnum depth showempty ts `is`)
let ts =
[
nulltxn{tdescription="desc",taccount="expenses:food:groceries",tamount=Mixed [dollars 1]}
@@ -984,9 +836,9 @@
]
,"postingamount" ~: do
- parseWithCtx postingamount " $47.18" `parseis` Mixed [dollars 47.18]
- parseWithCtx postingamount " $1." `parseis`
- Mixed [Amount (Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0}) 1 Nothing]
+ parseWithCtx emptyCtx postingamount " $47.18" `parseis` Mixed [dollars 47.18]
+ parseWithCtx emptyCtx postingamount " $1." `parseis`
+ Mixed [Amount Commodity {symbol="$",side=L,spaced=False,comma=False,precision=0} 1 Nothing]
]
@@ -1064,9 +916,9 @@
]
entry1 =
- (LedgerTransaction (parsedate "2007/01/28") False "" "coopportunity" ""
+ LedgerTransaction (parsedate "2007/01/28") Nothing False "" "coopportunity" ""
[Posting False "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularPosting,
- Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting] "")
+ Posting False "assets:checking" (Mixed [dollars (-47.18)]) "" RegularPosting] ""
entry2_str = unlines
@@ -1213,7 +1065,8 @@
[]
[
LedgerTransaction {
- ltdate= parsedate "2007/01/01",
+ ltdate=parsedate "2007/01/01",
+ lteffectivedate=Nothing,
ltstatus=False,
ltcode="*",
ltdescription="opening balance",
@@ -1238,7 +1091,8 @@
}
,
LedgerTransaction {
- ltdate= parsedate "2007/02/01",
+ ltdate=parsedate "2007/02/01",
+ lteffectivedate=Nothing,
ltstatus=False,
ltcode="*",
ltdescription="ayres suites",
@@ -1264,6 +1118,7 @@
,
LedgerTransaction {
ltdate=parsedate "2007/01/02",
+ lteffectivedate=Nothing,
ltstatus=False,
ltcode="*",
ltdescription="auto transfer to savings",
@@ -1289,6 +1144,7 @@
,
LedgerTransaction {
ltdate=parsedate "2007/01/03",
+ lteffectivedate=Nothing,
ltstatus=False,
ltcode="*",
ltdescription="poquito mas",
@@ -1314,6 +1170,7 @@
,
LedgerTransaction {
ltdate=parsedate "2007/01/03",
+ lteffectivedate=Nothing,
ltstatus=False,
ltcode="*",
ltdescription="verizon",
@@ -1339,6 +1196,7 @@
,
LedgerTransaction {
ltdate=parsedate "2007/01/03",
+ lteffectivedate=Nothing,
ltstatus=False,
ltcode="*",
ltdescription="discover",
@@ -1366,6 +1224,7 @@
[]
""
""
+ (TOD 0 0)
ledger7 = cacheLedger [] rawledger7
@@ -1382,12 +1241,12 @@
timelogentry2_str = "o 2007/03/11 16:30:00\n"
timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") ""
-price1_str = "P 2004/05/01 XYZ $55\n"
-price1 = HistoricalPrice (parsedate "2004/05/01") "XYZ" "$" 55
+price1_str = "P 2004/05/01 XYZ $55.00\n"
+price1 = HistoricalPrice (parsedate "2004/05/01") "XYZ" $ Mixed [dollars 55]
a1 = Mixed [(hours 1){price=Just $ Mixed [Amount (comm "$") 10 Nothing]}]
a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}]
-a3 = Mixed $ (amounts a1) ++ (amounts a2)
+a3 = Mixed $ amounts a1 ++ amounts a2
rawLedgerWithAmounts :: [String] -> RawLedger
rawLedgerWithAmounts as =
@@ -1399,5 +1258,6 @@
[]
""
""
- where parse = fromparse . parseWithCtx postingamount . (" "++)
+ (TOD 0 0)
+ where parse = fromparse . parseWithCtx emptyCtx postingamount . (" "++)
diff --git a/Utils.hs b/Utils.hs
--- a/Utils.hs
+++ b/Utils.hs
@@ -9,9 +9,14 @@
where
import Control.Monad.Error
import Ledger
-import Options (Opt,ledgerFilePathFromOpts,optsToIOArgs)
+import Options (Opt,ledgerFilePathFromOpts,optsToFilterSpec)
import System.Directory (doesFileExist)
-import System.IO
+import System.IO (stderr)
+import System.IO.UTF8 (hPutStrLn)
+import System.Exit
+import System.Cmd (system)
+import System.Info (os)
+import System.Time (getClockTime)
-- | Parse the user's specified ledger file and run a hledger command on
@@ -27,10 +32,11 @@
let creating = not fileexists && cmdname == "add"
rawtext <- if creating then return "" else strictReadFile f'
t <- getCurrentLocalTime
- let go = cmd opts args . filterAndCacheLedgerWithOpts opts args t rawtext . (\rl -> rl{filepath=f})
- case creating of
- True -> return rawLedgerEmpty >>= go
- False -> return f >>= runErrorT . parseLedgerFile t >>= either (hPutStrLn stderr) go
+ tc <- getClockTime
+ let go = cmd opts args . filterAndCacheLedgerWithOpts opts args t rawtext . (\rl -> rl{filepath=f,filereadtime=tc})
+ if creating then go rawLedgerEmpty else (runErrorT . parseLedgerFile t) f
+ >>= flip either go
+ (\e -> hPutStrLn stderr e >> exitWith (ExitFailure 1))
-- | Get a Ledger from the given string and options, or raise an error.
ledgerFromStringWithOpts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger
@@ -42,10 +48,33 @@
readLedgerWithOpts :: [Opt] -> [String] -> FilePath -> IO Ledger
readLedgerWithOpts opts args f = do
t <- getCurrentLocalTime
- readLedgerWithIOArgs (optsToIOArgs opts args t) f
+ readLedgerWithFilterSpec (optsToFilterSpec opts args t) f
-- | Convert a RawLedger to a canonicalised, cached and filtered Ledger
-- based on the command-line options/arguments and a reference time.
filterAndCacheLedgerWithOpts :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger
-filterAndCacheLedgerWithOpts opts args t = filterAndCacheLedger (optsToIOArgs opts args t)
+filterAndCacheLedgerWithOpts opts args = filterAndCacheLedger . optsToFilterSpec opts args
+
+-- | Attempt to open a web browser on the given url, all platforms.
+openBrowserOn :: String -> IO ExitCode
+openBrowserOn u = trybrowsers browsers u
+ where
+ trybrowsers (b:bs) u = do
+ e <- system $ printf "%s %s" b u
+ case e of
+ ExitSuccess -> return ExitSuccess
+ ExitFailure _ -> trybrowsers bs u
+ trybrowsers [] u = do
+ putStrLn $ printf "Sorry, I could not start a browser (tried: %s)" $ intercalate ", " browsers
+ putStrLn $ printf "Please open your browser and visit %s" u
+ return $ ExitFailure 127
+ browsers | os=="darwin" = ["open"]
+ | os=="mingw32" = ["start","firefox","safari","opera","iexplore"]
+ | otherwise = ["sensible-browser","firefox"]
+ -- jeffz: write a ffi binding for it using the Win32 package as a basis
+ -- start by adding System/Win32/Shell.hsc and follow the style of any
+ -- other module in that directory for types, headers, error handling and
+ -- what not.
+ -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL);
+ -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL);
diff --git a/Version.hs b/Version.hs
--- a/Version.hs
+++ b/Version.hs
@@ -1,11 +1,7 @@
-{-# OPTIONS_GHC -cpp #-}
+{-# LANGUAGE CPP #-}
{-
-Version-related utilities.
-
-We should follow http://haskell.org/haskellwiki/Package_versioning_policy .
-But currently hledger's version is MAJOR[.MINOR[.BUGFIX]][+PATCHLEVEL].
-See also the Makefile.
-
+Version-related utilities. See the Makefile for details of our version
+numbering policy.
-}
module Version
@@ -15,7 +11,7 @@
import Options (progname)
-- version and PATCHLEVEL are set by the makefile
-version = "0.6.1"
+version = "0.7.0"
#ifdef PATCHLEVEL
patchlevel = "." ++ show PATCHLEVEL -- must be numeric !
@@ -32,34 +28,30 @@
where
bugfix'
| bugfix `elem` ["0"{-,"98","99"-}] = ""
- | otherwise = "."++bugfix
+ | otherwise = '.' : bugfix
patches'
- | patches/="0" = "+"++patches
+ | patches/="0" = '+' : patches
| otherwise = ""
(os',suffix)
| os == "darwin" = ("mac","")
| os == "mingw32" = ("windows",".exe")
| otherwise = (os,"")
- prettify (major:minor:bugfix:[]) = prettify (major:minor:bugfix:"0":[])
- prettify (major:minor:[]) = prettify (major:minor:"0":"0":[])
- prettify (major:[]) = prettify (major:"0":"0":"0":[])
+ prettify (major:minor:bugfix:[]) = prettify [major,minor,bugfix,"0"]
+ prettify (major:minor:[]) = prettify [major,minor,"0","0"]
+ prettify (major:[]) = prettify [major,"0","0","0"]
prettify [] = error "VERSION is empty, please fix"
prettify _ = error "VERSION has too many components, please fix"
versionstr = prettify $ splitAtElement '.' buildversion :: String
where
prettify (major:minor:bugfix:patches:[]) =
- printf "%s.%s%s%s%s" major minor bugfix' patches' desc
+ printf "%s.%s%s%s" major minor bugfix' patches'
where
bugfix'
| bugfix `elem` ["0"{-,"98","99"-}] = ""
- | otherwise = "."++bugfix
+ | otherwise = '.' : bugfix
patches'
- | patches/="0" = "+"++patches++" patches"
- | otherwise = ""
- desc
--- | bugfix=="98" = " (alpha)"
--- | bugfix=="99" = " (beta)"
+ | patches/="0" = "+"++patches
| otherwise = ""
prettify s = intercalate "." s
@@ -72,7 +64,7 @@
#ifdef VTY
,"vty"
#endif
-#ifdef HAPPS
- ,"happs"
+#ifdef WEB
+ ,"web"
#endif
]
diff --git a/hledger.cabal b/hledger.cabal
--- a/hledger.cabal
+++ b/hledger.cabal
@@ -1,6 +1,6 @@
name: hledger
-- Version is set by the makefile
-version: 0.6.1
+version: 0.7.0
category: Finance
synopsis: A command-line (or curses or web-based) double-entry accounting tool.
description:
@@ -21,7 +21,7 @@
stability: experimental
tested-with: GHC==6.8, GHC==6.10
cabal-version: >= 1.2
-build-type: Simple
+build-type: Custom
extra-tmp-files:
extra-source-files:
@@ -33,7 +33,7 @@
description: enable the curses ui
default: False
-flag happs
+flag web
description: enable the web ui
default: False
@@ -61,6 +61,7 @@
,directory
,filepath
,haskell98
+ ,old-time
,parsec
,time
,utf8-string >= 0.3 && < 0.4
@@ -106,6 +107,7 @@
,filepath
,haskell98
,mtl
+ ,old-time
,parsec
,process
,regexpr >= 0.5.1
@@ -114,6 +116,7 @@
,time
,utf8-string >= 0.3 && < 0.4
,HUnit
+ ,safe >= 0.2
-- should set patchlevel here as in Makefile
cpp-options: -DPATCHLEVEL=0
@@ -122,19 +125,28 @@
cpp-options: -DVTY
other-modules:Commands.UI
build-depends:
- vty >= 3.1.8.2 && < 3.2
+ vty >= 4.0.0.1 && < 4.1
- if flag(happs)
- cpp-options: -DHAPPS
+ if flag(web)
+ cpp-options: -DWEB
other-modules:Commands.Web
build-depends:
- happstack >= 0.2 && < 0.3
- ,happstack-data >= 0.2 && < 0.3
- ,happstack-server >= 0.2 && < 0.3
- ,happstack-state >= 0.2 && < 0.3
+ hsp
+ ,hsx
,xhtml >= 3000.2 && < 3000.3
+ ,loli
+ ,io-storage
+ ,hack-contrib
+ ,hack
+ ,hack-handler-happstack
+ ,happstack >= 0.3 && < 0.4
+ ,happstack-data >= 0.3 && < 0.4
+ ,happstack-server >= 0.3 && < 0.4
+ ,happstack-state >= 0.3 && < 0.4
,HTTP >= 4000.0 && < 4000.1
+ ,applicative-extras
+
-- source-repository head
-- type: darcs
-- location: http://joyful.com/repos/hledger
@@ -144,3 +156,7 @@
-- >= 1.6'.
-- cf http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html
+
+-- Additional dependencies:
+-- required for make test: test-framework, test-framework-hunit
+-- required for make bench: tabular-0.1
diff --git a/hledger.hs b/hledger.hs
--- a/hledger.hs
+++ b/hledger.hs
@@ -1,5 +1,5 @@
-- #!/usr/bin/env runhaskell <- sp doesn't like
-{-# OPTIONS_GHC -cpp #-}
+{-# LANGUAGE CPP #-}
{-|
hledger - a ledger-compatible text-based accounting tool.
@@ -50,9 +50,9 @@
main = do
(opts, cmd, args) <- parseArguments
run cmd opts args
- where
+ where
run cmd opts args
- | Help `elem` opts = putStr $ usage
+ | Help `elem` opts = putStr usage
| Version `elem` opts = putStrLn versionmsg
| BinaryFilename `elem` opts = putStrLn binaryfilename
| cmd `isPrefixOf` "balance" = withLedgerDo opts args cmd balance
@@ -65,8 +65,8 @@
#ifdef VTY
| cmd `isPrefixOf` "ui" = withLedgerDo opts args cmd ui
#endif
-#ifdef HAPPS
+#ifdef WEB
| cmd `isPrefixOf` "web" = withLedgerDo opts args cmd web
#endif
| cmd `isPrefixOf` "test" = runtests opts args >> return ()
- | otherwise = putStr $ usage
+ | otherwise = putStr usage