hledger 0.5.1 → 0.6
raw patch · 40 files changed
+1857/−1598 lines, 40 filesdep +HTTPdep +xhtmldep −old-localedep −regex-compatdep −regex-pcredep ~basedep ~utf8-stringPVP ok
version bump matches the API change (PVP)
Dependencies added: HTTP, xhtml
Dependencies removed: old-locale, regex-compat, regex-pcre
Dependency ranges changed: base, utf8-string
API changes (from Hackage documentation)
- Ledger.AccountName: match_negative_pats :: [String] -> String -> Bool
- Ledger.AccountName: match_positive_pats :: [String] -> String -> Bool
- Ledger.AccountName: matchpats :: [String] -> String -> Bool
- Ledger.AccountName: matchpats_balance :: [String] -> String -> Bool
- Ledger.IO: tildeExpand :: FilePath -> IO FilePath
- Ledger.Parse: balancedvirtualposting :: GenParser Char LedgerFileCtx Posting
- Ledger.Parse: normalposting :: GenParser Char LedgerFileCtx Posting
- Ledger.Parse: virtualposting :: GenParser Char LedgerFileCtx Posting
- Ledger.Utils: instance Show Regex
+ Ledger.AccountName: T :: (Map a (Tree' a)) -> Tree' a
+ Ledger.AccountName: accountNameTreeFrom4 :: [AccountName] -> Tree AccountName
+ Ledger.AccountName: converttree :: Tree' AccountName -> [Tree AccountName]
+ Ledger.AccountName: expandTreeNames :: Tree AccountName -> Tree AccountName
+ Ledger.AccountName: fromPaths :: (Ord a) => [[a]] -> Tree' a
+ Ledger.AccountName: instance (Eq a) => Eq (Tree' a)
+ Ledger.AccountName: instance (Ord a) => Ord (Tree' a)
+ Ledger.AccountName: instance (Show a) => Show (Tree' a)
+ Ledger.AccountName: mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a
+ Ledger.AccountName: newtype Tree' a
+ Ledger.AccountName: pathtree :: [a] -> Tree' a
+ Ledger.Dates: daysInSpan :: DateSpan -> Maybe Integer
+ Ledger.Dates: splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan]
+ Ledger.Ledger: commodities :: Ledger -> [Commodity]
+ Ledger.LedgerTransaction: showAccountName :: Maybe Int -> PostingType -> AccountName -> String
+ Ledger.RawLedger: matchpats :: [String] -> String -> Bool
+ Ledger.Utils: unbracket :: String -> String
+ Ledger.Utils: underline :: String -> String
- Ledger.Utils: containsRegex :: Regex -> String -> Bool
+ Ledger.Utils: containsRegex :: String -> String -> Bool
Files
- AddCommand.hs +0/−228
- BalanceCommand.hs +0/−161
- Commands/Add.hs +211/−0
- Commands/All.hs +38/−0
- Commands/Balance.hs +159/−0
- Commands/Convert.hs +124/−0
- Commands/Histogram.hs +48/−0
- Commands/Print.hs +27/−0
- Commands/Register.hs +116/−0
- Commands/Stats.hs +65/−0
- Commands/UI.hs +391/−0
- Commands/Web.hs +155/−0
- ConvertCommand.hs +0/−114
- HistogramCommand.hs +0/−50
- Ledger.hs +3/−2
- Ledger/AccountName.hs +81/−62
- Ledger/Amount.hs +8/−8
- Ledger/Commodity.hs +1/−2
- Ledger/Dates.hs +27/−24
- Ledger/IO.hs +24/−22
- Ledger/Ledger.hs +6/−5
- Ledger/LedgerTransaction.hs +14/−5
- Ledger/Parse.hs +32/−58
- Ledger/Posting.hs +10/−4
- Ledger/RawLedger.hs +15/−2
- Ledger/TimeLog.hs +0/−2
- Ledger/Transaction.hs +4/−4
- Ledger/Utils.hs +21/−9
- Options.hs +14/−20
- PrintCommand.hs +0/−27
- README +28/−29
- RegisterCommand.hs +0/−118
- Tests.hs +79/−13
- UICommand.hs +0/−391
- Utils.hs +0/−3
- Version.hs +42/−11
- WebCommand.hs +0/−127
- hledger.cabal +99/−56
- hledger.hs +9/−41
- sample.timelog +6/−0
− AddCommand.hs
@@ -1,228 +0,0 @@-{-| --An add command to help with data entry.---}--module AddCommand-where-import Prelude hiding (putStr, putStrLn, getLine, appendFile)-import Ledger-import Options-import RegisterCommand (showRegisterReport)-import System.IO.UTF8-import System.IO (stderr, hFlush)-import System.IO.Error-import Text.ParserCombinators.Parsec-import Utils (ledgerFromStringWithOpts)----- | Read ledger transactions from the terminal, prompting for each field,--- and append them to the ledger file. If the ledger came from stdin, this--- command has no effect.-add :: [Opt] -> [String] -> Ledger -> IO ()-add opts args l- | filepath (rawledger l) == "-" = return ()- | otherwise = do- hPutStrLn stderr- "Enter one or more transactions, which will be added to your ledger file.\n\- \To complete a transaction, enter . as account name.\n\- \To finish input, enter control-d (discards any transaction in progress)."- getAndAddTransactions l args- return ()---- | Read a number of ledger transactions from the command line,--- prompting, validating, displaying and appending them to the ledger--- file, until end of input.-getAndAddTransactions :: Ledger -> [String] -> IO [LedgerTransaction]-getAndAddTransactions l args = do- -- for now, thread the eoi flag throughout rather than muck about with monads- (t, eoi) <- getTransaction l args- l <- if isJust t then addTransaction l (fromJust t) else return l- if eoi then return $ maybe [] (:[]) t- else liftM (fromJust t:) (getAndAddTransactions l args)---- | Get a transaction from the command line, if possible, and a flag--- indicating end of input.-getTransaction :: Ledger -> [String] -> IO (Maybe LedgerTransaction, Bool)-getTransaction l args = do- today <- getCurrentDay- (datestr, eoi) <- askFor "date" - (Just $ showDate today)- (Just $ \s -> null s || - (isRight $ parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))- if eoi- then return (Nothing, True)- else do- (description, eoi) <- if null args - then askFor "description" Nothing (Just $ not . null) - else (do- let description = unwords args- hPutStrLn stderr $ "description: " ++ description- return (description, False))- if eoi- then return (Nothing, True)- else do- let historymatches = transactionsSimilarTo l description- when (not $ null historymatches) (do- hPutStrLn stderr "Similar past transactions found:"- hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches)- let bestmatch | null historymatches = Nothing- | otherwise = Just $ snd $ head $ historymatches- bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch- date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr- getpostingsandvalidate = do- (ps, eoi) <- getPostings bestmatchpostings []- let t = nullledgertxn{ltdate=date- ,ltstatus=False- ,ltdescription=description- ,ltpostings=ps- }- if eoi && null ps- then return (Nothing, eoi)- else either (const retry) (return . flip (,) eoi . Just) $ balanceLedgerTransaction t- retry = do- hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:"- getpostingsandvalidate- getpostingsandvalidate---- | Get two or more postings from the command line, if possible, and a--- flag indicating end of input.-getPostings :: Maybe [Posting] -> [Posting] -> IO ([Posting], Bool)-getPostings bestmatchps enteredps = do- (account, eoi) <- askFor (printf "account %d" n) defaultaccount validateaccount- if account=="." || eoi- then return (enteredps, eoi)- else do- (amountstr, eoi) <- askFor (printf "amount %d" n) defaultamount validateamount- let amount = fromparse $ parse (someamount <|> return missingamt) "" amountstr- let p = nullrawposting{paccount=account,pamount=amount}- if eoi- then if null enteredps- then return ([], True)- else return (enteredps ++ [p], True)- else if amount == missingamt- then return $ (enteredps ++ [p], eoi)- else getPostings bestmatchps $ enteredps ++ [p]- where- n = length enteredps + 1- bestmatch | isNothing bestmatchps = Nothing- | n <= length ps = Just $ ps !! (n-1)- | otherwise = Nothing- where Just ps = bestmatchps- defaultaccount = maybe Nothing (Just . paccount) bestmatch- validateaccount = Just $ \s -> not $ null s- defaultamount | n==1 = maybe Nothing (Just . show . pamount) bestmatch -- previously used amount- | otherwise = Just $ show $ negate $ sum $ map pamount enteredps -- balancing amount- validateamount = Just $ \s -> - (null s && (not $ null enteredps)) ||- (isRight $ parse (someamount>>many spacenonewline>>eof) "" s)----- | Prompt for and read a string value and a flag indicating whether--- input has ended (control-d was pressed), optionally with a default--- value and a validator. A validator will cause the prompt to repeat--- until the input is valid (unless the input is just ctrl-d).-askFor :: String -> Maybe String -> Maybe (String -> Bool) -> IO (String, Bool)-askFor prompt def validator = do- hPutStr stderr $ prompt ++ (maybe "" showdef def) ++ ": "- hFlush stderr- -- ugly- l <- getLine `catch` (\e -> if isEOFError e then return "*EOF*" else ioError e)- let (l', eoi) = case l of "*EOF*" -> ("", True)- _ -> (l, False)- let input = if null l' then fromMaybe l' def else l'- case validator of- Just valid -> if valid input || (null input && eoi)- then return (input, eoi) - else askFor prompt def validator- Nothing -> return (input, eoi)- where showdef s = " [" ++ s ++ "]"---- | Append this transaction to the ledger's file. Also, to the ledger's--- transaction list, but we don't bother updating the other fields - this--- is enough to include new transactions in the history matching.-addTransaction :: Ledger -> LedgerTransaction -> IO Ledger-addTransaction l t = do- appendToLedgerFile l $ show t- putStrLn $ printf "\nAdded transaction to %s:" (filepath $ rawledger l)- putStrLn =<< registerFromString (show t)- return l{rawledger=rl{ledger_txns=ts}}- where rl = rawledger l- ts = ledger_txns rl ++ [t]---- | Append data to the ledger's file, ensuring proper separation from any--- existing data; or if the file is "-", dump it to stdout.-appendToLedgerFile :: Ledger -> String -> IO ()-appendToLedgerFile l s = - if f == "-"- then putStr $ sep ++ s- else appendFile f $ sep++s- where - f = filepath $ rawledger l- -- we keep looking at the original raw text from when the ledger- -- was first read, but that's good enough for now- t = rawledgertext l- sep | null $ strip t = ""- | otherwise = replicate (2 - min 2 (length lastnls)) '\n'- where lastnls = takeWhile (=='\n') $ reverse t---- | Convert a string of ledger data into a register report.-registerFromString :: String -> IO String-registerFromString s = do- now <- getCurrentLocalTime- l <- ledgerFromStringWithOpts [] [] now s- return $ showRegisterReport [Empty] [] l---- | Return a similarity measure, from 0 to 1, for two strings.--- This is Simon White's letter pairs algorithm from--- http://www.catalysoft.com/articles/StrikeAMatch.html--- with a modification for short strings.-compareStrings :: String -> String -> Float-compareStrings "" "" = 1-compareStrings (a:[]) "" = 0-compareStrings "" (b:[]) = 0-compareStrings (a:[]) (b:[]) = if toUpper a == toUpper b then 1 else 0-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 _ = []--compareLedgerDescriptions s t = compareStrings s' t'- where s' = simplify s- t' = simplify t- simplify = filter (not . (`elem` "0123456789"))--transactionsSimilarTo :: Ledger -> String -> [(Float,LedgerTransaction)]-transactionsSimilarTo l s =- sortBy compareRelevanceAndRecency- $ filter ((> threshold).fst)- $ [(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: -@---}
− BalanceCommand.hs
@@ -1,161 +0,0 @@-{-| --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-following account tree:--@- assets- bank- checking- saving- cash- expenses- food- supplies- income- gifts- salary- liabilities- debts-@--The balance command shows accounts with their aggregate balances.-Subaccounts are displayed indented below their parent. Each balance is the-sum of any transactions in that account plus any balances from-subaccounts:--@- $ 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-@--Usually, the non-interesting accounts are elided or omitted. Above,-@checking@ is omitted because it has no subaccounts and a zero balance.-@bank@ is elided because it has only a single displayed subaccount-(@saving@) and it would be showing the same balance as that ($1). Ditto-for @liabilities@. We will return to this in a moment.--The --depth argument can be used to limit the depth of the balance report.-So, to see just the top level accounts:--@-$ hledger -f sample.ledger balance --depth 1- $-1 assets- $2 expenses- $-2 income- $1 liabilities-@--This time liabilities has no displayed subaccounts (due to --depth) and-is not elided.--With one or more account pattern arguments, the balance command shows-accounts whose name matches one of the patterns, plus their parents-(elided) and subaccounts. So with the pattern o we get:--@- $ hledger -f sample.ledger balance o- $1 expenses:food- $-2 income- $-1 gifts- $-1 salary---------------------- $-1-@--The o pattern matched @food@ and @income@, so they are shown. Unmatched-parents of matched accounts are also shown (elided) for context (@expenses@).--Also, the balance report shows the total of all displayed accounts, when-that is non-zero. Here, it is displayed because the accounts shown add up-to $-1.--Here is a more precise definition of \"interesting\" accounts in ledger's-balance report:--- an account which has just one interesting subaccount branch, and which- is not at the report's maximum depth, is interesting if the balance is- different from the subaccount's, and otherwise boring.--- any other account is interesting if it has a non-zero balance, or the -E- flag is used.---}--module BalanceCommand-where-import Prelude hiding (putStr)-import Ledger.Utils-import Ledger.Types-import Ledger.Amount-import Ledger.AccountName-import Ledger.Transaction-import Ledger.Ledger-import Ledger.Parse-import Options-import Utils-import System.IO.UTF8----- | Print a balance report.-balance :: [Opt] -> [String] -> Ledger -> IO ()-balance opts args l = putStr $ showBalanceReport opts args l---- | Generate a balance report with the specified options for this ledger.-showBalanceReport :: [Opt] -> [String] -> Ledger -> String-showBalanceReport opts args l = acctsstr ++ totalstr- where - acctsstr = unlines $ map showacct interestingaccts- where- showacct = showInterestingAccount l interestingaccts- interestingaccts = filter (isInteresting opts l) acctnames- 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- where- total = sum $ map abalance $ ledgerTopAccounts l---- | Display one line of the balance report with appropriate indenting and eliding.-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- parents = parentAccountNames a- interestingparents = filter (`elem` interestingaccts) parents- depthspacer = replicate (2 * length interestingparents) ' '- -- 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]- where ps = takeWhile boring parents where boring = not . (`elem` interestingparents)---- | Is the named account considered interesting for this ledger's balance report ?-isInteresting :: [Opt] -> Ledger -> AccountName -> Bool-isInteresting opts l a- | numinterestingsubs==1 && not atmaxdepth = notlikesub- | otherwise = notzero || emptyflag- where- atmaxdepth = accountNameLevel a == depthFromOpts opts- emptyflag = Empty `elem` opts- acct = ledgerAccount l a- notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct- notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumTransactions $ atransactions acct- numinterestingsubs = length $ filter isInterestingTree subtrees- where- isInterestingTree t = treeany (isInteresting opts l . aname) t- subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a-
+ Commands/Add.hs view
@@ -0,0 +1,211 @@+{-| ++A history-aware add command to help with data entry.++-}++module Commands.Add+where+import Prelude hiding (putStr, putStrLn, getLine, appendFile)+import Ledger+import Options+import Commands.Register (showRegisterReport)+import System.IO.UTF8+import System.IO (stderr, hFlush)+import System.IO.Error+import Text.ParserCombinators.Parsec+import Utils (ledgerFromStringWithOpts)+++-- | Read ledger transactions from the terminal, prompting for each field,+-- and append them to the ledger file. If the ledger came from stdin, this+-- command has no effect.+add :: [Opt] -> [String] -> Ledger -> IO ()+add _ args l+ | filepath (rawledger l) == "-" = return ()+ | otherwise = do+ 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)++-- | Read a number of ledger transactions from the command line,+-- prompting, validating, displaying and appending them to the ledger+-- file, until end of input (then raise an EOF exception). Any+-- command-line arguments are used as the first transaction's description.+getAndAddTransactions :: Ledger -> [String] -> IO ()+getAndAddTransactions l args = do+ l <- getTransaction l args >>= addTransaction l+ getAndAddTransactions l []++-- | Read a transaction from the command line, with history-aware prompting.+getTransaction :: Ledger -> [String] -> IO LedgerTransaction+getTransaction l args = do+ today <- getCurrentDay+ datestr <- askFor "date" + (Just $ showDate today)+ (Just $ \s -> null s || + (isRight $ parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))+ description <- if null args + then askFor "description" Nothing (Just $ not . null) + else do+ let description = unwords args+ hPutStrLn stderr $ "description: " ++ description+ return description+ let historymatches = transactionsSimilarTo l description+ bestmatch | null historymatches = Nothing+ | otherwise = Just $ snd $ head $ historymatches+ bestmatchpostings = maybe Nothing (Just . ltpostings) bestmatch+ date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr+ getpostingsandvalidate = do+ ps <- getPostings bestmatchpostings []+ let t = nullledgertxn{ltdate=date+ ,ltstatus=False+ ,ltdescription=description+ ,ltpostings=ps+ }+ retry = do+ hPutStrLn stderr $ "\n" ++ nonzerobalanceerror ++ ". Re-enter:"+ getpostingsandvalidate+ either (const retry) return $ balanceLedgerTransaction t+ when (not $ 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)+ getpostingsandvalidate++-- | Read postings from the command line until . is entered, using the+-- provided historical postings, if any, to guess defaults.+getPostings :: Maybe [Posting] -> [Posting] -> IO [Posting]+getPostings historicalps enteredps = do+ account <- askFor (printf "account %d" n) defaultaccount (Just $ not . null)+ if account=="."+ then return enteredps+ else do+ amountstr <- askFor (printf "amount %d" n) defaultamount validateamount+ let amount = fromparse $ parse (someamount <|> return missingamt) "" amountstr+ let p = nullrawposting{paccount=stripbrackets account,+ pamount=amount,+ ptype=postingtype account}+ getPostings historicalps $ enteredps ++ [p]+ where+ n = length enteredps + 1+ enteredrealps = filter isReal enteredps+ bestmatch | isNothing historicalps = Nothing+ | n <= length ps = Just $ ps !! (n-1)+ | otherwise = Nothing+ where Just ps = historicalps+ defaultaccount = maybe Nothing (Just . showacctname) bestmatch+ showacctname p = showAccountName Nothing (ptype p) $ paccount p+ defaultamount = maybe balancingamount (Just . show . pamount) bestmatch+ where balancingamount = Just $ show $ negate $ sum $ map pamount enteredrealps+ postingtype ('[':_) = BalancedVirtualPosting+ 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)++-- | 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) ++ ": "+ hFlush stderr+ l <- getLine+ let input = if null l then fromMaybe l def else l+ case validator of+ Just valid -> if valid input+ then return input+ else askFor prompt def validator+ Nothing -> return input+ where showdef s = " [" ++ s ++ "]"++-- | Append this transaction to the ledger's file. Also, to the ledger's+-- transaction list, but we don't bother updating the other fields - this+-- is enough to include new transactions in the history matching.+addTransaction :: Ledger -> LedgerTransaction -> IO Ledger+addTransaction l t = do+ appendToLedgerFile l $ show t+ putStrLn $ printf "\nAdded transaction to %s:" (filepath $ rawledger l)+ putStrLn =<< registerFromString (show t)+ return l{rawledger=rl{ledger_txns=ts}}+ where rl = rawledger l+ ts = ledger_txns rl ++ [t]++-- | Append data to the ledger's file, ensuring proper separation from any+-- existing data; or if the file is "-", dump it to stdout.+appendToLedgerFile :: Ledger -> String -> IO ()+appendToLedgerFile l s = + if f == "-"+ then putStr $ sep ++ s+ else appendFile f $ sep++s+ where + f = filepath $ rawledger l+ -- we keep looking at the original raw text from when the ledger+ -- was first read, but that's good enough for now+ t = rawledgertext l+ sep | null $ strip t = ""+ | otherwise = replicate (2 - min 2 (length lastnls)) '\n'+ where lastnls = takeWhile (=='\n') $ reverse t++-- | Convert a string of ledger data into a register report.+registerFromString :: String -> IO String+registerFromString s = do+ now <- getCurrentLocalTime+ l <- ledgerFromStringWithOpts [] [] now s+ return $ showRegisterReport [Empty] [] l++-- | Return a similarity measure, from 0 to 1, for two strings.+-- This is Simon White's letter pairs algorithm from+-- http://www.catalysoft.com/articles/StrikeAMatch.html+-- with a modification for short strings.+compareStrings :: String -> String -> Double+compareStrings "" "" = 1+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)+ 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 _ = []++compareLedgerDescriptions s t = compareStrings s' t'+ where s' = simplify s+ t' = simplify t+ simplify = filter (not . (`elem` "0123456789"))++transactionsSimilarTo :: Ledger -> String -> [(Double,LedgerTransaction)]+transactionsSimilarTo l s =+ sortBy compareRelevanceAndRecency+ $ filter ((> threshold).fst)+ $ [(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
@@ -0,0 +1,38 @@+{-# OPTIONS_GHC -cpp #-}+{-| ++The Commands package defines all the commands offered by the hledger+application, like \"register\" and \"balance\". This module exports all+the commands; you can also import individual modules if you prefer.++-}++module Commands.All (+ module Commands.Add,+ module Commands.Balance,+ module Commands.Convert,+ module Commands.Histogram,+ module Commands.Print,+ module Commands.Register,+ module Commands.Stats,+#ifdef VTY+ module Commands.UI,+#endif+#ifdef HAPPS+ module Commands.Web,+#endif+ )+where+import Commands.Add+import Commands.Balance+import Commands.Convert+import Commands.Histogram+import Commands.Print+import Commands.Register+import Commands.Stats+#ifdef VTY+import Commands.UI+#endif+#ifdef HAPPS+import Commands.Web+#endif
+ Commands/Balance.hs view
@@ -0,0 +1,159 @@+{-| ++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+following account tree:++@+ assets+ bank+ checking+ saving+ cash+ expenses+ food+ supplies+ income+ gifts+ salary+ liabilities+ debts+@++The balance command shows accounts with their aggregate balances.+Subaccounts are displayed indented below their parent. Each balance is the+sum of any transactions in that account plus any balances from+subaccounts:++@+ $ 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+@++Usually, the non-interesting accounts are elided or omitted. Above,+@checking@ is omitted because it has no subaccounts and a zero balance.+@bank@ is elided because it has only a single displayed subaccount+(@saving@) and it would be showing the same balance as that ($1). Ditto+for @liabilities@. We will return to this in a moment.++The --depth argument can be used to limit the depth of the balance report.+So, to see just the top level accounts:++@+$ hledger -f sample.ledger balance --depth 1+ $-1 assets+ $2 expenses+ $-2 income+ $1 liabilities+@++This time liabilities has no displayed subaccounts (due to --depth) and+is not elided.++With one or more account pattern arguments, the balance command shows+accounts whose name matches one of the patterns, plus their parents+(elided) and subaccounts. So with the pattern o we get:++@+ $ hledger -f sample.ledger balance o+ $1 expenses:food+ $-2 income+ $-1 gifts+ $-1 salary+--------------------+ $-1+@++The o pattern matched @food@ and @income@, so they are shown. Unmatched+parents of matched accounts are also shown (elided) for context (@expenses@).++Also, the balance report shows the total of all displayed accounts, when+that is non-zero. Here, it is displayed because the accounts shown add up+to $-1.++Here is a more precise definition of \"interesting\" accounts in ledger's+balance report:++- an account which has just one interesting subaccount branch, and which+ is not at the report's maximum depth, is interesting if the balance is+ different from the subaccount's, and otherwise boring.++- any other account is interesting if it has a non-zero balance, or the -E+ flag is used.++-}++module Commands.Balance+where+import Prelude hiding (putStr)+import Ledger.Utils+import Ledger.Types+import Ledger.Amount+import Ledger.AccountName+import Ledger.Transaction+import Ledger.Ledger+import Options+import System.IO.UTF8+++-- | Print a balance report.+balance :: [Opt] -> [String] -> Ledger -> IO ()+balance opts args l = putStr $ showBalanceReport opts args l++-- | Generate a balance report with the specified options for this ledger.+showBalanceReport :: [Opt] -> [String] -> Ledger -> String+showBalanceReport opts _ l = acctsstr ++ totalstr+ where + acctsstr = unlines $ map showacct interestingaccts+ where+ showacct = showInterestingAccount l interestingaccts+ interestingaccts = filter (isInteresting opts l) acctnames+ 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+ where+ total = sum $ map abalance $ ledgerTopAccounts l++-- | Display one line of the balance report with appropriate indenting and eliding.+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+ parents = parentAccountNames a+ interestingparents = filter (`elem` interestingaccts) parents+ depthspacer = replicate (2 * length interestingparents) ' '+ -- 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]+ where ps = takeWhile boring parents where boring = not . (`elem` interestingparents)++-- | Is the named account considered interesting for this ledger's balance report ?+isInteresting :: [Opt] -> Ledger -> AccountName -> Bool+isInteresting opts l a+ | numinterestingsubs==1 && not atmaxdepth = notlikesub+ | otherwise = notzero || emptyflag+ where+ atmaxdepth = accountNameLevel a == depthFromOpts opts+ emptyflag = Empty `elem` opts+ acct = ledgerAccount l a+ notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct+ notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumTransactions $ atransactions acct+ numinterestingsubs = length $ filter isInterestingTree subtrees+ where+ isInterestingTree t = treeany (isInteresting opts l . aname) t+ subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a+
+ Commands/Convert.hs view
@@ -0,0 +1,124 @@+{-|++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.++-}++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 Text.RegexPR (matchRegexPR)+import Data.Maybe+import Ledger.Dates (firstJust, showDate)+import Locale (defaultTimeLocale)+import Data.Time.Format (parseTime)+import Control.Monad (when)+++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+ rulesstr <- readFile rulesfile+ (fieldpositions,rules) <- parseRules rulesstr+ parse <- parseCSVFromFile csvfile+ let records = case parse of+ Left e -> error $ show e+ Right rs -> reverse rs+ mapM_ (print_ledger_txn (Debug `elem` opts) (baseacct,fieldpositions,rules)) records+++type Rule = (+ [(String, Maybe String)] -- list of patterns and optional replacements+ ,AccountName -- account name to use for a matched transaction+ )++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)++parsePatRepl :: String -> (String, Maybe String)+parsePatRepl l = case splitOn "=" l of+ (p:r:_) -> (p, Just r)+ _ -> (l, Nothing)++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"+ | 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 ()++choose_acct_desc :: [Rule] -> (String,String) -> (String,String)+choose_acct_desc rules (acct,desc) | null matchingrules = (acct,desc)+ | otherwise = (a,d)+ where+ matchingrules = filter ismatch rules :: [Rule]+ where ismatch = any (isJust . flip matchregex desc . fst) . fst+ (prs,a) = 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)++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+ ]+
+ Commands/Histogram.hs view
@@ -0,0 +1,48 @@+{-| ++Print a histogram report.++-}++module Commands.Histogram+where+import Prelude hiding (putStr)+import Ledger+import Options+import System.IO.UTF8+++barchar = '*'++-- | 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++showHistogram :: [Opt] -> [String] -> Ledger -> String+showHistogram opts args l = concatMap (printDayWith countBar) daytxns+ where+ i = intervalFromOpts opts+ interval | i == NoInterval = Daily+ | otherwise = i+ fullspan = rawLedgerDateSpan $ rawledger l+ days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan+ daytxns = [(s, filter (isTransactionInDateSpan s) ts) | s <- days]+ -- same as Register+ 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+ (apats,_) = parsePatternArgs args+ filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth)+ | otherwise = id+ depth = depthFromOpts opts++printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts)++countBar ts = replicate (length ts) barchar++total ts = show $ sumTransactions ts++-- totalBar ts = replicate (sumTransactions ts) barchar
+ Commands/Print.hs view
@@ -0,0 +1,27 @@+{-| ++A ledger-compatible @print@ command.++-}++module Commands.Print+where+import Prelude hiding (putStr)+import Ledger+import Options+import System.IO.UTF8+++-- | Print ledger transactions in standard format.+print' :: [Opt] -> [String] -> Ledger -> IO ()+print' opts args l = putStr $ showLedgerTransactions opts args l++showLedgerTransactions :: [Opt] -> [String] -> Ledger -> String+showLedgerTransactions opts args l = concatMap showLedgerTransaction $ filteredtxns+ where + filteredtxns = ledger_txns $ + filterRawLedgerPostingsByDepth depth $ + filterRawLedgerTransactionsByAccount apats $ + rawledger l+ depth = depthFromOpts opts+ (apats,_) = parsePatternArgs args
+ Commands/Register.hs view
@@ -0,0 +1,116 @@+{-| ++A ledger-compatible @register@ command.++-}++module Commands.Register+where+import Prelude hiding (putStr)+import Ledger+import Options+import System.IO.UTF8+++-- | Print a register report.+register :: [Opt] -> [String] -> Ledger -> IO ()+register opts args l = putStr $ showRegisterReport opts args l++{- |+Generate the register report. Each ledger entry is displayed as two or+more lines like this:++@+date (10) description (20) account (22) amount (11) balance (12)+DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA+ aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA+ ... ... ...+@+-}+showRegisterReport :: [Opt] -> [String] -> Ledger -> String+showRegisterReport opts args l+ | interval == NoInterval = showtxns displayedts nulltxn startbal+ | 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)+ | otherwise = id+ filterempties+ | Empty `elem` opts = id+ | otherwise = filter (not . isZeroMixedAmount . tamount)+ (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+ dopt = displayFromOpts opts+ empty = Empty `elem` opts+ depth = depthFromOpts opts+ summaryts = concatMap summarisespan (zip spans [1..])+ summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s)+ transactionsinspan s = filter (isTransactionInDateSpan s) displayedts+ spans = splitSpan interval (ledgerDateSpan l)+ +-- | Convert a date span (representing a reporting interval) and a list of+-- transactions within it to a new list of transactions aggregated by+-- account, which showtxns will render as a summary for this interval.+-- +-- As usual with date spans the end date is exclusive, but for display+-- purposes we show the previous day as end date, like ledger.+-- +-- A unique tnum value is provided so that the new transactions will be+-- grouped as one entry.+-- +-- When a depth argument is present, transactions to accounts of greater+-- depth are aggregated where possible.+-- +-- The showempty flag forces the display of a zero-transaction span+-- and also zero-transaction accounts within the span.+summariseTransactionsInDateSpan :: DateSpan -> Int -> Int -> Bool -> [Transaction] -> [Transaction]+summariseTransactionsInDateSpan (DateSpan b e) tnum depth showempty ts+ | null ts && showempty = [txn]+ | null ts = []+ | otherwise = summaryts'+ where+ txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++(showDate $ addDays (-1) e')}+ b' = fromMaybe (tdate $ head ts) b+ e' = fromMaybe (tdate $ last ts) e+ summaryts'+ | showempty = summaryts+ | otherwise = filter (not . isZeroMixedAmount . tamount) summaryts+ txnanames = sort $ nub $ map taccount ts+ -- aggregate balances by account, like cacheLedger, then do depth-clipping+ (_,_,exclbalof,inclbalof) = groupTransactions ts+ clippedanames = clipAccountNames depth txnanames+ isclipped a = accountNameLevel a >= depth+ balancetoshowfor a =+ (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)+ summaryts = [txn{taccount=a,tamount=balancetoshowfor a} | a <- clippedanames]++clipAccountNames :: Int -> [AccountName] -> [AccountName]+clipAccountNames d as = nub $ map (clip d) as + where clip d = accountNameFromComponents . take d . accountNameComponents++-- | Show transactions one per line, with each date/description appearing+-- only once, and a running balance.+showtxns [] _ _ = ""+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+ 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)+ Transaction{tstatus=s,tdate=da,tdescription=de,taccount=a,tamount=amt,ttype=tt} = t+
+ Commands/Stats.hs view
@@ -0,0 +1,65 @@+{-| ++Print some statistics for the ledger.++-}++module Commands.Stats+where+import Prelude hiding (putStr)+import Ledger+import Options+import System.IO.UTF8+++-- | Print various statistics for the ledger.+stats :: [Opt] -> [String] -> Ledger -> IO ()+stats opts args l = do+ today <- getCurrentDay+ 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)+ where+ heading = underline $ printf "Ledger statistics as of %s" (show today)+ fmt = "%-" ++ (show w1) ++ "s: %-" ++ (show w2) ++ "s"+ w1 = maximum $ map (length . fst) stats+ w2 = maximum $ map (length . show . snd) stats+ stats = [+ ("File", filepath $ rawledger l)+ ,("Period", printf "%s to %s (%d days)" (start span) (end span) days)+ ,("Transactions", printf "%d (%0.1f per day)" tnum txnrate)+ ,("Transactions last 30 days", printf "%d (%0.1f per day)" tnum30 txnrate30)+ ,("Transactions last 7 days", printf "%d (%0.1f per day)" tnum7 txnrate7)+ ,("Last transaction", maybe "none" show lastdate +++ maybe "" (printf " (%d days ago)") lastelapsed)+-- ,("Payees/descriptions", show $ length $ nub $ map ltdescription ts)+ ,("Accounts", show $ length $ accounts l)+ ,("Commodities", show $ length $ commodities l)+ -- Transactions this month : %(monthtxns)s (last month in the same period: %(lastmonthtxns)s)+ -- Uncleared transactions : %(uncleared)s+ -- Days since reconciliation : %(reconcileelapsed)s+ -- Days since last transaction : %(recentelapsed)s+ ]+ where + ts = sortBy (comparing ltdate) $ ledger_txns $ rawledger l+ lastdate | null ts = Nothing+ | otherwise = Just $ ltdate $ last ts+ lastelapsed = maybe Nothing (Just . diffDays today) lastdate+ tnum = length ts+ span = rawdatespan l+ start (DateSpan (Just d) _) = show d+ start _ = ""+ end (DateSpan _ (Just d)) = show d+ end _ = ""+ days = fromMaybe 0 $ daysInSpan span+ 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+ txnrate30 = fromIntegral tnum30 / 30 :: Double+ tnum7 = length $ filter withinlast7 ts+ withinlast7 t = (d>=(addDays (-7) today) && (d<=today)) where d = ltdate t+ txnrate7 = fromIntegral tnum7 / 7 :: Double+
+ Commands/UI.hs view
@@ -0,0 +1,391 @@+{-| ++A simple text UI for hledger, based on the vty library.++-}++module Commands.UI+where+import Graphics.Vty+import qualified Data.ByteString.Char8 as B+import Ledger+import Options+import Commands.Balance+import Commands.Register+import Commands.Print+++helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit"++instance Show Vty where show = const "a Vty"++-- | The application state when running the ui command.+data AppState = AppState {+ av :: Vty -- ^ the vty context+ ,aw :: Int -- ^ window width+ ,ah :: Int -- ^ window height+ ,amsg :: String -- ^ status message+ ,aopts :: [Opt] -- ^ command-line opts+ ,aargs :: [String] -- ^ command-line args+ ,aledger :: Ledger -- ^ parsed ledger+ ,abuf :: [String] -- ^ lines of the current buffered view+ ,alocs :: [Loc] -- ^ user's navigation trail within the UI+ -- ^ never null, head is current location+ } deriving (Show)++-- | A location within the user interface.+data Loc = Loc {+ scr :: Screen -- ^ one of the available screens+ ,sy :: Int -- ^ viewport y scroll position+ ,cy :: Int -- ^ cursor y position+ } deriving (Show)++-- | The screens available within the user interface.+data Screen = BalanceScreen -- ^ like hledger balance, shows accounts+ | RegisterScreen -- ^ like hledger register, shows transaction-postings+ | PrintScreen -- ^ like hledger print, shows ledger transactions+ -- | LedgerScreen -- ^ shows the raw ledger+ deriving (Eq,Show)++-- | Run the interactive text ui.+ui :: [Opt] -> [String] -> Ledger -> IO ()+ui opts args l = do+ v <- mkVty+ (w,h) <- getSize v+ let opts' = SubTotal:opts+ let a = enter BalanceScreen $ + AppState {+ av=v+ ,aw=w+ ,ah=h+ ,amsg=helpmsg+ ,aopts=opts'+ ,aargs=args+ ,aledger=l+ ,abuf=[]+ ,alocs=[]+ }+ go a ++-- | 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+ 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+ EvKey KUp [] -> go $ moveUpAndPushEdge a+ EvKey KDown [] -> go $ moveDownAndPushEdge a+ EvKey KHome [] -> go $ moveToTop a+ EvKey KUp [MCtrl] -> go $ moveToTop a+ EvKey KUp [MShift] -> go $ moveToTop a+ EvKey KEnd [] -> go $ moveToBottom a+ EvKey KDown [MCtrl] -> go $ moveToBottom a+ EvKey KDown [MShift] -> go $ moveToBottom a+ EvKey KPageUp [] -> go $ prevpage a+ EvKey KBS [] -> go $ prevpage a+ EvKey (KASCII ' ') [MShift] -> go $ prevpage a+ EvKey KPageDown [] -> go $ nextpage a+ EvKey (KASCII ' ') [] -> go $ nextpage a+ EvKey (KASCII 'q') [] -> shutdown av >> return ()+-- EvKey KEsc [] -> shutdown av >> return ()+ _ -> go a++-- app state modifiers++-- | The number of lines currently available for the main data display area.+pageHeight :: AppState -> Int+pageHeight a = ah a - 1++setLocCursorY, setLocScrollY :: Int -> Loc -> Loc+setLocCursorY y l = l{cy=y}+setLocScrollY y l = l{sy=y}++cursorY, scrollY, posY :: AppState -> Int+cursorY = cy . loc+scrollY = sy . loc+posY a = scrollY a + cursorY a++setCursorY, setScrollY, setPosY :: Int -> AppState -> AppState+setCursorY _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings+setCursorY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l++setScrollY _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings+setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l++setPosY _ AppState{alocs=[]} = error "shouldn't happen" -- silence warnings+setPosY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)}+ where + l' = setLocScrollY sy $ setLocCursorY cy l+ ph = pageHeight a+ 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+updatePosY f a = setPosY (f $ posY a) a++resize :: Int -> Int -> AppState -> AppState+resize x y a = setCursorY cy' a{aw=x,ah=y}+ where+ cy = cursorY a+ cy' = min cy (y-2)++moveToTop :: AppState -> AppState+moveToTop a = setPosY 0 a++moveToBottom :: AppState -> AppState+moveToBottom a = setPosY (length $ abuf a) a++moveUpAndPushEdge :: AppState -> AppState+moveUpAndPushEdge a+ | cy > 0 = updateCursorY (subtract 1) a+ | sy > 0 = updateScrollY (subtract 1) a+ | otherwise = a+ where Loc{sy=sy,cy=cy} = head $ alocs a++moveDownAndPushEdge :: AppState -> AppState+moveDownAndPushEdge a+ | sy+cy >= bh = a+ | cy < ph-1 = updateCursorY (+1) a+ | otherwise = updateScrollY (+1) a+ where + Loc{sy=sy,cy=cy} = head $ alocs a+ ph = pageHeight a+ bh = length $ abuf a++-- | Scroll down by page height or until we can just see the last line,+-- without moving the cursor, or if we are already scrolled as far as+-- possible then move the cursor to the last line.+nextpage :: AppState -> AppState+nextpage (a@AppState{abuf=b})+ | sy < bh-jump = setScrollY sy' a+ | otherwise = setCursorY (bh-sy) a+ where+ sy = scrollY a+ jump = pageHeight a - 1+ bh = length b+ sy' = min (sy+jump) (bh-jump)++-- | Scroll up by page height or until we can just see the first line,+-- without moving the cursor, or if we are scrolled as far as possible+-- then move the cursor to the first line.+prevpage :: AppState -> AppState+prevpage a+ | sy > 0 = setScrollY sy' a+ | otherwise = setCursorY 0 a+ where+ sy = scrollY a+ jump = pageHeight a - 1+ sy' = max (sy-jump) 0++-- | Push a new UI location on to the stack.+pushLoc :: Loc -> AppState -> AppState+pushLoc l a = a{alocs=(l:alocs a)}++popLoc :: AppState -> AppState+popLoc a@AppState{alocs=locs}+ | length locs > 1 = a{alocs=drop 1 locs}+ | otherwise = a++clearLocs :: AppState -> AppState+clearLocs a = a{alocs=[]}++exit :: AppState -> AppState +exit = popLoc++loc :: AppState -> Loc+loc = head . alocs++screen :: AppState -> Screen+screen a = scr where (Loc scr _ _) = loc a++-- | Enter a new screen, saving the old ui location on the stack.+enter :: Screen -> AppState -> AppState +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++-- | Regenerate the display data appropriate for the current screen.+updateData :: AppState -> AppState+updateData a@AppState{aopts=opts,aargs=args,aledger=l} =+ case screen a of+ 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+ | otherwise = updateData $ popLoc a++drilldown :: AppState -> AppState+drilldown a =+ case screen a of+ 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+-- balance screen. Results undefined while on other screens.+currentAccountName :: AppState -> AccountName+currentAccountName a = accountNameAt (abuf a) (posY a)++-- | Get the full name of the account being displayed at a specific line+-- within the balance command's output.+accountNameAt :: [String] -> Int -> AccountName+accountNameAt buf lineno = accountNameFromComponents anamecomponents+ where+ namestohere = map (drop 22) $ take (lineno+1) buf+ (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'+ where+ xs' = dropWhile moreindented xs+ moreindented = (>= myindent) . indentof+ myindent = indentof x+ indentof = length . takeWhile (==' ')++-- | If on the print screen, move the cursor to highlight the specified entry+-- (or a reasonable guess). Doesn't work.+scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState+scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a+ where+ entryfirstline = head $ lines $ showLedgerTransaction $ e+ halfph = pageHeight a `div` 2+ y = fromMaybe 0 $ findIndex (== entryfirstline) buf+ sy = max 0 $ y - halfph+ cy = y - sy++-- | Get the entry containing the transaction currently highlighted by the+-- cursor on the register screen (or best guess). Results undefined while+-- on other screens. Doesn't work.+currentLedgerTransaction :: AppState -> LedgerTransaction+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+ acctamt = drop 32 $ safehead "" rest+ safehead d ls = if null ls then d else head ls+ (above,rest) = splitAt y buf+ y = posY a++-- | 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++-- 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+ }+ 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)) +-- | null ls = ([],[""])+-- | otherwise = splitAt y ls+-- ls = lines $ fitto w (h-1) $ unlines $ drop as $ buf++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+ blankline = replicate w ' '++renderString :: Attr -> String -> Image+renderString attr s = vertcat $ map (renderBS attr . B.pack) rows+ where+ rows = lines $ fitto w h s+ 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 ' ')) +++-- the all-important theming engine++theme = Restrained++data UITheme = Restrained | Colorful | Blood++(defaultattr, + currentlineattr, + statusattr+ ) = case theme of+ Restrained -> (attr+ ,setBold attr+ ,setRV attr+ )+ Colorful -> (setRV attr+ ,setFG white $ setBG red $ attr+ ,setFG black $ setBG green $ attr+ )+ Blood -> (setRV attr+ ,setFG white $ setBG red $ attr+ ,setRV attr+ )++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+-- }
+ Commands/Web.hs view
@@ -0,0 +1,155 @@+{-| +A happs-based web UI for hledger.+-}++module Commands.Web+where+import Control.Concurrent+import Happstack.Server+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 Options hiding (value)+import Commands.Balance+import Commands.Register+import Commands.Print+import Commands.Histogram+import Utils (filterAndCacheLedgerWithOpts)+++tcpport = 5000++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+ 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+ putStrLn "starting web browser"+ openBrowserOn $ printf "http://localhost:%d/" tcpport+ 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++{-+ <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++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']++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"++navlinks :: Request -> String -> String -> Html+navlinks _ a p' = + concatHtml $ intersperse sep $ map linkto ["balance", "register", "print", "histogram"]+ 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'++-- queryValues :: String -> Request -> [String]+-- queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r++-- queryValue :: String -> Request -> Maybe String+-- queryValue q r = case filter ((==q).fst) $ rqInputs r of+-- [] -> Nothing+-- is -> Just $ B.unpack $ inputValue $ snd $ head is++-- | 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);+
− ConvertCommand.hs
@@ -1,114 +0,0 @@-{-|--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.---}--module ConvertCommand where-import Data.Maybe (isJust)-import Data.List.Split (splitOn)-import Options -- (Opt,Debug)-import Ledger.Types (Ledger,AccountName)-import Ledger.Utils (strip)-import System (getArgs)-import System.IO (stderr, hPutStrLn)-import Text.CSV (parseCSVFromFile, Record)-import Text.Printf (printf)-import Text.Regex.PCRE ((=~))-import Data.Maybe-import Ledger.Dates (firstJust, showDate)-import System.Locale (defaultTimeLocale)-import Data.Time.Format (parseTime)-import Control.Monad (when)---convert :: [Opt] -> [String] -> Ledger -> IO ()-convert opts args l = do- when (length args /= 3) (error "please specify a csv file, base account, and import rules file.")- let [csvfile,baseacct,rulesfile] = args- rulesstr <- readFile rulesfile- (fieldpositions,rules) <- parseRules rulesstr- parse <- parseCSVFromFile csvfile- let records = case parse of- Left e -> error $ show e- Right rs -> reverse rs- mapM_ (print_ledger_txn (Debug `elem` opts) (baseacct,fieldpositions,rules)) records---type Rule = ([[String]] -- list of [pattern,replacement]. replacement may or may not be present.- ,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 (splitOn "=") $ init p, last p) | p <- tail paras]- return (fieldpositions,rules)--print_ledger_txn debug (baseacct,fieldpositions,rules) record@(a:b:c:d:e) = do- let [date,cleared,number,description,amount] = map (record !!) fieldpositions- amount' = strnegate amount where strnegate ('-':s) = s- strnegate s = '-':s- unknownacct | (read amount' :: 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 ()--choose_acct_desc rules (acct,desc) | null matches = (acct,desc)- | otherwise = (a,d)- where- matches = filter (any (desc =~) . map head . fst) rules- (pats,a) = head matches :: Rule- ((before,match,after,groups),repl) = head $ filter isMatch $ map (\(pat:repl) -> (desc=~pat,repl)) pats- d = head $ repl ++ [match] -- show the replacement text if any, or the matched text--isMatch :: ((String, String, String, [String]),[String]) -> Bool-isMatch ((_,m,_,_),_) = not $ null m--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- ]
− HistogramCommand.hs
@@ -1,50 +0,0 @@-{-| --Print a histogram report.---}--module HistogramCommand-where-import Prelude hiding (putStr)-import qualified Data.Map as Map-import Data.Map ((!))-import Ledger-import Options-import System.IO.UTF8---barchar = '*'---- | 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--showHistogram :: [Opt] -> [String] -> Ledger -> String-showHistogram opts args l = concatMap (printDayWith countBar) daytxns- where- i = intervalFromOpts opts- interval | i == NoInterval = Daily- | otherwise = i- fullspan = rawLedgerDateSpan $ rawledger l- days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan- daytxns = [(s, filter (isTransactionInDateSpan s) ts) | s <- days]- -- same as RegisterCommand- 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- (apats,_) = parsePatternArgs args- filterdepth | interval == NoInterval = filter (\t -> (accountNameLevel $ taccount t) <= depth)- | otherwise = id- depth = depthFromOpts opts--printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts)--countBar ts = replicate (length ts) barchar--total ts = show $ sumTransactions ts---- totalBar ts = replicate (sumTransactions ts) barchar
Ledger.hs view
@@ -1,7 +1,8 @@ {-| -The Ledger package allows parsing and querying of ledger files.-It generally provides a compatible subset of C++ ledger's functionality.+The Ledger library allows parsing and querying of ledger files. It+generally provides a compatible subset of C++ ledger's functionality.+This package re-exports all the Ledger.* modules. -}
Ledger/AccountName.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoMonomorphismRestriction#-} {-| 'AccountName's are strings like @assets:cash:petty@.@@ -9,8 +10,11 @@ where import Ledger.Utils import Ledger.Types+import Data.Map (Map)+import qualified Data.Map as M + -- change to use a different separator for nested accounts acctsepchar = ':' @@ -46,29 +50,95 @@ parentAccountNames' a = [a] ++ (parentAccountNames' $ parentAccountName a) isAccountNamePrefixOf :: AccountName -> AccountName -> Bool-p `isAccountNamePrefixOf` s = ((p ++ [acctsepchar]) `isPrefixOf` s)+p `isAccountNamePrefixOf` s = ((p ++ [acctsepchar] ) `isPrefixOf` s) isSubAccountNameOf :: AccountName -> AccountName -> Bool s `isSubAccountNameOf` p = (p `isAccountNamePrefixOf` s) && (accountNameLevel s == (accountNameLevel p + 1)) +-- | From a list of account names, select those which are direct+-- subaccounts of the given account name. subAccountNamesFrom :: [AccountName] -> AccountName -> [AccountName] subAccountNamesFrom accts a = filter (`isSubAccountNameOf` a) accts --- | We could almost get by with just the AccountName manipulations--- above, but we need smarter structures to eg display the account--- tree with boring accounts elided. This converts a list of--- AccountName to a tree (later we will convert that to a tree of--- 'Account'.)+-- | Convert a list of account names to a tree. accountNameTreeFrom :: [AccountName] -> Tree AccountName-accountNameTreeFrom accts = - Node "top" (accountsFrom (topAccountNames accts))+accountNameTreeFrom = accountNameTreeFrom1++accountNameTreeFrom1 accts = + Node "top" (accounttreesfrom (topAccountNames accts)) where- accountsFrom :: [AccountName] -> [Tree AccountName]- accountsFrom [] = []- accountsFrom as = [Node a (accountsFrom $ subs a) | a <- as]+ accounttreesfrom :: [AccountName] -> [Tree AccountName]+ accounttreesfrom [] = []+ accounttreesfrom as = [Node a (accounttreesfrom $ subs a) | a <- as] subs = subAccountNamesFrom (expandAccountNames accts) +accountNameTreeFrom2 accts = + Node "top" $ unfoldForest (\a -> (a, subs a)) $ topAccountNames accts+ where+ subs = subAccountNamesFrom allaccts+ allaccts = expandAccountNames accts+ -- subs' a = subsmap ! a+ -- subsmap :: Map AccountName [AccountName]+ -- subsmap = Data.Map.fromList [(a, subAccountNamesFrom allaccts a) | a <- allaccts]++accountNameTreeFrom3 accts = + Node "top" $ forestfrom allaccts $ topAccountNames accts+ where+ -- drop accts from the list of potential subs as we add them to the tree+ forestfrom :: [AccountName] -> [AccountName] -> Forest AccountName+ forestfrom subaccts accts = + [let subaccts' = subaccts \\ accts in Node a $ forestfrom subaccts' (subAccountNamesFrom subaccts' a) | a <- accts]+ allaccts = expandAccountNames accts+ ++-- a more efficient tree builder from Cale Gibbard+newtype Tree' a = T (Map a (Tree' a))+ deriving (Show, Eq, Ord)++mergeTrees :: (Ord a) => Tree' a -> Tree' a -> Tree' a+mergeTrees (T m) (T m') = T (M.unionWith mergeTrees m m')++emptyTree = T M.empty++pathtree :: [a] -> Tree' a+pathtree [] = T M.empty+pathtree (x:xs) = T (M.singleton x (pathtree xs))++fromPaths :: (Ord a) => [[a]] -> Tree' a+fromPaths = foldl' mergeTrees emptyTree . map pathtree++-- the above, but trying to build Tree directly++-- mergeTrees' :: (Ord a) => Tree a -> Tree a -> Tree a+-- mergeTrees' (Node m ms) (Node m' ms') = Node undefined (ms `union` ms')++-- emptyTree' = Node "top" []++-- pathtree' :: [a] -> Tree a+-- pathtree' [] = Node undefined []+-- pathtree' (x:xs) = Node x [pathtree' xs]++-- fromPaths' :: (Ord a) => [[a]] -> Tree a+-- fromPaths' = foldl' mergeTrees' emptyTree' . map pathtree'+++-- converttree :: [AccountName] -> Tree' AccountName -> [Tree AccountName]+-- converttree parents (T m) = [Node (accountNameFromComponents $ parents ++ [a]) (converttree (parents++[a]) b) | (a,b) <- M.toList m]++-- accountNameTreeFrom4 :: [AccountName] -> Tree AccountName+-- accountNameTreeFrom4 accts = Node "top" (converttree [] $ fromPaths $ map accountNameComponents accts)++converttree :: Tree' AccountName -> [Tree AccountName]+converttree (T m) = [Node a (converttree b) | (a,b) <- M.toList m]++expandTreeNames :: Tree AccountName -> Tree AccountName+expandTreeNames (Node x ts) = Node x (map (treemap (\n -> accountNameFromComponents [x,n]) . expandTreeNames) ts)++accountNameTreeFrom4 :: [AccountName] -> Tree AccountName+accountNameTreeFrom4 = Node "top" . map expandTreeNames . converttree . fromPaths . map accountNameComponents++ -- | Elide an account name to fit in the specified width. -- From the ledger 2.6 news: -- @@ -95,54 +165,3 @@ | otherwise = done++ss --- | Check if a set of ledger account/description patterns matches the--- given account name or entry description. Patterns are case-insensitive--- regular expression strings; those beginning with - are anti-patterns.-matchpats :: [String] -> String -> Bool-matchpats pats str =- (null positives || any match positives) && (null negatives || not (any match negatives))- where- (negatives,positives) = partition isnegativepat pats- match "" = True- match pat = matchregex (abspat pat) str---- | Similar to matchpats, but follows the special behaviour of ledger--- 2.6's balance command: positive patterns which do not contain : match--- the account leaf name, other patterns match the full account name.-matchpats_balance :: [String] -> String -> Bool-matchpats_balance pats str = match_positive_pats pats str && (not $ match_negative_pats pats str)--- (null positives || any match positives) && (null negatives || not (any match negatives))--- where--- (negatives,positives) = partition isnegativepat pats--- match "" = True--- match pat = matchregex (abspat pat) matchee--- where --- matchee = if not (':' `elem` pat) && not (isnegativepat pat)--- then accountLeafName str--- else str---- | Do the positives in these patterns permit a match for this string ?-match_positive_pats :: [String] -> String -> Bool-match_positive_pats pats str = (null ps) || (any match ps)- where- ps = positivepats pats- match "" = True- match p = matchregex (abspat p) matchee- where - matchee | ':' `elem` p = str- | otherwise = accountLeafName str---- | Do the negatives in these patterns prevent a match for this string ?-match_negative_pats :: [String] -> String -> Bool-match_negative_pats pats str = (not $ null ns) && (any match ns)- where- ns = map abspat $ negativepats pats- match "" = True- match p = matchregex (abspat p) str--negateprefix = "not:"-isnegativepat pat = negateprefix `isPrefixOf` pat-abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat-positivepats = filter (not . isnegativepat)-negativepats = filter isnegativepat-matchregex pat str = null pat || containsRegex (mkRegexWithOpts pat True False) str
Ledger/Amount.hs view
@@ -39,7 +39,6 @@ module Ledger.Amount where-import qualified Data.Map as Map import Ledger.Utils import Ledger.Types import Ledger.Commodity@@ -77,13 +76,13 @@ -- 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 ac aq ap) b@(Amount bc bq bp) = +amountop op a@(Amount _ _ _) (Amount bc bq _) = Amount bc ((quantity $ convertAmountTo bc a) `op` bq) Nothing -- | Convert an amount to the commodity of its saved price, if any. costOfAmount :: Amount -> Amount costOfAmount a@(Amount _ _ Nothing) = a-costOfAmount a@(Amount _ q (Just price))+costOfAmount (Amount _ q (Just price)) | isZeroMixedAmount price = nullamt | otherwise = Amount pc (pq*q) Nothing where (Amount pc pq _) = head $ amounts price@@ -91,15 +90,16 @@ -- | 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 p) = Amount c2 (q * conversionRate c1 c2) Nothing+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-showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) q pri)- | sym=="AUTO" = "" -- can display one of these in an error message- | side==L = printf "%s%s%s%s" sym space quantity price- | side==R = printf "%s%s%s%s" quantity space sym price+showAmount (Amount (Commodity {symbol="AUTO"}) _ _) = "" -- can appear in an error message+showAmount a@(Amount (Commodity {symbol=sym,side=side,spaced=spaced}) _ pri) =+ case side of+ L -> printf "%s%s%s%s" sym space quantity price+ R -> printf "%s%s%s%s" quantity space sym price where space = if spaced then " " else "" quantity = showAmount' a
Ledger/Commodity.hs view
@@ -8,7 +8,6 @@ -} module Ledger.Commodity where-import qualified Data.Map as Map import Ledger.Utils import Ledger.Types @@ -36,5 +35,5 @@ -- | Find the conversion rate between two commodities. Currently returns 1. conversionRate :: Commodity -> Commodity -> Double-conversionRate oldc newc = 1+conversionRate _ _ = 1
Ledger/Dates.hs view
@@ -19,16 +19,9 @@ module Ledger.Dates where -import Data.Time.Clock import Data.Time.Format-import Data.Time.Calendar-import Data.Time.Calendar.MonthDay import Data.Time.Calendar.OrdinalDate-import Data.Time.Calendar.WeekDate-import Data.Time.LocalTime-import System.Locale (defaultTimeLocale)-import Text.Printf-import Data.Maybe+import Locale (defaultTimeLocale) import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Char import Text.ParserCombinators.Parsec.Combinator@@ -49,24 +42,34 @@ -- | Split a DateSpan into one or more consecutive spans at the specified interval. splitSpan :: Interval -> DateSpan -> [DateSpan]-splitSpan i (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing]+splitSpan _ (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] splitSpan NoInterval s = [s]-splitSpan Daily s = splitspan start next s where (start,next) = (startofday,nextday)-splitSpan Weekly s = splitspan start next s where (start,next) = (startofweek,nextweek)-splitSpan Monthly s = splitspan start next s where (start,next) = (startofmonth,nextmonth)-splitSpan Quarterly s = splitspan start next s where (start,next) = (startofquarter,nextquarter)-splitSpan Yearly s = splitspan start next s where (start,next) = (startofyear,nextyear)+splitSpan Daily s = splitspan startofday nextday s+splitSpan Weekly s = splitspan startofweek nextweek s+splitSpan Monthly s = splitspan startofmonth nextmonth s+splitSpan Quarterly s = splitspan startofquarter nextquarter s+splitSpan Yearly s = splitspan startofyear nextyear s +splitspan :: (Day -> Day) -> (Day -> Day) -> DateSpan -> [DateSpan] splitspan _ _ (DateSpan Nothing Nothing) = []-splitspan startof next (DateSpan Nothing (Just e)) = [DateSpan (Just $ startof e) (Just $ next $ startof e)]-splitspan startof next (DateSpan (Just b) Nothing) = [DateSpan (Just $ startof b) (Just $ next $ startof b)]-splitspan startof next s@(DateSpan (Just b) (Just e))- | b == e = [s]- | otherwise = splitspan' startof next s- where splitspan' startof next (DateSpan (Just b) (Just e))- | b >= e = []- | otherwise = [DateSpan (Just $ startof b) (Just $ next $ startof b)] - ++ splitspan' startof next (DateSpan (Just $ next $ startof b) (Just e))+splitspan start next (DateSpan Nothing (Just e)) = [DateSpan (Just $ start e) (Just $ next $ start e)]+splitspan start next (DateSpan (Just b) Nothing) = [DateSpan (Just $ start b) (Just $ next $ start b)]+splitspan start next span@(DateSpan (Just b) (Just e))+ | b == e = [span]+ | otherwise = splitspan' start next span+ 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))+ where s = start b+ n = next s+ splitspan' _ _ _ = error "won't happen, avoids warnings"++-- | Count the days in a DateSpan, or if it is open-ended return Nothing.+daysInSpan :: DateSpan -> Maybe Integer+daysInSpan (DateSpan (Just d1) (Just d2)) = Just $ diffDays d2 d1+daysInSpan _ = Nothing -- | Parse a period expression to an Interval and overall DateSpan using -- the provided reference date.@@ -84,7 +87,7 @@ spanFromSmartDate :: Day -> SmartDate -> DateSpan spanFromSmartDate refdate sdate = DateSpan (Just b) (Just e) where- (ry,rm,rd) = toGregorian refdate+ (ry,rm,_) = toGregorian refdate (b,e) = span sdate span :: SmartDate -> (Day,Day) span ("","","today") = (refdate, nextday refdate)
Ledger/IO.hs view
@@ -5,8 +5,6 @@ module Ledger.IO where import Control.Monad.Error-import Data.Time.Clock-import Data.Time.LocalTime (LocalTime) import Ledger.Ledger (cacheLedger) import Ledger.Parse (parseLedger) import Ledger.RawLedger (canonicaliseAmounts,filterRawLedger)@@ -15,14 +13,13 @@ import System.Directory (getHomeDirectory) import System.Environment (getEnv) import System.IO-import Text.ParserCombinators.Parsec-import qualified Data.Map as Map (lookup)+import System.FilePath ((</>)) -ledgerdefaultpath = "~/.ledger"-timelogdefaultpath = "~/.timelog"-ledgerenvvar = "LEDGER"-timelogenvvar = "TIMELOG"+ledgerenvvar = "LEDGER"+timelogenvvar = "TIMELOG"+ledgerdefaultfilename = ".ledger"+timelogdefaultfilename = ".timelog" -- | A tuple of arguments specifying how to filter a raw ledger file: -- @@ -51,12 +48,18 @@ -- | Get the user's default ledger file path. myLedgerPath :: IO String myLedgerPath = - getEnv ledgerenvvar `catch` \_ -> return ledgerdefaultpath+ getEnv ledgerenvvar `catch` + (\_ -> do+ home <- getHomeDirectory+ return $ home </> ledgerdefaultfilename) -- | Get the user's default timelog file path. myTimelogPath :: IO String myTimelogPath =- getEnv timelogenvvar `catch` \_ -> return timelogdefaultpath+ getEnv timelogenvvar `catch`+ (\_ -> do+ home <- getHomeDirectory+ return $ home </> timelogdefaultfilename) -- | Read the user's default ledger file, or give an error. myLedger :: IO Ledger@@ -68,13 +71,12 @@ -- | Read a ledger from this file, with no filtering, or give an error. readLedger :: FilePath -> IO Ledger-readLedger f = tildeExpand f >>= readLedgerWithIOArgs noioargs+readLedger = readLedgerWithIOArgs noioargs -- | Read a ledger from this file, filtering according to the io args, -- | or give an error. readLedgerWithIOArgs :: IOArgs -> FilePath -> IO Ledger readLedgerWithIOArgs ioargs f = do- t <- getCurrentLocalTime s <- readFile f rl <- rawLedgerFromString s return $ filterAndCacheLedger ioargs s rl@@ -94,14 +96,14 @@ $ canonicaliseAmounts costbasis rl ){rawledgertext=rawtext} --- | Expand ~ in a file path (does not handle ~name).-tildeExpand :: FilePath -> IO FilePath-tildeExpand ('~':[]) = getHomeDirectory-tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))---handle ~name, requires -fvia-C or ghc 6.8:---import System.Posix.User--- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs--- pw <- getUserEntryForName user--- return (homeDirectory pw ++ path)-tildeExpand xs = return xs+-- -- | Expand ~ in a file path (does not handle ~name).+-- tildeExpand :: FilePath -> IO FilePath+-- tildeExpand ('~':[]) = getHomeDirectory+-- tildeExpand ('~':'/':xs) = getHomeDirectory >>= return . (++ ('/':xs))+-- --handle ~name, requires -fvia-C or ghc 6.8:+-- --import System.Posix.User+-- -- tildeExpand ('~':xs) = do let (user, path) = span (/= '/') xs+-- -- pw <- getUserEntryForName user+-- -- return (homeDirectory pw ++ path)+-- tildeExpand xs = return xs
Ledger/Ledger.hs view
@@ -57,12 +57,10 @@ import Data.Map ((!)) import Ledger.Utils import Ledger.Types-import Ledger.Amount+import Ledger.Account () import Ledger.AccountName-import Ledger.Account import Ledger.Transaction import Ledger.RawLedger-import Ledger.LedgerTransaction instance Show Ledger where@@ -156,7 +154,7 @@ ledgerSubAccounts l Account{aname=a} = map (ledgerAccount l) $ filter (`isSubAccountNameOf` a) $ accountnames l --- | List a ledger's transactions.+-- | List a ledger's "transactions", ie postings with transaction info attached. ledgerTransactions :: Ledger -> [Transaction] ledgerTransactions l = rawLedgerTransactions $ rawledger l @@ -168,7 +166,7 @@ ledgerAccountTreeAt :: Ledger -> Account -> Maybe (Tree Account) ledgerAccountTreeAt l acct = subtreeat acct $ ledgerAccountTree 9999 l --- | The date span containing all the ledger's (filtered) transactions,+-- | The (fully specified) date span containing all the ledger's (filtered) transactions, -- or DateSpan Nothing Nothing if there are none. ledgerDateSpan :: Ledger -> DateSpan ledgerDateSpan l@@ -198,6 +196,9 @@ transactions :: Ledger -> [Transaction] transactions = ledgerTransactions++commodities :: Ledger -> [Commodity]+commodities = nub . rawLedgerCommodities . rawledger accounttree :: Int -> Ledger -> Tree Account accounttree = ledgerAccountTree
Ledger/LedgerTransaction.hs view
@@ -57,15 +57,13 @@ showLedgerTransaction' :: Bool -> LedgerTransaction -> String showLedgerTransaction' elide t = - unlines $ [{-precedingcomment ++ -}description] ++ (showpostings $ ltpostings t) ++ [""]+ unlines $ [description] ++ (showpostings $ ltpostings t) ++ [""] where- precedingcomment = ltpreceding_comment_lines t description = concat [date, status, code, desc] -- , comment] date = showdate $ ltdate t status = if ltstatus t then " *" else "" code = if (length $ ltcode t) > 0 then (printf " (%s)" $ ltcode t) else "" desc = " " ++ ltdescription t- comment = if (length $ ltcomment t) > 0 then " ; "++(ltcomment t) else "" showdate d = printf "%-10s" (showDate d) showpostings ps | elide && length ps > 1 && isLedgerTransactionBalanced t@@ -74,11 +72,22 @@ where showposting p = showacct p ++ " " ++ (showamount $ pamount p) ++ (showcomment $ pcomment p) showpostingnoamt p = rstrip $ showacct p ++ " " ++ (showcomment $ pcomment p)- showacct p = " " ++ showstatus p ++ (showaccountname $ paccount p)+ showacct p = " " ++ showstatus p ++ (printf "%-34s" $ showAccountName (Just 34) (ptype p) (paccount p)) showamount = printf "%12s" . showMixedAmount- showaccountname s = printf "%-34s" s showcomment s = if (length s) > 0 then " ; "++s else "" showstatus p = if pstatus p then "* " else ""++-- | Show an account name, clipped to the given width if any, and+-- appropriately bracketed/parenthesised for the given posting type.+showAccountName :: Maybe Int -> PostingType -> AccountName -> String+showAccountName w = fmt+ where+ fmt RegularPosting = take w'+ fmt VirtualPosting = parenthesise . reverse . take (w'-2) . reverse+ fmt BalancedVirtualPosting = bracket . reverse . take (w'-2) . reverse+ w' = fromMaybe 999999 w+ parenthesise s = "("++s++")"+ bracket s = "["++s++"]" isLedgerTransactionBalanced :: LedgerTransaction -> Bool isLedgerTransactionBalanced (LedgerTransaction {ltpostings=ps}) =
Ledger/Parse.hs view
@@ -7,26 +7,20 @@ module Ledger.Parse where import Prelude hiding (readFile, putStr, print)-import Control.Monad import Control.Monad.Error import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Char-import Text.ParserCombinators.Parsec.Language import Text.ParserCombinators.Parsec.Combinator-import qualified Text.ParserCombinators.Parsec.Token as P import System.Directory import System.IO.UTF8 import System.IO (stdin)-import qualified Data.Map as Map-import Data.Time.LocalTime-import Data.Time.Calendar import Ledger.Utils import Ledger.Types import Ledger.Dates+import Ledger.AccountName (accountNameFromComponents,accountNameComponents) import Ledger.Amount import Ledger.LedgerTransaction-import Ledger.Commodity-import Ledger.TimeLog+import Ledger.Posting import Ledger.RawLedger import System.FilePath(takeDirectory,combine) @@ -109,6 +103,7 @@ "include" -> ledgerInclude "account" -> ledgerAccountBegin "end" -> ledgerAccountEnd+ _ -> mzero ledgerInclude :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger)) ledgerInclude = do many1 spacenonewline@@ -289,9 +284,9 @@ many spacenonewline symbol1 <- commoditysymbol many spacenonewline- (Mixed [Amount c price pri]) <- someamount+ (Mixed [Amount c q _]) <- someamount restofline- return $ HistoricalPrice date symbol1 (symbol c) price+ return $ HistoricalPrice date symbol1 (symbol c) q -- like ledgerAccountBegin, updates the LedgerFileCtx ledgerDefaultYear :: GenParser Char LedgerFileCtx (ErrorT String IO (RawLedger -> RawLedger))@@ -318,7 +313,7 @@ let t = LedgerTransaction date status code description comment postings "" case balanceLedgerTransaction t of Right t' -> return t'- Left err -> error err+ Left err -> fail err ledgerdate :: GenParser Char LedgerFileCtx Day ledgerdate = try ledgerfulldate <|> ledgerpartialdate@@ -336,7 +331,7 @@ (_,m,d) <- md many spacenonewline y <- getYear- when (y==Nothing) $ error "partial date found, but no default year specified"+ when (y==Nothing) $ fail "partial date found, but no default year specified" return $ fromGregorian (fromJust y) (read m) (read d) ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime@@ -362,60 +357,39 @@ ledgerpostings = many1 $ try ledgerposting ledgerposting :: GenParser Char LedgerFileCtx Posting-ledgerposting = many1 spacenonewline >> choice [ normalposting, virtualposting, balancedvirtualposting ]--normalposting :: GenParser Char LedgerFileCtx Posting-normalposting = do+ledgerposting = do+ many1 spacenonewline status <- ledgerstatus account <- transactionaccountname- amount <- postingamount- many spacenonewline- comment <- ledgercomment- restofline- parent <- getParentAccount- return (Posting status account amount comment RegularPosting)--virtualposting :: GenParser Char LedgerFileCtx Posting-virtualposting = do- status <- ledgerstatus- char '('- account <- transactionaccountname- char ')'- amount <- postingamount- many spacenonewline- comment <- ledgercomment- restofline- parent <- getParentAccount- return (Posting status account amount comment VirtualPosting)--balancedvirtualposting :: GenParser Char LedgerFileCtx Posting-balancedvirtualposting = do- status <- ledgerstatus- char '['- account <- transactionaccountname- char ']'+ let (ptype, account') = (postingTypeFromAccountName account, unbracket account) amount <- postingamount many spacenonewline comment <- ledgercomment restofline- return (Posting status account amount comment BalancedVirtualPosting)+ return (Posting status account' amount comment ptype) -- Qualify with the parent account from parsing context transactionaccountname :: GenParser Char LedgerFileCtx AccountName transactionaccountname = liftM2 (++) getParentAccount ledgeraccountname --- | account names may have single spaces inside them, and are terminated by two or more spaces+-- | Account names may have single spaces inside them, and are terminated+-- by two or more spaces. They should have one or more components of at+-- least one character, separated by the account separator char.+ ledgeraccountname :: GenParser Char st String ledgeraccountname = do- accountname <- many1 (accountnamechar <|> singlespace)- return $ striptrailingspace accountname+ a <- many1 (nonspace <|> singlespace)+ let a' = striptrailingspace a+ when (accountNameFromComponents (accountNameComponents a') /= a')+ (fail $ "accountname seems ill-formed: "++a')+ return a' where singlespace = try (do {spacenonewline; do {notFollowedBy spacenonewline; return ' '}}) -- couldn't avoid consuming a final space sometimes, harmless striptrailingspace s = if last s == ' ' then init s else s -accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace- <?> "account name character (non-bracket, non-parenthesis, non-whitespace)"+-- accountnamechar = notFollowedBy (oneOf "()[]") >> nonspace+-- <?> "account name character (non-bracket, non-parenthesis, non-whitespace)" postingamount :: GenParser Char st MixedAmount postingamount =@@ -566,16 +540,16 @@ char '[' (y,m,d) <- smartdate char ']'- let ltdate = parsedate $ printf "%04s/%02s/%02s" y m d- let matcher = \(Transaction{tdate=d}) -> - case op of- "<" -> d < ltdate- "<=" -> d <= ltdate- "=" -> d == ltdate- "==" -> d == ltdate -- just in case- ">=" -> d >= ltdate- ">" -> d > ltdate- return matcher + let date = parsedate $ printf "%04s/%02s/%02s" y m d+ test op = return $ (`op` date) . tdate+ case op of+ "<" -> test (<)+ "<=" -> test (<=)+ "=" -> test (==)+ "==" -> test (==)+ ">=" -> test (>=)+ ">" -> test (>)+ _ -> mzero compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"]
Ledger/Posting.hs view
@@ -22,14 +22,14 @@ nullrawposting = Posting False "" nullmixedamt "" RegularPosting showPosting :: Posting -> String-showPosting (Posting s a amt _ ttype) = +showPosting (Posting _ a amt _ ttype) = concatTopPadded [showaccountname a ++ " ", showamount amt] where showaccountname = printf "%-22s" . bracket . elideAccountName width (bracket,width) = case ttype of- BalancedVirtualPosting -> (\s -> "["++s++"]", 20)- VirtualPosting -> (\s -> "("++s++")", 20)- otherwise -> (id,22)+ BalancedVirtualPosting -> (\s -> "["++s++"]", 20)+ VirtualPosting -> (\s -> "("++s++")", 20)+ _ -> (id,22) showamount = padleft 12 . showMixedAmountOrZero isReal :: Posting -> Bool@@ -43,3 +43,9 @@ hasAmount :: Posting -> Bool hasAmount = (/= missingamt) . pamount++postingTypeFromAccountName a+ | head a == '[' && last a == ']' = BalancedVirtualPosting+ | head a == '(' && last a == ')' = VirtualPosting+ | otherwise = RegularPosting+
Ledger/RawLedger.hs view
@@ -13,7 +13,6 @@ import Ledger.Types import Ledger.AccountName import Ledger.Amount-import Ledger.LedgerTransaction import Ledger.Transaction import Ledger.Posting import Ledger.TimeLog@@ -164,7 +163,7 @@ where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 --- | The date span containing all the raw ledger's transactions,+-- | The (fully specified) date span containing all the raw ledger's transactions, -- or DateSpan Nothing Nothing if there are none. rawLedgerDateSpan :: RawLedger -> DateSpan rawLedgerDateSpan rl@@ -172,3 +171,17 @@ | otherwise = DateSpan (Just $ ltdate $ head ts) (Just $ addDays 1 $ ltdate $ last ts) where ts = sortBy (comparing ltdate) $ ledger_txns rl++-- | Check if a set of ledger account/description patterns matches the+-- given account name or entry description. Patterns are case-insensitive+-- regular expression strings; those beginning with - are anti-patterns.+matchpats :: [String] -> String -> Bool+matchpats pats str =+ (null positives || any match positives) && (null negatives || not (any match negatives))+ where+ (negatives,positives) = partition isnegativepat pats+ match "" = True+ match pat = containsRegex (abspat pat) str+ negateprefix = "not:"+ isnegativepat pat = negateprefix `isPrefixOf` pat+ abspat pat = if isnegativepat pat then drop (length negateprefix) pat else pat
Ledger/TimeLog.hs view
@@ -12,7 +12,6 @@ import Ledger.Types import Ledger.Dates import Ledger.Commodity-import Ledger.Amount import Ledger.LedgerTransaction instance Show TimeLogEntry where @@ -82,7 +81,6 @@ itod = localTimeOfDay itime otod = localTimeOfDay otime idate = localDay itime- odate = localDay otime hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc amount = Mixed [hours hrs] ps = [Posting False acctname amount "" RegularPosting
Ledger/Transaction.hs view
@@ -14,17 +14,17 @@ import Ledger.Utils import Ledger.Types import Ledger.Dates-import Ledger.LedgerTransaction-import Ledger.Posting+import Ledger.LedgerTransaction (showAccountName) import Ledger.Amount instance Show Transaction where show=showTransaction showTransaction :: Transaction -> String-showTransaction (Transaction eno stat d desc a amt ttype) = - s ++ unwords [showDate d,desc,a,show amt,show ttype]+showTransaction (Transaction _ stat d desc a amt ttype) = + s ++ unwords [showDate d,desc,a',show amt,show ttype] where s = if stat then " *" else ""+ a' = showAccountName Nothing ttype a -- | Convert a 'LedgerTransaction' to two or more 'Transaction's. An id number -- is attached to the transactions to preserve their grouping - it should
Ledger/Utils.hs view
@@ -19,7 +19,7 @@ module Debug.Trace, module Ledger.Utils, module Text.Printf,-module Text.Regex,+module Text.RegexPR, module Test.HUnit, ) where@@ -39,7 +39,7 @@ import System.IO.UTF8 import Test.HUnit import Text.Printf-import Text.Regex+import Text.RegexPR import Text.ParserCombinators.Parsec @@ -63,6 +63,17 @@ True -> take (width - 2) s ++ ".." False -> s +underline :: String -> String+underline s = s' ++ replicate (length s) '-' ++ "\n"+ where s'+ | last s == '\n' = s+ | otherwise = s ++ "\n"++unbracket :: String -> String+unbracket s+ | (head s == '[' && last s == ']') || (head s == '(' && last s == ')') = init $ tail s+ | otherwise = s+ -- | Join multi-line strings as side-by-side rectangular strings of the same height, top-padded. concatTopPadded :: [String] -> String concatTopPadded strs = intercalate "\n" $ map concat $ transpose padded@@ -136,12 +147,10 @@ -- regexps -instance Show Regex where show r = "a Regex"--containsRegex :: Regex -> String -> Bool-containsRegex r s = case matchRegex r s of+containsRegex :: String -> String -> Bool+containsRegex r s = case matchRegexPR ("(?i)"++r) s of Just _ -> True- otherwise -> False+ _ -> False -- lists@@ -175,7 +184,7 @@ -- | get the sub-tree for the specified node value in the first tree in -- forest in which it occurs. subtreeinforest :: Eq a => a -> [Tree a] -> Maybe (Tree a)-subtreeinforest v [] = Nothing+subtreeinforest _ [] = Nothing subtreeinforest v (t:ts) = case (subtreeat v t) of Just t' -> Just t' Nothing -> subtreeinforest v ts@@ -204,7 +213,7 @@ -- | show a compact ascii representation of a tree showtree :: Show a => Tree a -> String-showtree = unlines . filter (containsRegex (mkRegex "[^ |]")) . 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@@ -220,6 +229,9 @@ -- | labelled trace - like strace, with a newline and a label prepended ltrace :: Show a => String -> a -> a ltrace l a = trace (l ++ ": " ++ show a) a++-- | trace an expression using a custom show function+tracewith f e = trace (f e) e -- parsing
Options.hs view
@@ -5,16 +5,9 @@ module Options where-import System import System.Console.GetOpt import System.Environment-import Text.Printf-import Text.RegexPR (gsubRegexPRBy)-import Data.Char (toLower)-import Ledger.IO (IOArgs,- ledgerenvvar,ledgerdefaultpath,myLedgerPath,- timelogenvvar,timelogdefaultpath,myTimelogPath)-import Ledger.Parse+import Ledger.IO (IOArgs,myLedgerPath,myTimelogPath) import Ledger.Utils import Ledger.Types import Ledger.Dates@@ -39,6 +32,7 @@ " histogram - show transaction counts 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" ++ #endif@@ -83,6 +77,7 @@ ,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" ]@@ -109,6 +104,7 @@ Help | Verbose | Version+ | BinaryFilename | Debug | DebugNoUI deriving (Show,Eq)@@ -174,19 +170,17 @@ -- | Figure out the reporting interval, if any, specified by the options. -- If there is a period option, the others are ignored. intervalFromOpts :: [Opt] -> Interval-intervalFromOpts opts- | not $ null popts = fst $ parsePeriodExpr refdate $ last popts- | null otheropts = NoInterval- | otherwise = case last otheropts of- WeeklyOpt -> Weekly- MonthlyOpt -> Monthly- QuarterlyOpt -> Quarterly- YearlyOpt -> Yearly+intervalFromOpts opts =+ case (periodopts, intervalopts) of+ ((p:_), _) -> fst $ parsePeriodExpr d p where d = parsedate "0001/01/01" -- unused+ (_, (WeeklyOpt:_)) -> Weekly+ (_, (MonthlyOpt:_)) -> Monthly+ (_, (QuarterlyOpt:_)) -> Quarterly+ (_, (YearlyOpt:_)) -> Yearly+ (_, _) -> NoInterval where- popts = optValuesForConstructor Period opts- otheropts = filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts- -- doesn't affect the interval, but parsePeriodExpr needs something- refdate = parsedate "0001/01/01"+ periodopts = reverse $ optValuesForConstructor Period opts+ intervalopts = reverse $ filter (`elem` [WeeklyOpt,MonthlyOpt,QuarterlyOpt,YearlyOpt]) opts -- | Get the value of the (last) depth option, if any, otherwise a large number. depthFromOpts :: [Opt] -> Int
− PrintCommand.hs
@@ -1,27 +0,0 @@-{-| --A ledger-compatible @print@ command.---}--module PrintCommand-where-import Prelude hiding (putStr)-import Ledger-import Options-import System.IO.UTF8----- | Print ledger transactions in standard format.-print' :: [Opt] -> [String] -> Ledger -> IO ()-print' opts args l = putStr $ showLedgerTransactions opts args l--showLedgerTransactions :: [Opt] -> [String] -> Ledger -> String-showLedgerTransactions opts args l = concatMap showLedgerTransaction $ filteredtxns- where - filteredtxns = ledger_txns $ - filterRawLedgerPostingsByDepth depth $ - filterRawLedgerTransactionsByAccount apats $ - rawledger l- depth = depthFromOpts opts- (apats,_) = parsePatternArgs args
README view
@@ -1,17 +1,17 @@+hledger User's Guide+==================== Welcome to hledger! -hledger is a partial haskell clone of John Wiegley's text-based accounting-tool, ledger (http://wiki.github.com/jwiegley/ledger). hledger generates-ledger-compatible register & balance reports from a plain text journal,-allows precise batch-mode or interactive querying, and demonstrates a pure-functional implementation of ledger. For more information, see-http://hledger.org .+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>+Copyright (c) 2007-2009 Simon Michael <simon@joyful.com> and contributors. Released under GPL version 3 or later. - Installation ------------ @@ -40,8 +40,8 @@ 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 narrow the-results. Here are some commands to try::+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@@ -52,17 +52,16 @@ 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 # interactive ui, if installed with -fvty- hledger web # web ui, installed with -fhapps- echo >new; hledger -f new add # input transactions from the command line-+ 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 timeclock.el-format timelog entries. As a-convenience, if you invoke hledger via a link or copy named "hours", it-uses your timelog file (~/.timelog or $TIMELOG) by default.::+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]] @@ -74,13 +73,13 @@ The clockin description is treated as an account name. Here are some queries to try:: - ln -s `which hledger` ~/bin/hours # add the "hours" symlink in your path+ ln -s `which hledger` ~/bin/hours # set up "hours" in your path export TIMELOG=sample.timelog- hours # time logged today, if any- hours -p 'last month' # last month- hours -p thisyear # the space is optional- hours -p 'from 1/15' register proj # project sessions since last jan 15- hours -p 'weekly this year' reg --depth 1 # weekly time summary+ 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 --------@@ -88,8 +87,7 @@ 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 patterns, the LEDGER environment variable, and these commands-and options::+description filtering, and these commands and options:: Commands: balance [REGEXP]... show balance totals for matching accounts@@ -127,11 +125,12 @@ display expressions consisting of a simple date predicate. Also the following new commands are supported:: - histogram show a (textual) barchart of transaction counts- add input transactions from the command line+ 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 interactive text ui (only on unix platforms)+ ui a simple curses ui (only on unix platforms) web a simple web ui+ stats report some ledger statistics test run self-tests ledger features not supported@@ -213,4 +212,4 @@ * 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 the trailing spaces after amount-elided postings+* hledger doesn't print trailing spaces after amount-elided postings
− RegisterCommand.hs
@@ -1,118 +0,0 @@-{-| --A ledger-compatible @register@ command.---}--module RegisterCommand-where-import Prelude hiding (putStr)-import qualified Data.Map as Map-import Data.Map ((!))-import Ledger-import Options-import System.IO.UTF8----- | Print a register report.-register :: [Opt] -> [String] -> Ledger -> IO ()-register opts args l = putStr $ showRegisterReport opts args l--{- |-Generate the register report. Each ledger entry is displayed as two or-more lines like this:--@-date (10) description (20) account (22) amount (11) balance (12)-DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA- aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA- ... ... ...-@--}-showRegisterReport :: [Opt] -> [String] -> Ledger -> String-showRegisterReport opts args l- | interval == NoInterval = showtxns displayedts nulltxn startbal- | 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)- | otherwise = id- filterempties- | Empty `elem` opts = id- | otherwise = filter (not . isZeroMixedAmount . tamount)- (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 t = True- matchdisplayopt (Just e) t = (fromparse $ parsewith datedisplayexpr e) t- dopt = displayFromOpts opts- empty = Empty `elem` opts- depth = depthFromOpts opts- summaryts = concatMap summarisespan (zip spans [1..])- summarisespan (s,n) = summariseTransactionsInDateSpan s n depth empty (transactionsinspan s)- transactionsinspan s = filter (isTransactionInDateSpan s) displayedts- spans = splitSpan interval (ledgerDateSpan l)- --- | Convert a date span (representing a reporting interval) and a list of--- transactions within it to a new list of transactions aggregated by--- account, which showtxns will render as a summary for this interval.--- --- As usual with date spans the end date is exclusive, but for display--- purposes we show the previous day as end date, like ledger.--- --- A unique tnum value is provided so that the new transactions will be--- grouped as one entry.--- --- When a depth argument is present, transactions to accounts of greater--- depth are aggregated where possible.--- --- The showempty flag forces the display of a zero-transaction span--- and also zero-transaction accounts within the span.-summariseTransactionsInDateSpan :: DateSpan -> Int -> Int -> Bool -> [Transaction] -> [Transaction]-summariseTransactionsInDateSpan (DateSpan b e) tnum depth showempty ts- | null ts && showempty = [txn]- | null ts = []- | otherwise = summaryts'- where- txn = nulltxn{tnum=tnum, tdate=b', tdescription="- "++(showDate $ addDays (-1) e')}- b' = fromMaybe (tdate $ head ts) b- e' = fromMaybe (tdate $ last ts) e- summaryts'- | showempty = summaryts- | otherwise = filter (not . isZeroMixedAmount . tamount) summaryts- txnanames = sort $ nub $ map taccount ts- -- aggregate balances by account, like cacheLedger, then do depth-clipping- (_,_,exclbalof,inclbalof) = groupTransactions ts- clippedanames = clipAccountNames depth txnanames- isclipped a = accountNameLevel a >= depth- balancetoshowfor a =- (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)- summaryts = [txn{taccount=a,tamount=balancetoshowfor a} | a <- clippedanames]--clipAccountNames :: Int -> [AccountName] -> [AccountName]-clipAccountNames d as = nub $ map (clip d) as - where clip d = accountNameFromComponents . take d . accountNameComponents---- | Show transactions one per line, with each date/description appearing--- only once, and a running balance.-showtxns [] _ _ = ""-showtxns (t@Transaction{tamount=a}:ts) tprev bal = this ++ showtxns ts t bal'- where- this = showtxn (t `issame` tprev) t bal'- issame t1 t2 = tnum t1 == tnum t2- 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)- Transaction{tstatus=s,tdate=da,tdescription=de,taccount=a,tamount=amt,ttype=tt} = t-
Tests.hs view
@@ -84,7 +84,9 @@ {- @ $ printf "2009/1/1 a\n b 1.1\n c -1\n" | runhaskell hledger.hs -f- reg 2>&1 ; true-hledger.hs: could not balance this transaction, amounts do not add up to zero:+"-" (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@@ -92,6 +94,15 @@ @ +@+$ 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@@ -141,6 +152,44 @@ --@++@+$ 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+"-" (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@@ -150,24 +199,27 @@ where import qualified Data.Map as Map import Data.Time.Format-import System.Locale (defaultTimeLocale)+import Locale (defaultTimeLocale) import Text.ParserCombinators.Parsec-import Test.HUnit-import Test.HUnit.Tools (assertRaises, runVerboseTests)+import Test.HUnit.Tools (runVerboseTests)+import System.Exit (exitFailure,exitSuccess)++import Commands.All import Ledger-import Utils import Options-import BalanceCommand-import PrintCommand-import RegisterCommand+import Utils -runtests opts args = runner flattests+runtests opts args = do+ (counts,_) <- runner ts+ if errors counts > 0 || (failures counts > 0)+ then exitFailure+ else exitSuccess where runner | (Verbose `elem` opts) = runVerboseTests | otherwise = \t -> runTestTT t >>= return . (flip (,) 0)- flattests = TestList $ filter matchname $ concatMap tflatten tests- deeptests = tfilter matchname $ TestList tests+ ts = TestList $ filter matchname $ concatMap tflatten tests+ --ts = tfilter matchname $ TestList tests -- unflattened matchname = matchpats args . tname -- | Get a Test's label, or the empty string.@@ -445,6 +497,9 @@ "use the greatest precision" ~: do (rawLedgerPrecisions $ canonicaliseAmounts False $ rawLedgerWithAmounts ["1","2.00"]) `is` [2,2] + ,"commodities" ~: do+ 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@@ -453,6 +508,13 @@ [Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" [Begin "2005", End "2007",Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)" + -- don't know what this should do+ -- ,"elideAccountName" ~: do+ -- (elideAccountName 50 "aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa"+ -- `is` "aa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa")+ -- (elideAccountName 20 "aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa:aaaaaaaaaaaaaaaaaaaa"+ -- `is` "aa:aa:aaaaaaaaaaaaaa")+ ,"entriesFromTimeLogEntries" ~: do today <- getCurrentDay now' <- getCurrentTime@@ -461,7 +523,6 @@ nowstr = showtime now yesterday = prevday today clockin t a = TimeLogEntry In t a- clockout t = TimeLogEntry Out t "" mktime d s = LocalTime d $ fromMaybe midnight $ parseTime defaultTimeLocale "%H:%M:%S" s showtime t = formatTime defaultTimeLocale "%H:%M" t assertEntriesGiveStrings name es ss = assertEqual name ss (map ltdescription $ entriesFromTimeLogEntries now es)@@ -561,7 +622,6 @@ return () ,"ledgerFile" ~: do- let now = getCurrentLocalTime assertBool "ledgerFile should parse an empty file" $ (isRight $ parseWithCtx 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@@ -578,6 +638,12 @@ let t = parseWithCtx 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:") ,"ledgerposting" ~: do parseWithCtx ledgerposting rawposting1_str `parseis` rawposting1
− UICommand.hs
@@ -1,391 +0,0 @@-{-| --A simple text UI for hledger, based on the vty library.---}--module UICommand-where-import qualified Data.Map as Map-import Data.Map ((!))-import Graphics.Vty-import qualified Data.ByteString.Char8 as B-import Ledger-import Options-import BalanceCommand-import RegisterCommand-import PrintCommand---helpmsg = "(b)alance, (r)egister, (p)rint, (right) to drill down, (left) to back up, (q)uit"--instance Show Vty where show v = "a Vty"---- | The application state when running the ui command.-data AppState = AppState {- av :: Vty -- ^ the vty context- ,aw :: Int -- ^ window width- ,ah :: Int -- ^ window height- ,amsg :: String -- ^ status message- ,aopts :: [Opt] -- ^ command-line opts- ,aargs :: [String] -- ^ command-line args- ,aledger :: Ledger -- ^ parsed ledger- ,abuf :: [String] -- ^ lines of the current buffered view- ,alocs :: [Loc] -- ^ user's navigation trail within the UI- -- ^ never null, head is current location- } deriving (Show)---- | A location within the user interface.-data Loc = Loc {- scr :: Screen -- ^ one of the available screens- ,sy :: Int -- ^ viewport y scroll position- ,cy :: Int -- ^ cursor y position- } deriving (Show)---- | The screens available within the user interface.-data Screen = BalanceScreen -- ^ like hledger balance, shows accounts- | RegisterScreen -- ^ like hledger register, shows transaction-postings- | PrintScreen -- ^ like hledger print, shows ledger transactions- | LedgerScreen -- ^ shows the raw ledger- deriving (Eq,Show)---- | Run the interactive text ui.-ui :: [Opt] -> [String] -> Ledger -> IO ()-ui opts args l = do- v <- mkVty- (w,h) <- getSize v- let opts' = SubTotal:opts- let a = enter BalanceScreen $ - AppState {- av=v- ,aw=w- ,ah=h- ,amsg=helpmsg- ,aopts=opts'- ,aargs=args- ,aledger=l- ,abuf=[]- ,alocs=[]- }- go a ---- | Update the screen, wait for the next event, repeat.-go :: AppState -> IO ()-go a@AppState{av=av,aw=aw,ah=ah,abuf=buf,amsg=amsg,aopts=opts,aargs=args,aledger=l} = do- when (not $ DebugNoUI `elem` opts) $ update av (renderScreen a)- k <- getEvent 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- EvKey KUp [] -> go $ moveUpAndPushEdge a- EvKey KDown [] -> go $ moveDownAndPushEdge a- EvKey KHome [] -> go $ moveToTop a- EvKey KUp [MCtrl] -> go $ moveToTop a- EvKey KUp [MShift] -> go $ moveToTop a- EvKey KEnd [] -> go $ moveToBottom a- EvKey KDown [MCtrl] -> go $ moveToBottom a- EvKey KDown [MShift] -> go $ moveToBottom a- EvKey KPageUp [] -> go $ prevpage a- EvKey KBS [] -> go $ prevpage a- EvKey (KASCII ' ') [MShift] -> go $ prevpage a- EvKey KPageDown [] -> go $ nextpage a- EvKey (KASCII ' ') [] -> go $ nextpage a- EvKey (KASCII 'q') [] -> shutdown av >> return ()--- EvKey KEsc [] -> shutdown av >> return ()- _ -> go a- where- bh = length buf- y = posY a---- app state modifiers---- | The number of lines currently available for the main data display area.-pageHeight :: AppState -> Int-pageHeight a = ah a - 1--setLocCursorY, setLocScrollY :: Int -> Loc -> Loc-setLocCursorY y l = l{cy=y}-setLocScrollY y l = l{sy=y}--cursorY, scrollY, posY :: AppState -> Int-cursorY = cy . loc-scrollY = sy . loc-posY a = scrollY a + cursorY a--setCursorY, setScrollY, setPosY :: Int -> AppState -> AppState-setCursorY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocCursorY y l-setScrollY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)} where l' = setLocScrollY y l-setPosY y a@AppState{alocs=(l:locs)} = a{alocs=(l':locs)}- where - l' = setLocScrollY sy $ setLocCursorY cy l- ph = pageHeight a- 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-updatePosY f a = setPosY (f $ posY a) a--resize :: Int -> Int -> AppState -> AppState-resize x y a = setCursorY cy' a{aw=x,ah=y}- where- cy = cursorY a- cy' = min cy (y-2)--moveToTop :: AppState -> AppState-moveToTop a = setPosY 0 a--moveToBottom :: AppState -> AppState-moveToBottom a = setPosY (length $ abuf a) a--moveUpAndPushEdge :: AppState -> AppState-moveUpAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)}- | cy > 0 = updateCursorY (subtract 1) a- | sy > 0 = updateScrollY (subtract 1) a- | otherwise = a--moveDownAndPushEdge :: AppState -> AppState-moveDownAndPushEdge a@AppState{alocs=(Loc{sy=sy,cy=cy}:_)}- | sy+cy >= bh = a- | cy < ph-1 = updateCursorY (+1) a- | otherwise = updateScrollY (+1) a- where - ph = pageHeight a- bh = length $ abuf a---- | Scroll down by page height or until we can just see the last line,--- without moving the cursor, or if we are already scrolled as far as--- possible then move the cursor to the last line.-nextpage :: AppState -> AppState-nextpage (a@AppState{abuf=b})- | sy < bh-jump = setScrollY sy' a- | otherwise = setCursorY (bh-sy) a- where- sy = scrollY a- jump = pageHeight a - 1- bh = length b- sy' = min (sy+jump) (bh-jump)---- | Scroll up by page height or until we can just see the first line,--- without moving the cursor, or if we are scrolled as far as possible--- then move the cursor to the first line.-prevpage :: AppState -> AppState-prevpage (a@AppState{abuf=b})- | sy > 0 = setScrollY sy' a- | otherwise = setCursorY 0 a- where- sy = scrollY a- jump = pageHeight a - 1- sy' = max (sy-jump) 0---- | Push a new UI location on to the stack.-pushLoc :: Loc -> AppState -> AppState-pushLoc l a = a{alocs=(l:alocs a)}--popLoc :: AppState -> AppState-popLoc a@AppState{alocs=locs}- | length locs > 1 = a{alocs=drop 1 locs}- | otherwise = a--clearLocs :: AppState -> AppState-clearLocs a = a{alocs=[]}--exit :: AppState -> AppState -exit = popLoc--loc :: AppState -> Loc-loc = head . alocs--screen :: AppState -> Screen-screen a = scr where (Loc scr _ _) = loc a---- | Enter a new screen, saving the old ui location on the stack.-enter :: Screen -> AppState -> AppState -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---- | Regenerate the display data appropriate for the current screen.-updateData :: AppState -> AppState-updateData a@AppState{aopts=opts,aargs=args,aledger=l}- | scr == BalanceScreen = a{abuf=lines $ showBalanceReport opts [] l, aargs=[]}- | scr == RegisterScreen = a{abuf=lines $ showRegisterReport opts args l}- | scr == PrintScreen = a{abuf=lines $ showLedgerTransactions opts args l}- | scr == LedgerScreen = a{abuf=lines $ rawledgertext l}- where scr = screen a--backout :: AppState -> AppState-backout a- | screen a == BalanceScreen = a- | otherwise = updateData $ popLoc a--drilldown :: AppState -> AppState-drilldown a- | screen a == BalanceScreen = enter RegisterScreen a{aargs=[currentAccountName a]}- | screen a == RegisterScreen = scrollToLedgerTransaction e $ enter PrintScreen a- | screen a == PrintScreen = a- -- screen a == PrintScreen = enter LedgerScreen a- -- screen a == LedgerScreen = a- where e = currentLedgerTransaction a---- | Get the account name currently highlighted by the cursor on the--- balance screen. Results undefined while on other screens.-currentAccountName :: AppState -> AccountName-currentAccountName a = accountNameAt (abuf a) (posY a)---- | Get the full name of the account being displayed at a specific line--- within the balance command's output.-accountNameAt :: [String] -> Int -> AccountName-accountNameAt buf lineno = accountNameFromComponents anamecomponents- where- namestohere = map (drop 22) $ take (lineno+1) buf- (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'- where- xs' = dropWhile moreindented xs- moreindented = (>= myindent) . indentof- myindent = indentof x- indentof = length . takeWhile (==' ')---- | If on the print screen, move the cursor to highlight the specified entry--- (or a reasonable guess). Doesn't work.-scrollToLedgerTransaction :: LedgerTransaction -> AppState -> AppState-scrollToLedgerTransaction e a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a- where- entryfirstline = head $ lines $ showLedgerTransaction $ e- halfph = pageHeight a `div` 2- y = fromMaybe 0 $ findIndex (== entryfirstline) buf- sy = max 0 $ y - halfph- cy = y - sy---- | Get the entry containing the transaction currently highlighted by the--- cursor on the register screen (or best guess). Results undefined while--- on other screens. Doesn't work.-currentLedgerTransaction :: AppState -> LedgerTransaction-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- acctamt = drop 32 $ safehead "" rest- safehead d ls = if null ls then d else head ls- (above,rest) = splitAt y buf- y = posY a---- | 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---- 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- }- 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)) --- | null ls = ([],[""])--- | otherwise = splitAt y ls--- ls = lines $ fitto w (h-1) $ unlines $ drop as $ buf--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- blankline = replicate w ' '--renderString :: Attr -> String -> Image-renderString attr s = vertcat $ map (renderBS attr . B.pack) rows- where- rows = lines $ fitto w h s- 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 ' ')) ----- the all-important theming engine--theme = 1--(defaultattr, - currentlineattr, - statusattr- ) = - case theme of- 1 -> ( -- restrained- attr- ,setBold attr- ,setRV attr- )- 2 -> ( -- colorful- setRV attr- ,setFG white $ setBG red $ attr- ,setFG black $ setBG green $ attr- )- 3 -> ( -- - setRV attr- ,setFG white $ setBG red $ attr- ,setRV attr- )--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--- }
Utils.hs view
@@ -8,13 +8,10 @@ module Utils where import Control.Monad.Error-import Data.Time.Clock import Ledger import Options (Opt,ledgerFilePathFromOpts,optsToIOArgs) import System.Directory (doesFileExist) import System.IO-import Text.ParserCombinators.Parsec-import qualified Data.Map as Map (lookup) -- | Parse the user's specified ledger file and run a hledger command on
Version.hs view
@@ -1,29 +1,60 @@ {-# OPTIONS_GHC -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.++-}+ module Version where+import System.Info (os, arch) import Ledger.Utils import Options (progname) --- updated by build process from VERSION-version = "0.5.1"-#ifdef PATCHES--- a "make" development build defines PATCHES from the repo state-patchlevel = "." ++ show PATCHES -- must be numeric !+-- version and PATCHLEVEL are set by the makefile+version = "0.6.0"++#ifdef PATCHLEVEL+patchlevel = "." ++ show PATCHLEVEL -- must be numeric ! #else patchlevel = "" #endif-buildversion = version ++ patchlevel -versionstr = prettify $ splitAtElement '.' buildversion+buildversion = version ++ patchlevel :: String++binaryfilename = prettify $ splitAtElement '.' buildversion :: String where prettify (major:minor:bugfix:patches:[]) =+ printf "hledger-%s.%s%s%s-%s-%s" major minor bugfix' patches' os' arch+ where+ bugfix'+ | bugfix `elem` ["0"{-,"98","99"-}] = ""+ | otherwise = "."++bugfix+ patches'+ | patches/="0" = "+"++patches+ | otherwise = ""+ os'+ | os == "darwin" = "mac"+ | 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 [] = 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 where bugfix' | bugfix `elem` ["0"{-,"98","99"-}] = "" | otherwise = "."++bugfix patches'- | patches/="0" = " + "++patches++" patches"+ | patches/="0" = "+"++patches++" patches" | otherwise = "" desc -- | bugfix=="98" = " (alpha)"@@ -31,10 +62,10 @@ | otherwise = "" prettify s = intercalate "." s -versionmsg = progname ++ " " ++ versionstr ++ configmsg ++ "\n"+versionmsg = progname ++ "-" ++ versionstr ++ configmsg :: String where configmsg- | null configflags = ""- | otherwise = ", built with " ++ intercalate ", " configflags+ | null configflags = " with no extras"+ | otherwise = " with " ++ intercalate ", " configflags configflags = tail ["" #ifdef VTY
− WebCommand.hs
@@ -1,127 +0,0 @@-{-| -A happs-based web UI for hledger.--}--module WebCommand-where-import Control.Monad.Trans (liftIO)-import Data.ByteString.Lazy.UTF8 (toString)-import qualified Data.Map as M-import Data.Map ((!))-import Data.Time.Clock-import Data.Time.Format-import System.Locale-import Control.Concurrent-import qualified Data.ByteString.Lazy.Char8 as B-import Happstack.Data (defaultValue)-import Happstack.Server-import Happstack.Server.HTTP.FileServe (fileServe)-import Happstack.State.Control (waitForTermination)-import System.Cmd (system)-import System.Info (os)-import System.Exit--import Ledger-import Options-import BalanceCommand-import RegisterCommand-import PrintCommand-import HistogramCommand---tcpport = 5000--web :: [Opt] -> [String] -> Ledger -> IO ()-web opts args l =- if Debug `elem` opts- then do- putStrLn $ printf "starting web server on port %d in debug mode" tcpport- simpleHTTP nullConf{port=tcpport} handlers- else do- putStrLn $ printf "starting web server on port %d" tcpport- tid <- forkIO $ simpleHTTP nullConf{port=tcpport} handlers- putStrLn "starting web browser"- openBrowserOn $ printf "http://localhost:%d/balance" tcpport- waitForTermination- putStrLn "shutting down web server..."- killThread tid- putStrLn "shutdown complete"-- where- handlers :: ServerPartT IO Response- handlers = msum- [methodSP GET $ withDataFn (look "a") $ \a -> templatise $ balancereport [a]- ,methodSP GET $ templatise $ balancereport []- ,dir "print" $ withDataFn (look "a") $ \a -> templatise $ printreport [a]- ,dir "print" $ templatise $ printreport []- ,dir "register" $ withDataFn (look "a") $ \a -> templatise $ registerreport [a]- ,dir "register" $ templatise $ registerreport []- ,dir "balance" $ withDataFn (look "a") $ \a -> templatise $ balancereport [a]- ,dir "balance" $ templatise $ balancereport []- ,dir "histogram" $ withDataFn (look "a") $ \a -> templatise $ histogramreport [a]- ,dir "histogram" $ templatise $ histogramreport []- ]- printreport apats = showLedgerTransactions opts (apats ++ args) l- registerreport apats = showRegisterReport opts (apats ++ args) l- balancereport [] = showBalanceReport opts args l- balancereport apats = showBalanceReport opts (apats ++ args) l'- where l' = cacheLedger apats (rawledger l) -- re-filter by account pattern each time- histogramreport [] = showHistogram opts args l- histogramreport apats = showHistogram opts (apats ++ args) l'- where l' = cacheLedger apats (rawledger l) -- re-filter by account pattern each time--templatise :: String -> ServerPartT IO Response-templatise s = do- r <- askRq- return $ setHeader "Content-Type" "text/html" $ toResponse $ maintemplate r s--maintemplate :: Request -> String -> String-maintemplate r = printf (unlines- ["<div style=float:right>"- ,"<form action=%s>search: <input name=a value=%s></form>"- ,"</div>"- ,"<div align=center style=width:100%%>"- ," <a href=balance>balance</a>"- ,"|"- ," <a href=register>register</a>"- ,"|"- ," <a href=print>print</a>"- ,"|"- ," <a href=histogram>histogram</a>"- ,"</div>"- ,"<pre>%s</pre>"- ])- (dropWhile (=='/') $ rqUri r)- (fromMaybe "" $ queryValue "a" r)--queryValues :: String -> Request -> [String]-queryValues q r = map (B.unpack . inputValue . snd) $ filter ((==q).fst) $ rqInputs r--queryValue :: String -> Request -> Maybe String-queryValue q r = case filter ((==q).fst) $ rqInputs r of- [] -> Nothing- is -> Just $ B.unpack $ inputValue $ snd $ head is---- | 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" = ["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);-
hledger.cabal view
@@ -1,36 +1,45 @@-Name: hledger--- updated by build process from VERSION-Version: 0.5.1-Category: Finance-Synopsis: A ledger-compatible text-based accounting tool.-Description: hledger is a partial haskell clone of John Wiegley's "ledger" text-based- accounting tool. It generates ledger-compatible register & balance reports- from a plain text journal, and demonstrates a functional implementation of ledger.-License: GPL-Stability: beta-Author: Simon Michael <simon@joyful.com>-Maintainer: Simon Michael <simon@joyful.com>-Homepage: http://hledger.org-Tested-With: GHC-Build-Type: Simple-License-File: LICENSE-Extra-Source-Files: README sample.ledger-Extra-Tmp-Files: -Cabal-Version: >= 1.2+name: hledger+-- Version is set by the makefile+version: 0.6+category: Finance+synopsis: A command-line (or curses or web-based) double-entry accounting tool.+description:+ hledger reads a plain text ledger file or timelog+ describing your transactions and displays precise+ balance and register reports via command-line, curses+ or web interface. It is a remix, in haskell, of John+ Wiegley's excellent c++ ledger. hledger aims to be a+ practical, accessible tool for end users and a useful+ library for finance-minded haskell programmers. -Flag vty+license: GPL+license-file: LICENSE+author: Simon Michael <simon@joyful.com>+maintainer: Simon Michael <simon@joyful.com>+homepage: http://hledger.org+bug-reports: http://code.google.com/p/hledger/issues+stability: experimental+tested-with: GHC==6.8, GHC==6.10+cabal-version: >= 1.2+build-type: Simple++extra-tmp-files:+extra-source-files:+ README+ sample.ledger+ sample.timelog++flag vty description: enable the curses ui default: False -Flag happs+flag happs description: enable the web ui default: False -Library- Build-Depends: base, containers, haskell98, directory, parsec, regex-compat,- old-locale, time, HUnit, filepath, utf8-string-- Exposed-modules:Ledger+library+ exposed-modules:+ Ledger Ledger.Account Ledger.AccountName Ledger.Amount@@ -46,27 +55,28 @@ Ledger.Transaction Ledger.Types Ledger.Utils--Executable hledger- Main-Is: hledger.hs-- Build-Depends: base, containers, haskell98, directory, parsec,- regex-compat, regexpr>=0.5.1, old-locale, time,- HUnit, mtl, bytestring, filepath, process, testpack,- regex-pcre, csv, split, utf8-string+ Build-Depends:+ base >= 3 && < 5+ ,containers+ ,directory+ ,filepath+ ,haskell98+ ,parsec+ ,time+ ,utf8-string >= 0.3 && < 0.4+ ,HUnit - Other-Modules: - AddCommand- BalanceCommand- ConvertCommand- HistogramCommand- Options- PrintCommand- RegisterCommand- Setup- Tests- Utils- Version+executable hledger+ main-is: hledger.hs+ other-modules:+ Commands.Add+ Commands.All+ Commands.Balance+ Commands.Convert+ Commands.Histogram+ Commands.Print+ Commands.Register+ Commands.Stats Ledger Ledger.Account Ledger.AccountName@@ -83,21 +93,54 @@ Ledger.Transaction Ledger.Types Ledger.Utils+ Options+ Tests+ Utils+ Version+ build-depends:+ base >= 3 && < 5+ ,bytestring+ ,containers+ ,csv+ ,directory+ ,filepath+ ,haskell98+ ,mtl+ ,parsec+ ,process+ ,regexpr >= 0.5.1+ ,split+ ,testpack+ ,time+ ,utf8-string >= 0.3 && < 0.4+ ,HUnit - -- need to set patchlevel here (darcs changes --from-tag=. --count)- cpp-options: -DPATCHES=0+ -- should set patchlevel here as in Makefile+ cpp-options: -DPATCHLEVEL=0 if flag(vty) cpp-options: -DVTY- Build-Depends:vty >= 3.1.8.2 && < 3.2- Other-Modules:UICommand+ other-modules:Commands.UI+ build-depends:+ vty >= 3.1.8.2 && < 3.2 if flag(happs) cpp-options: -DHAPPS- 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- ,utf8-string >= 0.3 && < 0.4- Other-Modules:WebCommand+ 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+ ,xhtml >= 3000.2 && < 3000.3+ ,HTTP >= 4000.0 && < 4000.1 +-- source-repository head+-- type: darcs+-- location: http://joyful.com/repos/hledger+-- disabled for now due to:+-- The 'source-repository' section is new in Cabal-1.6. Unfortunately it messes+-- up the parser in earlier Cabal versions so you need to specify 'cabal-version:+-- >= 1.6'.++-- cf http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html
hledger.hs view
@@ -1,4 +1,4 @@--- sp doesn't like.. #!/usr/bin/env runhaskell+-- #!/usr/bin/env runhaskell <- sp doesn't like {-# OPTIONS_GHC -cpp #-} {-| hledger - a ledger-compatible text-based accounting tool.@@ -35,49 +35,16 @@ See "Ledger.Ledger" for more examples. -} -module Main (- -- for easy ghci access- module Main,- module Utils,- module Options,- module BalanceCommand,- module ConvertCommand,- module PrintCommand,- module RegisterCommand,- module HistogramCommand,- module AddCommand,-#ifdef VTY- module UICommand,-#endif-#ifdef HAPPS- module WebCommand,-#endif-)-where-import Prelude hiding (putStr)-import Control.Monad.Error-import qualified Data.Map as Map (lookup)+module Main where+import Prelude hiding (putStr, putStrLn) import System.IO.UTF8-import System.IO (stderr) -import Version (versionmsg)+import Commands.All import Ledger-import Utils (withLedgerDo) import Options import Tests-import BalanceCommand-import ConvertCommand-import PrintCommand-import RegisterCommand-import HistogramCommand-import AddCommand-#ifdef VTY-import UICommand-#endif-#ifdef HAPPS-import WebCommand-#endif-+import Utils (withLedgerDo)+import Version (versionmsg, binaryfilename) main :: IO () main = do@@ -86,13 +53,15 @@ where run cmd opts args | Help `elem` opts = putStr $ usage- | Version `elem` opts = putStr versionmsg+ | Version `elem` opts = putStrLn versionmsg+ | BinaryFilename `elem` opts = putStrLn binaryfilename | cmd `isPrefixOf` "balance" = withLedgerDo opts args cmd balance | cmd `isPrefixOf` "convert" = withLedgerDo opts args cmd convert | cmd `isPrefixOf` "print" = withLedgerDo opts args cmd print' | cmd `isPrefixOf` "register" = withLedgerDo opts args cmd register | cmd `isPrefixOf` "histogram" = withLedgerDo opts args cmd histogram | cmd `isPrefixOf` "add" = withLedgerDo opts args cmd add+ | cmd `isPrefixOf` "stats" = withLedgerDo opts args cmd stats #ifdef VTY | cmd `isPrefixOf` "ui" = withLedgerDo opts args cmd ui #endif@@ -101,4 +70,3 @@ #endif | cmd `isPrefixOf` "test" = runtests opts args >> return () | otherwise = putStr $ usage-
+ sample.timelog view
@@ -0,0 +1,6 @@+i 2009/03/27 09:00:00 projects:a+o 2009/03/27 17:00:34+i 2009/03/31 22:21:45 personal:reading:online+o 2009/04/01 02:00:34+i 2009/04/02 09:00:00 projects:b+o 2009/04/02 17:00:34