hledger 0.6.1 → 0.7.0
raw patch · 31 files changed
+1379/−1165 lines, 31 filesdep +applicative-extrasdep +hackdep +hack-contribdep ~happstackdep ~happstack-datadep ~happstack-serverbuild-type:Customsetup-changedPVP ok
version bump matches the API change (PVP)
Dependencies added: applicative-extras, hack, hack-contrib, hack-handler-happstack, hsp, hsx, io-storage, loli, old-time, safe
Dependency ranges changed: happstack, happstack-data, happstack-server, happstack-state, vty
API changes (from Hackage documentation)
- Ledger.IO: readLedgerWithIOArgs :: IOArgs -> FilePath -> IO Ledger
- Ledger.IO: type IOArgs = (DateSpan, Maybe Bool, Bool, Bool, [String], [String])
- Ledger.Ledger: datespan :: Ledger -> DateSpan
- Ledger.Types: hprice :: HistoricalPrice -> Double
- Ledger.Types: hsymbol1 :: HistoricalPrice -> String
- Ledger.Types: hsymbol2 :: HistoricalPrice -> String
- Ledger.Types: instance Show HistoricalPrice
+ Ledger.Amount: instance Show HistoricalPrice
+ Ledger.Amount: normaliseMixedAmountIgnoringPrice :: MixedAmount -> MixedAmount
+ Ledger.Amount: showAmountWithoutPrice :: Amount -> String
+ Ledger.Amount: showMixedAmountOrZeroWithoutPrice :: MixedAmount -> String
+ Ledger.Amount: showMixedAmountWithoutPrice :: MixedAmount -> String
+ Ledger.IO: readLedgerWithFilterSpec :: FilterSpec -> FilePath -> IO Ledger
+ Ledger.LedgerTransaction: ledgerTransactionWithDate :: WhichDate -> LedgerTransaction -> LedgerTransaction
+ Ledger.LedgerTransaction: showLedgerTransactionForPrint :: Bool -> LedgerTransaction -> String
+ Ledger.Parse: ledgercommentline :: GenParser Char st String
+ Ledger.Parse: ledgereffectivedate :: GenParser Char LedgerFileCtx (Maybe Day)
+ Ledger.Parse: linebeginningwithspaces :: GenParser Char st String
+ Ledger.RawLedger: rawLedgerSelectingDate :: WhichDate -> RawLedger -> RawLedger
+ Ledger.Types: ActualDate :: WhichDate
+ Ledger.Types: EffectiveDate :: WhichDate
+ Ledger.Types: FilterSpec :: DateSpan -> Maybe Bool -> Bool -> Bool -> [String] -> [String] -> WhichDate -> FilterSpec
+ Ledger.Types: acctpats :: FilterSpec -> [String]
+ Ledger.Types: cleared :: FilterSpec -> Maybe Bool
+ Ledger.Types: costbasis :: FilterSpec -> Bool
+ Ledger.Types: data FilterSpec
+ Ledger.Types: data WhichDate
+ Ledger.Types: datespan :: FilterSpec -> DateSpan
+ Ledger.Types: descpats :: FilterSpec -> [String]
+ Ledger.Types: filereadtime :: RawLedger -> ClockTime
+ Ledger.Types: hamount :: HistoricalPrice -> MixedAmount
+ Ledger.Types: hsymbol :: HistoricalPrice -> String
+ Ledger.Types: instance Typeable Ledger
+ Ledger.Types: lteffectivedate :: LedgerTransaction -> Maybe Day
+ Ledger.Types: real :: FilterSpec -> Bool
+ Ledger.Types: whichdate :: FilterSpec -> WhichDate
+ Ledger.Utils: parseWithCtx :: b -> GenParser Char b a -> String -> Either ParseError a
- Ledger.IO: filterAndCacheLedger :: IOArgs -> String -> RawLedger -> Ledger
+ Ledger.IO: filterAndCacheLedger :: FilterSpec -> String -> RawLedger -> Ledger
- Ledger.LedgerTransaction: showLedgerTransaction' :: Bool -> LedgerTransaction -> String
+ Ledger.LedgerTransaction: showLedgerTransaction' :: Bool -> Bool -> LedgerTransaction -> String
- Ledger.Types: HistoricalPrice :: Day -> String -> String -> Double -> HistoricalPrice
+ Ledger.Types: HistoricalPrice :: Day -> String -> MixedAmount -> HistoricalPrice
- Ledger.Types: LedgerTransaction :: Day -> Bool -> String -> String -> String -> [Posting] -> String -> LedgerTransaction
+ Ledger.Types: LedgerTransaction :: Day -> Maybe Day -> Bool -> String -> String -> String -> [Posting] -> String -> LedgerTransaction
- Ledger.Types: RawLedger :: [ModifierTransaction] -> [PeriodicTransaction] -> [LedgerTransaction] -> [TimeLogEntry] -> [HistoricalPrice] -> String -> FilePath -> RawLedger
+ Ledger.Types: RawLedger :: [ModifierTransaction] -> [PeriodicTransaction] -> [LedgerTransaction] -> [TimeLogEntry] -> [HistoricalPrice] -> String -> FilePath -> ClockTime -> RawLedger
Files
- Commands/Add.hs +10/−28
- Commands/All.hs +3/−3
- Commands/Balance.hs +11/−11
- Commands/Convert.hs +286/−94
- Commands/Histogram.hs +5/−4
- Commands/Print.hs +8/−6
- Commands/Register.hs +15/−11
- Commands/Stats.hs +7/−7
- Commands/UI.hs +56/−74
- Commands/Web.hs +302/−117
- Ledger/AccountName.hs +7/−7
- Ledger/Amount.hs +80/−37
- Ledger/Dates.hs +23/−22
- Ledger/IO.hs +29/−36
- Ledger/Ledger.hs +14/−14
- Ledger/LedgerTransaction.hs +33/−18
- Ledger/Parse.hs +61/−36
- Ledger/Posting.hs +22/−6
- Ledger/RawLedger.hs +73/−45
- Ledger/TimeLog.hs +4/−3
- Ledger/Transaction.hs +2/−3
- Ledger/Types.hs +25/−8
- Ledger/Utils.hs +12/−13
- Options.hs +55/−49
- README +25/−207
- Setup.hs +9/−1
- Tests.hs +120/−260
- Utils.hs +37/−8
- Version.hs +14/−22
- hledger.cabal +26/−10
- hledger.hs +5/−5
Commands/Add.hs view
@@ -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: -@---}
Commands/All.hs view
@@ -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
Commands/Balance.hs view
@@ -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
Commands/Convert.hs view
@@ -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)" ++)
Commands/Histogram.hs view
@@ -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
Commands/Print.hs view
@@ -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
Commands/Register.hs view
@@ -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
Commands/Stats.hs view
@@ -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
Commands/UI.hs view
@@ -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
Commands/Web.hs view
@@ -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 -{-- <div style=\"float:right;text-align:right;\">- <form action=%s>- filter by: <input name=a size=30 value=\"%s\">- reporting period: <input name=p size=30 value=\"%s\">- %s- </form>- </div>- <div style=\"width:100%%; font-weight:bold;\">- <a href=balance%s>balance</a>- | <a href=register%s>register</a>- | <a href=print%s>print</a>- | <a href=histogram%s>histogram</a>- </div>- <pre>%s</pre>--}-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 <div><% addform env %><pre><% f l' %></pre></div>++-- | A loli directive to serve a string in pre tags within the hledger web+-- layout.+string :: [String] -> String -> AppUnit+string msgs s = hsp msgs $ const <pre><% s %></pre>++-- | 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 = ("<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01//EN\" \"http://www.w3.org/TR/html4/strict.dtd\">\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 =+ <html>+ <head>+ <meta http-equiv = "Content-Type" content = "text/html; charset=utf-8" />+ <link rel="stylesheet" type="text/css" href="/static/style.css" media="all" />+ <title><% title %></title>+ </head>+ <body>+ <% navbar env %>+ <div id="messages"><% intercalate ", " msgs %></div>+ <div id="content"><% content %></div>+ </body>+ </html>++navbar :: Hack.Env -> HSP XML+navbar env =+ <div id="navbar">+ <a href="http://hledger.org" id="hledgerorglink">hledger.org</a>+ <% navlinks env %>+-- <% searchform env %>+ <a href="http://hledger.org/README.html" id="helplink">help</a>+ </div>++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 = <a href=(addparams s) class="navlink"><% s %></a>+ <div id="navlinks">+ <% link "journal" %> |+ <% link "register" %> |+ <% link "balance" %>+ </div>++searchform :: Hack.Env -> HSP XML+searchform env = do+ a <- getParamOrNull "a"+ p <- getParamOrNull "p"+ let resetlink | null a && null p = <span></span>+ | otherwise = <span id="resetlink">[NBSP]<a href=u>reset</a></span>+ where u = dropWhile (=='/') $ Hack.Contrib.Request.path env+ <form action="" id="searchform">+ [NBSP]account pattern:[NBSP]<input name="a" size="20" value=a+ />[NBSP][NBSP]reporting period:[NBSP]<input name="p" size="20" value=p />+ <input type="submit" name="submit" value="filter" style="display:none" />+ <% resetlink %>+ </form>++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+ <div>+ <div id="addform">+ <form action="" method="POST">+ <table border="0">+ <tr>+ <td>+ Date: <input size="15" name="date" value=date />[NBSP]+ Description: <input size="35" name="desc" value=desc />[NBSP]+ </td>+ </tr>+ <% transactionfields 1 env %>+ <% transactionfields 2 env %>+ <tr id="addbuttonrow"><td><input type="submit" value="add transaction" /></td></tr>+ </table>+ </form>+ </div>+ <br clear="all" />+ </div>++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+ <tr>+ <td>+ [NBSP][NBSP]+ Account: <input size="35" name=acctvar value=acct />[NBSP]+ Amount: <input size="15" name=amtvar value=amt />[NBSP]+ </td>+ </tr> 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)
Ledger/AccountName.hs view
@@ -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
Ledger/Amount.hs view
@@ -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]
Ledger/Dates.hs view
@@ -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
Ledger/IO.hs view
@@ -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}
Ledger/Ledger.hs view
@@ -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
Ledger/LedgerTransaction.hs view
@@ -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)}+
Ledger/Parse.hs view
@@ -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
Ledger/Posting.hs view
@@ -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
Ledger/RawLedger.hs view
@@ -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
Ledger/TimeLog.hs view
@@ -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,
Ledger/Transaction.hs view
@@ -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
Ledger/Types.hs view
@@ -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
Ledger/Utils.hs view
@@ -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
Options.hs view
@@ -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
README view
@@ -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 <simon@joyful.com> 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
Setup.hs view
@@ -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"
Tests.hs view
@@ -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 . (" "++)
Utils.hs view
@@ -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);
Version.hs view
@@ -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 ]
hledger.cabal view
@@ -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
hledger.hs view
@@ -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