diff --git a/CONTRIBUTORS.rst b/CONTRIBUTORS.rst
new file mode 100644
--- /dev/null
+++ b/CONTRIBUTORS.rst
@@ -0,0 +1,71 @@
+---
+title: hledger Contributor List and Agreement
+---
+hledger Contributor List and Agreement
+======================================
+
+hledger Contributors
+--------------------
+hledger is brought to you by:
+
+- Simon Michael - lead developer, project manager, general dogsbody
+- Sergey Astanin - utf8 support
+- Nick Ingolia - parser improvements
+- Roman Cheplyaka - "chart" command, "add" command improvements
+
+Developers who have not yet signed the contributor agreement:
+
+- Tim Docker - parser improvements
+- Marko Kocić - hlint cleanup
+- Oliver Braun - GHC 6.12 compatibility
+- Gwern Branwen - cleanups
+
+Also:
+
+- John Wiegley - created the original ledger program
+
+.. raw:: html
+
+
+
+----
+
+.. raw:: html
+
+
+
+hledger Contributor Agreement
+-----------------------------
+This is the official contributor agreement (v1) and contributor list
+for the hledger project. If you have contributed non-trivial code
+changes to hledger, please sign this, to help ensure:
+
+1. that there is a clear legal status and audit trail for the project
+
+2. that you get proper credit for your work
+
+3. that we are able to remain license-compatible with related software
+ by updating to newer versions of our license when appropriate
+ (eg GPLv2 -> GPLv3)
+
+To "sign", read the conditions below and then send a darcs patch to
+`this file`_ adding your name to the Contributor List above. By so
+doing you promise that all of your commits to hledger:
+
+- are free of patent violations or copyright violations, to the best of
+ your knowledge
+
+- are released under the hledger project's license_; or are released
+ under another compatible license (in which case this must be clearly
+ noted); or are public domain
+
+- may be relicensed under official future versions of their license
+ at the discretion of the project leader
+
+We don't currently gather paper signatures, but this is a good start.
+Feel free to update your entry as your contributions grow!
+
+
+.. _license: http://joyful.com/repos/hledger/LICENSE
+.. _this file: http://joyful.com//darcsweb/darcsweb.cgi?r=hledger;a=filehistory;f=/CONTRIBUTORS
+
diff --git a/Commands/Add.hs b/Commands/Add.hs
deleted file mode 100644
--- a/Commands/Add.hs
+++ /dev/null
@@ -1,202 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-|
-
-A history-aware add command to help with data entry.
-
--}
-
-module Commands.Add
-where
-import Ledger
-import Options
-import Commands.Register (showRegisterReport)
-#if __GLASGOW_HASKELL__ <= 610
-import Prelude hiding (putStr, putStrLn, getLine, appendFile)
-import System.IO.UTF8
-import System.IO ( stderr, hFlush )
-#else
-import System.IO ( stderr, hFlush, hPutStrLn, hPutStr )
-#endif
-import System.IO.Error
-import Text.ParserCombinators.Parsec
-import Utils (ledgerFromStringWithOpts)
-import qualified Data.Foldable as Foldable (find)
-
--- | 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 (journal 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, press control-c."
- today <- getCurrentDay
- getAndAddTransactions l opts args today `catch` (\e -> unless (isEOFError e) $ ioError e)
-
--- | Read a number of ledger transactions from the command line,
--- prompting, validating, displaying and appending them to the ledger
--- file, until end of input (then raise an EOF exception). Any
--- command-line arguments are used as the first transaction's description.
-getAndAddTransactions :: Ledger -> [Opt] -> [String] -> Day -> IO ()
-getAndAddTransactions l opts args defaultDate = do
- (ledgerTransaction,date) <- getTransaction l opts args defaultDate
- l <- ledgerAddTransaction l ledgerTransaction
- getAndAddTransactions l opts args date
-
--- | Read a transaction from the command line, with history-aware prompting.
-getTransaction :: Ledger -> [Opt] -> [String] -> Day -> IO (Transaction,Day)
-getTransaction l opts args defaultDate = do
- today <- getCurrentDay
- datestr <- askFor "date"
- (Just $ showDate defaultDate)
- (Just $ \s -> null s ||
- isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
- description <- askFor "description" Nothing (Just $ not . null)
- let historymatches = transactionsSimilarTo l args description
- bestmatch | null historymatches = Nothing
- | otherwise = Just $ snd $ head historymatches
- bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch
- date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr
- accept x = x == "." || (not . null) x &&
- if NoNewAccts `elem` opts
- then isJust $ Foldable.find (== x) ant
- else True
- where (ant,_,_,_) = groupPostings . journalPostings . journal $ l
- getpostingsandvalidate = do
- ps <- getPostings accept bestmatchpostings []
- let t = nulltransaction{tdate=date
- ,tstatus=False
- ,tdescription=description
- ,tpostings=ps
- }
- retry msg = do
- hPutStrLn stderr $ "\n" ++ msg ++ "please re-enter."
- getpostingsandvalidate
- either retry (return . flip (,) date) $ balanceTransaction t
- unless (null historymatches)
- (do
- hPutStrLn stderr "Similar transactions found, using the first for defaults:\n"
- hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches)
- getpostingsandvalidate
-
--- | Read postings from the command line until . is entered, using the
--- provided historical postings, if any, to guess defaults.
-getPostings :: (AccountName -> Bool) -> Maybe [Posting] -> [Posting] -> IO [Posting]
-getPostings accept historicalps enteredps = do
- account <- askFor (printf "account %d" n) defaultaccount (Just accept)
- 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 = nullposting{paccount=stripbrackets account,
- pamount=amount,
- ptype=postingtype account}
- getPostings accept 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 $ sumMixedAmountsPreservingHighestPrecision $ 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.
-ledgerAddTransaction :: Ledger -> Transaction -> IO Ledger
-ledgerAddTransaction l t = do
- appendToLedgerFile l $ showTransaction t
- putStrLn $ printf "\nAdded transaction to %s:" (filepath $ journal l)
- putStrLn =<< registerFromString (show t)
- return l{journal=rl{jtxns=ts}}
- where rl = journal l
- ts = jtxns 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 $ journal l
- -- XXX we are looking at the original raw text from when the ledger
- -- was first read, but that's good enough for now
- t = jtext $ journal 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 [] s
- return $ showRegisterReport opts (optsToFilterSpec opts [] now) l
- where opts = [Empty]
-
--- | 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 :: [Char] -> [Char] -> Double
-compareLedgerDescriptions s t = compareStrings s' t'
- where s' = simplify s
- t' = simplify t
- simplify = filter (not . (`elem` "0123456789"))
-
-transactionsSimilarTo :: Ledger -> [String] -> String -> [(Double,Transaction)]
-transactionsSimilarTo l apats s =
- sortBy compareRelevanceAndRecency
- $ filter ((> threshold).fst)
- [(compareLedgerDescriptions s $ tdescription t, t) | t <- ts]
- where
- compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1)
- ts = jtxns $ filterJournalTransactionsByAccount apats $ journal l
- threshold = 0
-
diff --git a/Commands/All.hs b/Commands/All.hs
deleted file mode 100644
--- a/Commands/All.hs
+++ /dev/null
@@ -1,67 +0,0 @@
-{-# LANGUAGE 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
-#if defined(WEB) || defined(WEBHAPPSTACK)
- module Commands.Web,
-#endif
-#ifdef CHART
- module Commands.Chart,
-#endif
- tests_Commands
- )
-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
-#if defined(WEB) || defined(WEBHAPPSTACK)
-import Commands.Web
-#endif
-#ifdef CHART
-import Commands.Chart
-#endif
-import Test.HUnit (Test(TestList))
-
-
-tests_Commands = TestList
- [
--- Commands.Add.tests_Add
--- ,Commands.Balance.tests_Balance
- Commands.Convert.tests_Convert
--- ,Commands.Histogram.tests_Histogram
--- ,Commands.Print.tests_Print
- ,Commands.Register.tests_Register
--- ,Commands.Stats.tests_Stats
- ]
--- #ifdef VTY
--- ,Commands.UI.tests_UI
--- #endif
--- #if defined(WEB) || defined(WEBHAPPSTACK)
--- ,Commands.Web.tests_Web
--- #endif
--- #ifdef CHART
--- ,Commands.Chart.tests_Chart
--- #endif
diff --git a/Commands/Balance.hs b/Commands/Balance.hs
deleted file mode 100644
--- a/Commands/Balance.hs
+++ /dev/null
@@ -1,165 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-|
-
-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 Ledger.Utils
-import Ledger.Types
-import Ledger.Amount
-import Ledger.AccountName
-import Ledger.Posting
-import Ledger.Ledger
-import Options
-#if __GLASGOW_HASKELL__ <= 610
-import Prelude hiding ( putStr )
-import System.IO.UTF8
-#endif
-
-
--- | Print a balance report.
-balance :: [Opt] -> [String] -> Ledger -> IO ()
-balance opts args l = do
- t <- getCurrentLocalTime
- putStr $ showBalanceReport opts (optsToFilterSpec opts args t) l
-
--- | Generate a balance report with the specified options for this ledger.
-showBalanceReport :: [Opt] -> FilterSpec -> Ledger -> String
-showBalanceReport opts filterspec l = acctsstr ++ totalstr
- where
- l' = cacheLedger'' filterspec l
- 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 (fromMaybe 99999 $ depthFromOpts opts) l'
- totalstr | NoTotal `elem` opts = ""
- | notElem Empty opts && isZeroMixedAmount total = ""
- | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmountWithoutPrice 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 $ showMixedAmountWithoutPrice $ abalance $ ledgerAccount l a
- parents = parentAccountNames a
- interestingparents = filter (`elem` interestingaccts) parents
- depthspacer = replicate (indentperlevel * length interestingparents) ' '
- indentperlevel = 2
- -- the partial name is the account's leaf name, prefixed by the
- -- names of any boring parents immediately above
- partialname = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]
- 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 = isJust d && Just (accountNameLevel a) == d where d = depthFromOpts opts
- emptyflag = Empty `elem` opts
- acct = ledgerAccount l a
- notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct
- notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct
- numinterestingsubs = length $ filter isInterestingTree subtrees
- where
- isInterestingTree = treeany (isInteresting opts l . aname)
- subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a
-
diff --git a/Commands/Chart.hs b/Commands/Chart.hs
deleted file mode 100644
--- a/Commands/Chart.hs
+++ /dev/null
@@ -1,108 +0,0 @@
-{-|
-
-Generate balances pie chart
-
--}
-
-module Commands.Chart
-where
-import Ledger.Utils
-import Ledger.Types
-import Ledger.Amount
-import Ledger.Ledger
-import Ledger.Commodity
-import Options
-
-import Control.Monad (liftM3)
-import Graphics.Rendering.Chart
-import Data.Colour
-import Data.Colour.Names
-import Data.Colour.RGBSpace
-import Data.Colour.RGBSpace.HSL (hsl)
-import Data.Colour.SRGB.Linear (rgb)
-import Data.List
-import Safe (readDef)
-
--- | Generate an image with the pie chart and write it to a file
-chart :: [Opt] -> [String] -> Ledger -> IO ()
-chart opts args l = do
- t <- getCurrentLocalTime
- let chart = genPie opts (optsToFilterSpec opts args t) l
- renderableToPNGFile (toRenderable chart) w h filename
- where
- filename = getOption opts ChartOutput chartoutput
- (w,h) = parseSize $ getOption opts ChartSize chartsize
-
--- | Extract string option value from a list of options or use the default
-getOption :: [Opt] -> (String->Opt) -> String -> String
-getOption opts opt def =
- case reverse $ optValuesForConstructor opt opts of
- [] -> def
- x:_ -> x
-
--- | Parse image size from a command-line option
-parseSize :: String -> (Int,Int)
-parseSize str = (read w, read h)
- where
- x = fromMaybe (error "Size should be in WIDTHxHEIGHT format") $ findIndex (=='x') str
- (w,_:h) = splitAt x str
-
--- | Generate pie chart
-genPie :: [Opt] -> FilterSpec -> Ledger -> PieLayout
-genPie opts filterspec l = defaultPieLayout { pie_background_ = solidFillStyle $ opaque $ white
- , pie_plot_ = pie_chart }
- where
- pie_chart = defaultPieChart { pie_data_ = map (uncurry accountPieItem) chartitems'
- , pie_start_angle_ = (-90)
- , pie_colors_ = mkColours hue
- , pie_label_style_ = defaultFontStyle{font_size_=12}
- }
- chartitems' = debug "chart" $ top num samesignitems
- (samesignitems, sign) = sameSignNonZero rawitems
- rawitems = debug "raw" $ flatten $ balances $
- ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) $ cacheLedger'' filterspec l
- top n t = topn ++ [other]
- where
- (topn,rest) = splitAt n $ reverse $ sortBy (comparing snd) t
- other = ("other", sum $ map snd rest)
- num = readDef (fromIntegral chartitems) (getOption opts ChartItems (show chartitems))
- hue = if sign > 0 then red else green where (red, green) = (0, 110)
- debug s = if Debug `elem` opts then ltrace s else id
-
--- | Select the nonzero items with same sign as the first, and make
--- them positive. Also return a 1 or -1 corresponding to the original sign.
-sameSignNonZero :: [(AccountName, Double)] -> ([(AccountName, Double)], Int)
-sameSignNonZero is | null nzs = ([], 1)
- | otherwise = (map pos $ filter (test.snd) nzs, sign)
- where
- nzs = filter ((/=0).snd) is
- pos (a,b) = (a, abs b)
- sign = if snd (head nzs) >= 0 then 1 else (-1)
- test = if sign > 0 then (>0) else (<0)
-
--- | Convert all quantities of MixedAccount to a single commodity
-amountValue :: MixedAmount -> Double
-amountValue = quantity . convertMixedAmountTo unknown
-
--- | Generate a tree of account names together with their balances.
--- The balance of account is decremented by the balance of its subaccounts
--- which are drawn on the chart.
-balances :: Tree Account -> Tree (AccountName, Double)
-balances (Node rootAcc subAccs) = Node newroot newsubs
- where
- newroot = (aname rootAcc,
- amountValue $
- abalance rootAcc - (sum . map (abalance . root)) subAccs)
- newsubs = map balances subAccs
-
--- | Build a single pie chart item
-accountPieItem :: AccountName -> Double -> PieItem
-accountPieItem accname balance = PieItem accname offset balance where offset = 0
-
--- | Generate an infinite color list suitable for charts.
-mkColours :: Double -> [AlphaColour Double]
-mkColours hue = cycle $ [opaque $ rgbToColour $ hsl h s l | (h,s,l) <- liftM3 (,,)
- [hue] [0.7] [0.1,0.2..0.7] ]
-
-rgbToColour :: (Fractional a) => RGB a -> Colour a
-rgbToColour (RGB r g b) = rgb r g b
diff --git a/Commands/Convert.hs b/Commands/Convert.hs
deleted file mode 100644
--- a/Commands/Convert.hs
+++ /dev/null
@@ -1,386 +0,0 @@
-{-|
-Convert account data in CSV format (eg downloaded from a bank) to ledger
-format, and print it on stdout. See the manual for more details.
--}
-
-module Commands.Convert where
-import Options (Opt(Debug))
-import Version (versionstr)
-import Ledger.Types (Ledger,AccountName,Transaction(..),Posting(..),PostingType(..))
-import Ledger.Utils (strip, spacenonewline, restofline, parseWithCtx, assertParse, assertParseEqual)
-import Ledger.Parse (someamount, emptyCtx, ledgeraccountname)
-import Ledger.Amount (nullmixedamt)
-import Safe (atDef, maximumDef)
-import System.IO (stderr)
-import Text.CSV (parseCSVFromFile, printCSV)
-import Text.Printf (hPrintf)
-import Text.RegexPR (matchRegexPR, gsubRegexPR)
-import Data.Maybe
-import Ledger.Dates (firstJust, showDate, parsedate)
-import System.Locale (defaultTimeLocale)
-import Data.Time.Format (parseTime)
-import Control.Monad (when, guard, liftM)
-import Safe (readDef, readMay)
-import System.Directory (doesFileExist)
-import System.Exit (exitFailure)
-import System.FilePath.Posix (takeBaseName, replaceExtension)
-import Text.ParserCombinators.Parsec
-import Test.HUnit
-
-
-{- |
-A set of data definitions and account-matching patterns sufficient to
-convert a particular CSV data file into meaningful ledger transactions. See above.
--}
-data CsvRules = CsvRules {
- dateField :: Maybe FieldPosition,
- statusField :: Maybe FieldPosition,
- codeField :: Maybe FieldPosition,
- descriptionField :: Maybe FieldPosition,
- amountField :: Maybe FieldPosition,
- currencyField :: Maybe FieldPosition,
- baseCurrency :: Maybe String,
- baseAccount :: AccountName,
- accountRules :: [AccountRule]
-} deriving (Show, Eq)
-
-nullrules = CsvRules {
- dateField=Nothing,
- statusField=Nothing,
- codeField=Nothing,
- descriptionField=Nothing,
- amountField=Nothing,
- currencyField=Nothing,
- baseCurrency=Nothing,
- baseAccount="unknown",
- accountRules=[]
-}
-
-type FieldPosition = Int
-
-type AccountRule = (
- [(String, Maybe String)] -- list of regex match patterns with optional replacements
- ,AccountName -- account name to use for a transaction matching this rule
- )
-
-type CsvRecord = [String]
-
-
--- | Read the CSV file named as an argument and print equivalent ledger transactions,
--- using/creating a .rules file.
-convert :: [Opt] -> [String] -> Ledger -> IO ()
-convert opts args _ = do
- when (null args) $ error "please specify a csv data file."
- let csvfile = head args
- csvparse <- parseCSVFromFile csvfile
- let records = case csvparse of
- Left e -> error $ show e
- Right rs -> reverse $ filter (/= [""]) rs
- let debug = Debug `elem` opts
- rulesfile = rulesFileFor csvfile
- exists <- doesFileExist rulesfile
- if (not exists) then do
- hPrintf stderr "creating conversion rules file %s, edit this file for better results\n" rulesfile
- writeFile rulesfile initialRulesFileContent
- else
- hPrintf stderr "using conversion rules file %s\n" rulesfile
- rules <- liftM (either (error.show) id) $ parseCsvRulesFile rulesfile
- when debug $ hPrintf stderr "rules: %s\n" (show rules)
- let requiredfields = max 2 (maxFieldIndex rules + 1)
- badrecords = take 1 $ filter ((< requiredfields).length) records
- if null badrecords
- then mapM_ (printTxn debug rules) records
- else do
- hPrintf stderr (unlines [
- "Warning, at least one CSV record does not contain a field referenced by the"
- ,"conversion rules file, or has less than two fields. Are you converting a"
- ,"valid CSV file ? First bad record:\n%s"
- ]) (show $ head badrecords)
- exitFailure
-
--- | The highest (0-based) field index referenced in the field
--- definitions, or -1 if no fields are defined.
-maxFieldIndex :: CsvRules -> Int
-maxFieldIndex r = maximumDef (-1) $ catMaybes [
- dateField r
- ,statusField r
- ,codeField r
- ,descriptionField r
- ,amountField r
- ,currencyField r
- ]
-
-rulesFileFor :: FilePath -> FilePath
-rulesFileFor csvfile = replaceExtension csvfile ".rules"
-
-initialRulesFileContent :: String
-initialRulesFileContent =
- "# csv conversion rules file generated by hledger "++versionstr++"\n" ++
- "# Add rules to this file for more accurate conversion, see\n"++
- "# http://hledger.org/MANUAL.html#convert\n" ++
- "\n" ++
- "base-account assets:bank:checking\n" ++
- "date-field 0\n" ++
- "description-field 4\n" ++
- "amount-field 1\n" ++
- "currency $\n" ++
- "\n" ++
- "# account-assigning rules\n" ++
- "\n" ++
- "SPECTRUM\n" ++
- "expenses:health:gym\n" ++
- "\n" ++
- "ITUNES\n" ++
- "BLKBSTR=BLOCKBUSTER\n" ++
- "expenses:entertainment\n" ++
- "\n" ++
- "(TO|FROM) SAVINGS\n" ++
- "assets:bank:savings\n"
-
--- rules file parser
-
-parseCsvRulesFile :: FilePath -> IO (Either ParseError CsvRules)
-parseCsvRulesFile f = do
- s <- readFile f
- return $ parseCsvRules f s
-
-parseCsvRules :: FilePath -> String -> Either ParseError CsvRules
-parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
-
-csvrulesfile :: GenParser Char CsvRules CsvRules
-csvrulesfile = do
- many blankorcommentline
- many definitions
- r <- getState
- ars <- many accountrule
- many blankorcommentline
- eof
- return r{accountRules=ars}
-
--- | Real independent parser choice, even when alternative matches share a prefix.
-choice' parsers = choice $ map try (init parsers) ++ [last parsers]
-
-definitions :: GenParser Char CsvRules ()
-definitions = do
- choice' [
- datefield
- ,statusfield
- ,codefield
- ,descriptionfield
- ,amountfield
- ,currencyfield
- ,basecurrency
- ,baseaccount
- ,commentline
- ] "definition"
- return ()
-
-datefield = do
- string "date-field"
- many1 spacenonewline
- v <- restofline
- r <- getState
- setState r{dateField=readMay v}
-
-codefield = do
- string "code-field"
- many1 spacenonewline
- v <- restofline
- r <- getState
- setState r{codeField=readMay v}
-
-statusfield = do
- string "status-field"
- many1 spacenonewline
- v <- restofline
- r <- getState
- setState r{statusField=readMay v}
-
-descriptionfield = do
- string "description-field"
- many1 spacenonewline
- v <- restofline
- r <- getState
- setState r{descriptionField=readMay v}
-
-amountfield = do
- string "amount-field"
- many1 spacenonewline
- v <- restofline
- r <- getState
- setState r{amountField=readMay v}
-
-currencyfield = do
- string "currency-field"
- many1 spacenonewline
- v <- restofline
- r <- getState
- setState r{currencyField=readMay v}
-
-basecurrency = do
- string "currency"
- many1 spacenonewline
- v <- restofline
- r <- getState
- setState r{baseCurrency=Just v}
-
-baseaccount = do
- string "base-account"
- many1 spacenonewline
- v <- ledgeraccountname
- optional newline
- r <- getState
- setState r{baseAccount=v}
-
-accountrule :: GenParser Char CsvRules AccountRule
-accountrule = do
- many blankorcommentline
- pats <- many1 matchreplacepattern
- guard $ length pats >= 2
- let pats' = init pats
- acct = either (fail.show) id $ runParser ledgeraccountname () "" $ fst $ last pats
- many blankorcommentline
- return (pats',acct)
- "account rule"
-
-blanklines = many1 blankline >> return ()
-
-blankline = many spacenonewline >> newline >> return () "blank line"
-
-commentchar = oneOf ";#"
-
-commentline = many spacenonewline >> commentchar >> restofline >> return () "comment line"
-
-blankorcommentline = choice' [blankline, commentline]
-
-matchreplacepattern = do
- notFollowedBy commentchar
- matchpat <- many1 (noneOf "=\n")
- replpat <- optionMaybe $ do {char '='; many $ noneOf "\n"}
- newline
- return (matchpat,replpat)
-
-printTxn :: Bool -> CsvRules -> CsvRecord -> IO ()
-printTxn debug rules rec = do
- when debug $ hPrintf stderr "record: %s" (printCSV [rec])
- putStr $ show $ transactionFromCsvRecord rules rec
-
--- csv record conversion
-
-transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction
-transactionFromCsvRecord rules fields =
- let
- date = parsedate $ normaliseDate $ maybe "1900/1/1" (atDef "" fields) (dateField rules)
- status = maybe False (null . strip . (atDef "" fields)) (statusField rules)
- code = maybe "" (atDef "" fields) (codeField rules)
- desc = maybe "" (atDef "" fields) (descriptionField rules)
- comment = ""
- precomment = ""
- amountstr = maybe "" (atDef "" fields) (amountField rules)
- amountstr' = strnegate amountstr where strnegate ('-':s) = s
- strnegate s = '-':s
- currency = maybe (fromMaybe "" $ baseCurrency rules) (atDef "" fields) (currencyField rules)
- amountstr'' = currency ++ amountstr'
- amountparse = runParser someamount emptyCtx "" amountstr''
- amount = either (const nullmixedamt) id amountparse
- unknownacct | (readDef 0 amountstr' :: Double) < 0 = "income:unknown"
- | otherwise = "expenses:unknown"
- (acct,newdesc) = identify (accountRules rules) unknownacct desc
- t = Transaction {
- tdate=date,
- teffectivedate=Nothing,
- tstatus=status,
- tcode=code,
- tdescription=newdesc,
- tcomment=comment,
- tpreceding_comment_lines=precomment,
- tpostings=[
- Posting {
- pstatus=False,
- paccount=acct,
- pamount=amount,
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Just t
- },
- Posting {
- pstatus=False,
- paccount=baseAccount rules,
- pamount=(-amount),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Just t
- }
- ]
- }
- in t
-
--- | Convert some date string with unknown format to YYYY/MM/DD.
-normaliseDate :: String -> String
-normaliseDate s = maybe "0000/00/00" showDate $
- firstJust
- [parseTime defaultTimeLocale "%Y/%m/%e" s
- -- can't parse a month without leading 0, try adding one
- ,parseTime defaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s)
- ,parseTime defaultTimeLocale "%Y-%m-%e" s
- ,parseTime defaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s)
- ,parseTime defaultTimeLocale "%m/%e/%Y" s
- ,parseTime defaultTimeLocale "%m/%e/%Y" ('0':s)
- ,parseTime defaultTimeLocale "%m-%e-%Y" s
- ,parseTime defaultTimeLocale "%m-%e-%Y" ('0':s)
- ]
-
--- | Apply account matching rules to a transaction description to obtain
--- the most appropriate account and a new description.
-identify :: [AccountRule] -> String -> String -> (String,String)
-identify rules defacct desc | null matchingrules = (defacct,desc)
- | otherwise = (acct,newdesc)
- where
- matchingrules = filter ismatch rules :: [AccountRule]
- where ismatch = any (isJust . flip matchRegexPR (caseinsensitive desc) . fst) . fst
- (prs,acct) = head matchingrules
- p_ms_r = filter (\(_,m,_) -> isJust m) $ map (\(p,r) -> (p, matchRegexPR (caseinsensitive p) desc, r)) prs
- (p,_,r) = head p_ms_r
- newdesc = case r of Just rpat -> gsubRegexPR (caseinsensitive p) rpat desc
- Nothing -> desc
-
-caseinsensitive = ("(?i)"++)
-
-tests_Convert = TestList [
-
- "convert rules parsing: empty file" ~: do
- -- let assertMixedAmountParse parseresult mixedamount =
- -- (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)
- assertParseEqual (parseCsvRules "unknown" "") nullrules
-
- ,"convert rules parsing: accountrule" ~: do
- assertParseEqual (parseWithCtx nullrules accountrule "A\na\n") -- leading blank line required
- ([("A",Nothing)], "a")
-
- ,"convert rules parsing: trailing comments" ~: do
- assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#\n")
-
- ,"convert rules parsing: trailing blank lines" ~: do
- assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n \n")
-
- -- not supported
- -- ,"convert rules parsing: no final newline" ~: do
- -- assertParse (parseWithCtx nullrules csvrulesfile "A\na")
- -- assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#")
- -- assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n ")
-
- -- (nullrules{
- -- -- dateField=Maybe FieldPosition,
- -- -- statusField=Maybe FieldPosition,
- -- -- codeField=Maybe FieldPosition,
- -- -- descriptionField=Maybe FieldPosition,
- -- -- amountField=Maybe FieldPosition,
- -- -- currencyField=Maybe FieldPosition,
- -- -- baseCurrency=Maybe String,
- -- -- baseAccount=AccountName,
- -- accountRules=[
- -- ([("A",Nothing)], "a")
- -- ]
- -- })
-
- ]
diff --git a/Commands/Histogram.hs b/Commands/Histogram.hs
deleted file mode 100644
--- a/Commands/Histogram.hs
+++ /dev/null
@@ -1,50 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-|
-
-Print a histogram report.
-
--}
-
-module Commands.Histogram
-where
-import Ledger
-import Options
-#if __GLASGOW_HASKELL__ <= 610
-import Prelude hiding ( putStr )
-import System.IO.UTF8
-#endif
-
-
-barchar = '*'
-
--- | Print a histogram of some statistic per reporting interval, such as
--- number of postings per day.
-histogram :: [Opt] -> [String] -> Ledger -> IO ()
-histogram opts args l = do
- t <- getCurrentLocalTime
- putStr $ showHistogram opts (optsToFilterSpec opts args t) l
-
-showHistogram :: [Opt] -> FilterSpec -> Ledger -> String
-showHistogram opts filterspec l = concatMap (printDayWith countBar) dayps
- where
- i = intervalFromOpts opts
- interval | i == NoInterval = Daily
- | otherwise = i
- fullspan = journalDateSpan $ journal l
- days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan
- dayps = [(s, filter (isPostingInDateSpan s) ps) | s <- days]
- -- same as Register
- -- should count transactions, not postings ?
- ps = sortBy (comparing postingDate) $ filterempties $ filter matchapats $ filterdepth $ ledgerPostings l
- filterempties
- | Empty `elem` opts = id
- | otherwise = filter (not . isZeroMixedAmount . pamount)
- matchapats = matchpats apats . paccount
- apats = acctpats filterspec
- filterdepth | interval == NoInterval = filter (\p -> accountNameLevel (paccount p) <= depth)
- | otherwise = id
- depth = fromMaybe 99999 $ depthFromOpts opts
-
-printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts)
-
-countBar ps = replicate (length ps) barchar
diff --git a/Commands/Print.hs b/Commands/Print.hs
deleted file mode 100644
--- a/Commands/Print.hs
+++ /dev/null
@@ -1,29 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-|
-
-A ledger-compatible @print@ command.
-
--}
-
-module Commands.Print
-where
-import Ledger
-import Options
-#if __GLASGOW_HASKELL__ <= 610
-import Prelude hiding ( putStr )
-import System.IO.UTF8
-#endif
-
-
--- | Print ledger transactions in standard format.
-print' :: [Opt] -> [String] -> Ledger -> IO ()
-print' opts args l = do
- t <- getCurrentLocalTime
- putStr $ showTransactions (optsToFilterSpec opts args t) l
-
-showTransactions :: FilterSpec -> Ledger -> String
-showTransactions filterspec l =
- concatMap (showTransactionForPrint effective) $ sortBy (comparing tdate) txns
- where
- effective = EffectiveDate == whichdate filterspec
- txns = jtxns $ filterJournalTransactions filterspec $ journal l
diff --git a/Commands/Register.hs b/Commands/Register.hs
deleted file mode 100644
--- a/Commands/Register.hs
+++ /dev/null
@@ -1,150 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-|
-
-A ledger-compatible @register@ command.
-
--}
-
-module Commands.Register (
- register
- ,showRegisterReport
- ,showPostingWithBalance
- ,tests_Register
-) where
-
-import Safe (headMay, lastMay)
-import Ledger
-import Options
-#if __GLASGOW_HASKELL__ <= 610
-import Prelude hiding ( putStr )
-import System.IO.UTF8
-#endif
-
-
--- | Print a register report.
-register :: [Opt] -> [String] -> Ledger -> IO ()
-register opts args l = do
- t <- getCurrentLocalTime
- putStr $ showRegisterReport opts (optsToFilterSpec opts args t) l
-
--- | Generate the register report, which is a list of postings with transaction
--- info and a running balance.
-showRegisterReport :: [Opt] -> FilterSpec -> Ledger -> String
-showRegisterReport opts filterspec l = showPostingsWithBalance ps nullposting startbal
- where
- ps | interval == NoInterval = displayableps
- | otherwise = summarisePostings interval depth empty filterspan displayableps
- startbal = sumPostings precedingps
- (precedingps,displayableps,_) =
- postingsMatchingDisplayExpr (displayExprFromOpts opts) $ journalPostings $ filterJournalPostings filterspec $ journal l
- (interval, depth, empty) = (intervalFromOpts opts, depthFromOpts opts, Empty `elem` opts)
- filterspan = datespan filterspec
-
--- | Convert a list of postings into summary postings, one per interval.
-summarisePostings :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting]
-summarisePostings interval depth empty filterspan ps = concatMap summarisespan $ splitSpan interval reportspan
- where
- summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)
- postingsinspan s = filter (isPostingInDateSpan s) ps
- dataspan = postingsDateSpan ps
- reportspan | empty = filterspan `orDatesFrom` dataspan
- | otherwise = dataspan
-
--- | Combine two datespans, filling any unspecified dates in the first
--- with dates from the second.
-orDatesFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b
- where a = if isJust a1 then a1 else a2
- b = if isJust b1 then b1 else b2
-
--- | Date-sort and split a list of postings into three spans - postings matched
--- by the given display expression, and the preceding and following postings.
-postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting])
-postingsMatchingDisplayExpr d ps = (before, matched, after)
- where
- sorted = sortBy (comparing postingDate) ps
- (before, rest) = break (displayExprMatches d) sorted
- (matched, after) = span (displayExprMatches d) rest
-
--- | Does this display expression allow this posting to be displayed ?
--- Raises an error if the display expression can't be parsed.
-displayExprMatches :: Maybe String -> Posting -> Bool
-displayExprMatches Nothing _ = True
-displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p
-
--- XXX confusing, refactor
--- | Given a date span (representing a reporting interval) and a list of
--- postings within it: aggregate the postings so there is only one per
--- account, and adjust their date/description so that they 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.
---
--- When a depth argument is present, postings to accounts of greater
--- depth are aggregated where possible.
---
--- The showempty flag forces the display of a zero-posting span
--- and also zero-posting accounts within the span.
-summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting]
-summarisePostingsInDateSpan (DateSpan b e) depth showempty ps
- | null ps && (isNothing b || isNothing e) = []
- | null ps && showempty = [summaryp]
- | otherwise = summaryps'
- where
- summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e'))
- b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b
- e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e
- summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}}
-
- summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps
- summaryps = [summaryp{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames]
- anames = sort $ nub $ map paccount ps
- -- aggregate balances by account, like cacheLedger, then do depth-clipping
- (_,_,exclbalof,inclbalof) = groupPostings ps
- clippedanames = nub $ map (clipAccountName d) anames
- isclipped a = accountNameLevel a >= d
- d = fromMaybe 99999 $ depth
- balancetoshowfor a =
- (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)
-
-{- |
-Show postings one per line, plus transaction info for the first posting of
-each transaction, and a running balance. Eg:
-
-@
-date (10) description (20) account (22) amount (11) balance (12)
-DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
- aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
-@
--}
-showPostingsWithBalance :: [Posting] -> Posting -> MixedAmount -> String
-showPostingsWithBalance [] _ _ = ""
-showPostingsWithBalance (p:ps) pprev bal = this ++ showPostingsWithBalance ps p bal'
- where
- this = showPostingWithBalance isfirst p bal'
- isfirst = ptransaction p /= ptransaction pprev
- bal' = bal + pamount p
-
--- | Show one posting and running balance, with or without transaction info.
-showPostingWithBalance :: Bool -> Posting -> MixedAmount -> String
-showPostingWithBalance withtxninfo p b = concatBottomPadded [txninfo ++ pstr ++ " ", bal] ++ "\n"
- where
- ledger3ishlayout = False
- datedescwidth = if ledger3ishlayout then 34 else 32
- txninfo = if withtxninfo then printf "%s %s " date desc else replicate datedescwidth ' '
- date = showDate da
- datewidth = 10
- descwidth = datedescwidth - datewidth - 2
- desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String
- pstr = showPostingForRegister p
- bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)
- (da,de) = case ptransaction p of Just (Transaction{tdate=da',tdescription=de'}) -> (da',de')
- Nothing -> (nulldate,"")
-
-tests_Register :: Test
-tests_Register = TestList [
-
- "summarisePostings" ~: do
- summarisePostings Quarterly Nothing False (DateSpan Nothing Nothing) [] ~?= []
-
- ]
diff --git a/Commands/Stats.hs b/Commands/Stats.hs
deleted file mode 100644
--- a/Commands/Stats.hs
+++ /dev/null
@@ -1,74 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-|
-
-Print some statistics for the ledger.
-
--}
-
-module Commands.Stats
-where
-import Ledger
-import Options
-#if __GLASGOW_HASKELL__ <= 610
-import Prelude hiding ( putStr )
-import System.IO.UTF8
-#endif
-
-
--- | Print various statistics for the ledger.
-stats :: [Opt] -> [String] -> Ledger -> IO ()
-stats opts args l = do
- today <- getCurrentDay
- putStr $ showStats opts args (cacheLedger' l) today
-
-showStats :: [Opt] -> [String] -> Ledger -> Day -> String
-showStats _ _ l today =
- heading ++ unlines (map (uncurry (printf fmt)) stats)
- where
- heading = underline $ printf "Ledger statistics as of %s" (show today)
- fmt = "%-" ++ show w1 ++ "s: %-" ++ show w2 ++ "s"
- w1 = maximum $ map (length . fst) stats
- w2 = maximum $ map (length . show . snd) stats
- stats = [
- ("File", filepath $ journal l)
- ,("Period", printf "%s to %s (%d days)" (start span) (end span) days)
- ,("Last transaction", maybe "none" show lastdate ++ showelapsed lastelapsed)
- ,("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)
--- ,("Payees/descriptions", show $ length $ nub $ map tdescription ts)
- ,("Accounts", show $ length $ accounts l)
- ,("Account tree depth", show $ maximum $ map (accountNameLevel.aname) $ accounts l)
- ,("Commodities", printf "%s (%s)" (show $ length $ cs) (intercalate ", " $ sort $ map symbol cs))
- -- 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 tdate) $ jtxns $ journal l
- lastdate | null ts = Nothing
- | otherwise = Just $ tdate $ last ts
- lastelapsed = maybe Nothing (Just . diffDays today) lastdate
- showelapsed Nothing = ""
- showelapsed (Just days) = printf " (%d %s)" days' direction
- where days' = abs days
- direction | days >= 0 = "days ago"
- | otherwise = "days from now"
- 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 = tdate t
- txnrate30 = fromIntegral tnum30 / 30 :: Double
- tnum7 = length $ filter withinlast7 ts
- withinlast7 t = d >= addDays (-7) today && (d<=today) where d = tdate t
- txnrate7 = fromIntegral tnum7 / 7 :: Double
- cs = commodities l
-
diff --git a/Commands/UI.hs b/Commands/UI.hs
deleted file mode 100644
--- a/Commands/UI.hs
+++ /dev/null
@@ -1,371 +0,0 @@
-{-|
-
-A simple text UI for hledger, based on the vty library.
-
--}
-
-module Commands.UI
-where
-import Safe (headDef)
-import Graphics.Vty
-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
- DisplayRegion w h <- display_bounds $ terminal v
- let opts' = SubTotal:opts
- t <- getCurrentLocalTime
- let a = enter t BalanceScreen
- AppState {
- av=v
- ,aw=fromIntegral w
- ,ah=fromIntegral 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,aopts=opts} = do
- when (notElem DebugNoUI opts) $ update av (renderScreen a)
- k <- next_event av
- t <- getCurrentLocalTime
- 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 t BalanceScreen a
- EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter t RegisterScreen a
- EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter t PrintScreen a
- EvKey KRight [] -> go $ drilldown t a
- EvKey KEnter [] -> go $ drilldown t a
- EvKey KLeft [] -> go $ backout t 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 = setPosY 0
-
-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 :: LocalTime -> Screen -> AppState -> AppState
-enter t scr@BalanceScreen a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a
-enter t scr@RegisterScreen a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a
-enter t scr@PrintScreen a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0} a
-
-resetTrailAndEnter t scr = enter t scr . clearLocs
-
--- | Regenerate the display data appropriate for the current screen.
-updateData :: LocalTime -> AppState -> AppState
-updateData t a@AppState{aopts=opts,aargs=args,aledger=l} =
- case screen a of
- BalanceScreen -> a{abuf=lines $ showBalanceReport opts (optsToFilterSpec opts args t) l, aargs=[]}
- RegisterScreen -> a{abuf=lines $ showRegisterReport opts (optsToFilterSpec opts args t) l}
- PrintScreen -> a{abuf=lines $ showTransactions (optsToFilterSpec opts args t) l}
-
-backout :: LocalTime -> AppState -> AppState
-backout t a | screen a == BalanceScreen = a
- | otherwise = updateData t $ popLoc a
-
-drilldown :: LocalTime -> AppState -> AppState
-drilldown t a =
- case screen a of
- BalanceScreen -> enter t RegisterScreen a{aargs=[currentAccountName a]}
- RegisterScreen -> scrollToTransaction e $ enter t PrintScreen a
- PrintScreen -> a
- where e = currentTransaction 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.
-scrollToTransaction :: Maybe Transaction -> AppState -> AppState
-scrollToTransaction Nothing a = a
-scrollToTransaction (Just t) a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a
- where
- entryfirstline = head $ lines $ showTransaction t
- halfph = pageHeight a `div` 2
- y = fromMaybe 0 $ findIndex (== entryfirstline) buf
- sy = max 0 $ y - halfph
- cy = y - sy
-
--- | Get the transaction containing the posting currently highlighted by
--- the cursor on the register screen (or best guess). Results undefined
--- while on other screens.
-currentTransaction :: AppState -> Maybe Transaction
-currentTransaction a@AppState{aledger=l,abuf=buf} = ptransaction p
- where
- p = headDef nullposting $ filter ismatch $ ledgerPostings l
- ismatch p = postingDate p == parsedate (take 10 datedesc)
- && take 70 (showPostingWithBalance False p nullmixedamt) == (datedesc ++ acctamt)
- datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ headDef "" rest : reverse above
- acctamt = drop 32 $ headDef "" rest
- (above,rest) = splitAt y buf
- y = posY a
-
--- renderers
-
-renderScreen :: AppState -> Picture
-renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
- Picture {pic_cursor = Cursor (fromIntegral cx) (fromIntegral cy)
- ,pic_image = mainimg
- <->
- renderStatus w msg
- ,pic_background = Background ' ' def_attr
- }
- where
- (cx, cy) = (0, cursorY a)
- sy = scrollY a
--- 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
--- trying for more speed
- mainimg = vert_cat (map (string defaultattr) above)
- <->
- string currentlineattr thisline
- <->
- vert_cat (map (string defaultattr) below)
- (thisline,below) | null rest = (blankline,[])
- | otherwise = (head rest, tail rest)
- (above,rest) = splitAt cy linestorender
- linestorender = map padclipline $ take (h-1) $ drop sy $ buf ++ replicate h blankline
- padclipline = take w . (++ blankline)
- blankline = replicate w ' '
-
-padClipString :: Int -> Int -> String -> [String]
-padClipString h w s = rows
- where
- rows = map padclipline $ take h $ lines s ++ replicate h blankline
- padclipline = take w . (++ blankline)
- blankline = replicate w ' '
-
-renderString :: Attr -> String -> Image
-renderString attr s = vert_cat $ map (string attr) 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 = string statusattr . take w . (++ repeat ' ')
-
--- the all-important theming engine!
-
-theme = Restrained
-
-data UITheme = Restrained | Colorful | Blood
-
-(defaultattr,
- currentlineattr,
- statusattr
- ) = case theme of
- Restrained -> (def_attr
- ,def_attr `with_style` bold
- ,def_attr `with_style` reverse_video
- )
- Colorful -> (def_attr `with_style` reverse_video
- ,def_attr `with_fore_color` white `with_back_color` red
- ,def_attr `with_fore_color` black `with_back_color` green
- )
- Blood -> (def_attr `with_style` reverse_video
- ,def_attr `with_fore_color` white `with_back_color` red
- ,def_attr `with_style` reverse_video
- )
-
-halfbrightattr = def_attr `with_style` dim
-reverseattr = def_attr `with_style` reverse_video
-redattr = def_attr `with_fore_color` red
-greenattr = def_attr `with_fore_color` green
-reverseredattr = def_attr `with_style` reverse_video `with_fore_color` red
-reversegreenattr= def_attr `with_style` reverse_video `with_fore_color` green
diff --git a/Commands/Web.hs b/Commands/Web.hs
deleted file mode 100644
--- a/Commands/Web.hs
+++ /dev/null
@@ -1,389 +0,0 @@
-{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
-{-# OPTIONS_GHC -F -pgmFtrhsx #-}
-{-|
-A web-based UI.
--}
-
-module Commands.Web
-where
-#if __GLASGOW_HASKELL__ <= 610
-import Codec.Binary.UTF8.String (decodeString)
-#endif
-import Control.Applicative.Error (Failing(Success,Failure))
-import Control.Concurrent
-import Control.Monad.Reader (ask)
-import Data.IORef (newIORef, atomicModifyIORef)
-import Network.HTTP (urlEncode, urlDecode)
-import System.Directory (getModificationTime)
-import System.IO.Storage (withStore, putValue, getValue)
-import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
-import Text.ParserCombinators.Parsec (parse)
-
-import Hack.Contrib.Constants (_TextHtmlUTF8)
-import Hack.Contrib.Response (set_content_type)
-import qualified Hack (Env, http)
-import qualified Hack.Contrib.Request (inputs, params, path)
-import qualified Hack.Contrib.Response (redirect)
-#ifdef WEBHAPPSTACK
-import System.Process (readProcess)
-import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))
-#else
-import Hack.Handler.SimpleServer (run)
-#endif
-
-import Network.Loli (loli, io, get, post, html, text, public)
-import Network.Loli.Type (AppUnit)
-import Network.Loli.Utils (update)
-
-import HSP hiding (Request,catch)
-import qualified HSP (Request(..))
-import HSP.HTML (renderAsHTML)
-
-import Commands.Add (ledgerAddTransaction)
-import Commands.Balance
-import Commands.Histogram
-import Commands.Print
-import Commands.Register
-import Ledger
-import Options hiding (value)
-#ifdef MAKE
-import Paths_hledger_make (getDataFileName)
-#else
-import Paths_hledger (getDataFileName)
-#endif
-import Utils (openBrowserOn)
-
--- import Debug.Trace
--- strace :: Show a => a -> a
--- strace a = trace (show a) a
-
-tcpport = 5000 :: Int
-homeurl = printf "http://localhost:%d/" tcpport
-browserdelay = 100000 -- microseconds
-
-web :: [Opt] -> [String] -> Ledger -> IO ()
-web opts args l = do
- unless (Debug `elem` opts) $ forkIO browser >> return ()
- server opts args l
-
-browser :: IO ()
-browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()
-
-server :: [Opt] -> [String] -> Ledger -> IO ()
-server opts args l =
- -- server initialisation
- withStore "hledger" $ do -- IO ()
- printf "starting web server on port %d\n" tcpport
- t <- getCurrentLocalTime
- webfiles <- getDataFileName "web"
- putValue "hledger" "ledger" l
-#ifdef WEBHAPPSTACK
- hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"
- runWithConfig (ServerConf tcpport hostname) $ -- (Env -> IO Response) -> IO ()
-#else
- run tcpport $ -- (Env -> IO Response) -> IO ()
-#endif
- \env -> do -- IO Response
- -- general request handler
- let a = intercalate "+" $ reqparam env "a"
- p = intercalate "+" $ reqparam env "p"
- opts' = opts ++ [Period p]
- args' = args ++ (map urlDecode $ words a)
- l' <- fromJust `fmap` getValue "hledger" "ledger"
- l'' <- reloadIfChanged opts' args' l'
- -- declare path-specific request handlers
- let command :: [String] -> ([Opt] -> FilterSpec -> Ledger -> String) -> AppUnit
- command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) l''
- (loli $ -- State Loli () -> (Env -> IO Response)
- do
- get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()
- get "/register" $ command [] showRegisterReport
- get "/histogram" $ command [] showHistogram
- get "/transactions" $ ledgerpage [] l'' (showTransactions (optsToFilterSpec opts' args' t))
- post "/transactions" $ handleAddform l''
- get "/env" $ getenv >>= (text . show)
- get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params)
- get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs)
- public (Just webfiles) ["/style.css"]
- get "/" $ redirect ("transactions") Nothing
- ) env
-
-getenv = ask
-response = update
-redirect u c = response $ Hack.Contrib.Response.redirect u c
-
-reqparam :: Hack.Env -> String -> [String]
-#if __GLASGOW_HASKELL__ <= 610
-reqparam env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
-#else
-reqparam env p = map (decodeString.snd) $ filter ((==p).fst) $ Hack.Contrib.Request.params env
-#endif
-
-ledgerFileModifiedTime :: Ledger -> IO ClockTime
-ledgerFileModifiedTime l
- | null path = getClockTime
- | otherwise = getModificationTime path `Prelude.catch` \_ -> getClockTime
- where path = filepath $ journal l
-
-ledgerFileReadTime :: Ledger -> ClockTime
-ledgerFileReadTime l = filereadtime $ journal l
-
-reload :: Ledger -> IO Ledger
-reload l = do
- l' <- readLedger (filepath $ journal l)
- putValue "hledger" "ledger" l'
- return l'
-
-reloadIfChanged :: [Opt] -> [String] -> Ledger -> IO Ledger
-reloadIfChanged opts _ l = do
- tmod <- ledgerFileModifiedTime l
- let tread = ledgerFileReadTime l
- newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
- -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)
- if newer
- then do
- when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" (filepath $ journal l)
- reload l
- else return l
-
--- refilter :: [Opt] -> [String] -> Ledger -> LocalTime -> IO Ledger
--- refilter opts args l t = return $ filterAndCacheLedgerWithOpts opts args t (jtext $ journal l) (journal l)
-
-ledgerpage :: [String] -> Ledger -> (Ledger -> String) -> AppUnit
-ledgerpage msgs l f = do
- env <- getenv
- l' <- io $ reloadIfChanged [] [] l
- hsp msgs $ const
<% addform env %>
<% f l' %>
-
--- | A loli directive to serve a string in pre tags within the hledger web
--- layout.
-string :: [String] -> String -> AppUnit
-string msgs s = hsp msgs $ const
<% s %>
-
--- | A loli directive to serve a hsp template wrapped in the hledger web
--- layout. The hack environment is passed in to every hsp template as an
--- argument, since I don't see how to get it within the hsp monad.
--- A list of messages is also passed, eg for form errors.
-hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
-hsp msgs f = do
- env <- getenv
- let contenthsp = f env
- pagehsp = hledgerpage env msgs title contenthsp
- html =<< (io $ do
- hspenv <- hackEnvToHspEnv env
- (_,xml) <- runHSP html4Strict pagehsp hspenv
- return $ addDoctype $ renderAsHTML xml)
- response $ set_content_type _TextHtmlUTF8
- where
- title = ""
- addDoctype = ("\n" ++)
- hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
- hackEnvToHspEnv env = do
- x <- newIORef 0
- let req = HSP.Request (reqparam env) (Hack.http env)
- num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
- return $ HSPEnv req num
-
--- htmlToHsp :: Html -> HSP XML
--- htmlToHsp h = return $ cdata $ showHtml h
-
--- views
-
-hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
-hledgerpage env msgs title content =
-
-
-
-
- <% title %>
-
-
- <% navbar env %>
-
-
-#if __GLASGOW_HASKELL__ <= 610
-getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p
-#else
-getParamOrNull p = fromMaybe "" `fmap` getParam p
-#endif
-
-navlinks :: Hack.Env -> HSP XML
-navlinks _ = do
- a <- getParamOrNull "a"
- p <- getParamOrNull "p"
- let addparams=(++(printf "?a=%s&p=%s" (urlEncode a) (urlEncode p)))
- link s = <% s %>
-
- <% link "transactions" %> |
- <% link "register" %> |
- <% link "balance" %>
-
-
-searchform :: Hack.Env -> HSP XML
-searchform env = do
- a <- getParamOrNull "a"
- p <- getParamOrNull "p"
- let resetlink | null a && null p =
- | otherwise = <% nbsp %>reset
- where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
-
-
-addform :: Hack.Env -> HSP XML
-addform env = do
- today <- io $ liftM showDate $ getCurrentDay
- let inputs = Hack.Contrib.Request.inputs env
-#if __GLASGOW_HASKELL__ <= 610
- date = decodeString $ fromMaybe today $ lookup "date" inputs
- desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
-#else
- date = fromMaybe today $ lookup "date" inputs
- desc = fromMaybe "" $ lookup "desc" inputs
-#endif
-
-
-
-
-
-
-
-help :: String -> HSP XML
-help topic = ?
- where u = printf "http://hledger.org/MANUAL.html%s" l :: String
- l | null topic = ""
- | otherwise = '#':topic
-
-transactionfields :: Int -> Hack.Env -> HSP XML
-transactionfields n env = do
- let inputs = Hack.Contrib.Request.inputs env
-#if __GLASGOW_HASKELL__ <= 610
- acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
- amt = decodeString $ fromMaybe "" $ lookup amtvar inputs
-#else
- acct = fromMaybe "" $ lookup acctvar inputs
- amt = fromMaybe "" $ lookup amtvar inputs
-#endif
-
- where
- numbered = (++ show n)
- acctvar = numbered "acct"
- amtvar = numbered "amt"
-
-handleAddform :: Ledger -> AppUnit
-handleAddform l = do
- env <- getenv
- d <- io getCurrentDay
- t <- io getCurrentLocalTime
- handle t $ validate env d
- where
- validate :: Hack.Env -> Day -> Failing Transaction
- validate env today =
- let inputs = Hack.Contrib.Request.inputs env
-#if __GLASGOW_HASKELL__ <= 610
- date = decodeString $ fromMaybe "today" $ lookup "date" inputs
- desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
- acct1 = decodeString $ fromMaybe "" $ lookup "acct1" inputs
- amt1 = decodeString $ fromMaybe "" $ lookup "amt1" inputs
- acct2 = decodeString $ fromMaybe "" $ lookup "acct2" inputs
- amt2 = decodeString $ fromMaybe "" $ lookup "amt2" inputs
-#else
- date = fromMaybe "today" $ lookup "date" inputs
- desc = fromMaybe "" $ lookup "desc" inputs
- acct1 = fromMaybe "" $ lookup "acct1" inputs
- amt1 = fromMaybe "" $ lookup "amt1" inputs
- acct2 = fromMaybe "" $ lookup "acct2" inputs
- amt2 = fromMaybe "" $ lookup "amt2" inputs
-#endif
- validateDate "" = ["missing date"]
- validateDate _ = []
- validateDesc "" = ["missing description"]
- validateDesc _ = []
- validateAcct1 "" = ["missing account 1"]
- validateAcct1 _ = []
- validateAmt1 "" = ["missing amount 1"]
- validateAmt1 _ = []
- validateAcct2 "" = ["missing account 2"]
- validateAcct2 _ = []
- validateAmt2 _ = []
- amt1' = either (const missingamt) id $ parse someamount "" amt1
- amt2' = either (const missingamt) id $ parse someamount "" amt2
- (date', dateparseerr) = case fixSmartDateStrEither today date of
- Right d -> (d, [])
- Left e -> ("1900/01/01", [showDateParseError e])
- t = Transaction {
- tdate = parsedate date' -- date' must be parseable
- ,teffectivedate=Nothing
- ,tstatus=False
- ,tcode=""
- ,tdescription=desc
- ,tcomment=""
- ,tpostings=[
- Posting False acct1 amt1' "" RegularPosting (Just t')
- ,Posting False acct2 amt2' "" RegularPosting (Just t')
- ]
- ,tpreceding_comment_lines=""
- }
- (t', balanceerr) = case balanceTransaction t of
- Right t'' -> (t'', [])
- Left e -> (t, [head $ lines e]) -- show just the error not the transaction
- errs = concat [
- validateDate date
- ,dateparseerr
- ,validateDesc desc
- ,validateAcct1 acct1
- ,validateAmt1 amt1
- ,validateAcct2 acct2
- ,validateAmt2 amt2
- ,balanceerr
- ]
- in
- case null errs of
- False -> Failure errs
- True -> Success t'
-
- handle :: LocalTime -> Failing Transaction -> AppUnit
- handle _ (Failure errs) = hsp errs addform
- handle ti (Success t) = do
- io $ ledgerAddTransaction l t >> reload l
- ledgerpage [msg] l (showTransactions (optsToFilterSpec [] [] ti))
- where msg = printf "Added transaction:\n%s" (show t)
-
-nbsp :: XML
-nbsp = cdata " "
diff --git a/Hledger/Cli/Commands/Add.hs b/Hledger/Cli/Commands/Add.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Add.hs
@@ -0,0 +1,198 @@
+{-# LANGUAGE CPP #-}
+{-|
+
+A history-aware add command to help with data entry.
+
+-}
+
+module Hledger.Cli.Commands.Add
+where
+import Hledger.Data
+import Hledger.Cli.Options
+import Hledger.Cli.Commands.Register (showRegisterReport)
+#if __GLASGOW_HASKELL__ <= 610
+import Prelude hiding (putStr, putStrLn, getLine, appendFile)
+import System.IO.UTF8
+import System.IO ( stderr, hFlush )
+#else
+import System.IO ( stderr, hFlush, hPutStrLn, hPutStr )
+#endif
+import System.IO.Error
+import Text.ParserCombinators.Parsec
+import Hledger.Cli.Utils (journalFromStringWithOpts)
+import qualified Data.Foldable as Foldable (find)
+
+-- | 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] -> Journal -> IO ()
+add opts args j
+ | filepath j == "-" = 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, press control-c."
+ today <- getCurrentDay
+ getAndAddTransactions j opts args today `catch` (\e -> unless (isEOFError e) $ ioError e)
+
+-- | Read a number of transactions from the command line, prompting,
+-- validating, displaying and appending them to the journal file, until
+-- end of input (then raise an EOF exception). Any command-line arguments
+-- are used as the first transaction's description.
+getAndAddTransactions :: Journal -> [Opt] -> [String] -> Day -> IO ()
+getAndAddTransactions j opts args defaultDate = do
+ (t, d) <- getTransaction j opts args defaultDate
+ j <- journalAddTransaction j t
+ getAndAddTransactions j opts args d
+
+-- | Read a transaction from the command line, with history-aware prompting.
+getTransaction :: Journal -> [Opt] -> [String] -> Day -> IO (Transaction,Day)
+getTransaction j opts args defaultDate = do
+ today <- getCurrentDay
+ datestr <- askFor "date"
+ (Just $ showDate defaultDate)
+ (Just $ \s -> null s ||
+ isRight (parse (smartdate >> many spacenonewline >> eof) "" $ lowercase s))
+ description <- askFor "description" Nothing (Just $ not . null)
+ let historymatches = transactionsSimilarTo j args description
+ bestmatch | null historymatches = Nothing
+ | otherwise = Just $ snd $ head historymatches
+ bestmatchpostings = maybe Nothing (Just . tpostings) bestmatch
+ date = fixSmartDate today $ fromparse $ (parse smartdate "" . lowercase) datestr
+ accept x = x == "." || (not . null) x &&
+ if NoNewAccts `elem` opts
+ then isJust $ Foldable.find (== x) ant
+ else True
+ where (ant,_,_,_) = groupPostings $ journalPostings j
+ getpostingsandvalidate = do
+ ps <- getPostings accept bestmatchpostings []
+ let t = nulltransaction{tdate=date
+ ,tstatus=False
+ ,tdescription=description
+ ,tpostings=ps
+ }
+ retry msg = do
+ hPutStrLn stderr $ "\n" ++ msg ++ "please re-enter."
+ getpostingsandvalidate
+ either retry (return . flip (,) date) $ balanceTransaction t
+ unless (null historymatches)
+ (do
+ hPutStrLn stderr "Similar transactions found, using the first for defaults:\n"
+ hPutStr stderr $ concatMap (\(n,t) -> printf "[%3d%%] %s" (round $ n*100 :: Int) (show t)) $ take 3 historymatches)
+ getpostingsandvalidate
+
+-- | Read postings from the command line until . is entered, using the
+-- provided historical postings, if any, to guess defaults.
+getPostings :: (AccountName -> Bool) -> Maybe [Posting] -> [Posting] -> IO [Posting]
+getPostings accept historicalps enteredps = do
+ account <- askFor (printf "account %d" n) defaultaccount (Just accept)
+ 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 = nullposting{paccount=stripbrackets account,
+ pamount=amount,
+ ptype=postingtype account}
+ getPostings accept 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 $ sumMixedAmountsPreservingHighestPrecision $ 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 journal's file. Also, to the journal's
+-- transaction list, but we don't bother updating the other fields - this
+-- is enough to include new transactions in the history matching.
+journalAddTransaction :: Journal -> Transaction -> IO Journal
+journalAddTransaction j@Journal{jtxns=ts} t = do
+ appendToJournalFile j $ showTransaction t
+ putStrLn $ printf "\nAdded transaction to %s:" (filepath j)
+ putStrLn =<< registerFromString (show t)
+ return j{jtxns=ts++[t]}
+
+-- | Append data to the journal's file, ensuring proper separation from
+-- any existing data; or if the file is "-", dump it to stdout.
+appendToJournalFile :: Journal -> String -> IO ()
+appendToJournalFile Journal{filepath=f, jtext=t} s =
+ if f == "-"
+ then putStr $ sep ++ s
+ else appendFile f $ sep++s
+ where
+ -- XXX we are looking at the original raw text from when the ledger
+ -- was first read, but that's good enough for now
+ 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 <- journalFromStringWithOpts [] s
+ return $ showRegisterReport opts (optsToFilterSpec opts [] now) l
+ where opts = [Empty]
+
+-- | 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 _ = []
+
+compareDescriptions :: [Char] -> [Char] -> Double
+compareDescriptions s t = compareStrings s' t'
+ where s' = simplify s
+ t' = simplify t
+ simplify = filter (not . (`elem` "0123456789"))
+
+transactionsSimilarTo :: Journal -> [String] -> String -> [(Double,Transaction)]
+transactionsSimilarTo j apats s =
+ sortBy compareRelevanceAndRecency
+ $ filter ((> threshold).fst)
+ [(compareDescriptions s $ tdescription t, t) | t <- ts]
+ where
+ compareRelevanceAndRecency (n1,t1) (n2,t2) = compare (n2,tdate t2) (n1,tdate t1)
+ ts = jtxns $ filterJournalTransactionsByAccount apats j
+ threshold = 0
+
diff --git a/Hledger/Cli/Commands/All.hs b/Hledger/Cli/Commands/All.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/All.hs
@@ -0,0 +1,67 @@
+{-# LANGUAGE 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 Hledger.Cli.Commands.All (
+ module Hledger.Cli.Commands.Add,
+ module Hledger.Cli.Commands.Balance,
+ module Hledger.Cli.Commands.Convert,
+ module Hledger.Cli.Commands.Histogram,
+ module Hledger.Cli.Commands.Print,
+ module Hledger.Cli.Commands.Register,
+ module Hledger.Cli.Commands.Stats,
+#ifdef VTY
+ module Hledger.Cli.Commands.Vty,
+#endif
+#if defined(WEB) || defined(WEBHAPPSTACK)
+ module Hledger.Cli.Commands.Web,
+#endif
+#ifdef CHART
+ module Hledger.Cli.Commands.Chart,
+#endif
+ tests_Hledger_Commands
+ )
+where
+import Hledger.Cli.Commands.Add
+import Hledger.Cli.Commands.Balance
+import Hledger.Cli.Commands.Convert
+import Hledger.Cli.Commands.Histogram
+import Hledger.Cli.Commands.Print
+import Hledger.Cli.Commands.Register
+import Hledger.Cli.Commands.Stats
+#ifdef VTY
+import Hledger.Cli.Commands.Vty
+#endif
+#if defined(WEB) || defined(WEBHAPPSTACK)
+import Hledger.Cli.Commands.Web
+#endif
+#ifdef CHART
+import Hledger.Cli.Commands.Chart
+#endif
+import Test.HUnit (Test(TestList))
+
+
+tests_Hledger_Commands = TestList
+ [
+-- Hledger.Cli.Commands.Add.tests_Add
+-- ,Hledger.Cli.Commands.Balance.tests_Balance
+ Hledger.Cli.Commands.Convert.tests_Convert
+-- ,Hledger.Cli.Commands.Histogram.tests_Histogram
+-- ,Hledger.Cli.Commands.Print.tests_Print
+ ,Hledger.Cli.Commands.Register.tests_Register
+-- ,Hledger.Cli.Commands.Stats.tests_Stats
+ ]
+-- #ifdef VTY
+-- ,Hledger.Cli.Commands.Vty.tests_Vty
+-- #endif
+-- #if defined(WEB) || defined(WEBHAPPSTACK)
+-- ,Hledger.Cli.Commands.Web.tests_Web
+-- #endif
+-- #ifdef CHART
+-- ,Hledger.Cli.Commands.Chart.tests_Chart
+-- #endif
diff --git a/Hledger/Cli/Commands/Balance.hs b/Hledger/Cli/Commands/Balance.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Balance.hs
@@ -0,0 +1,165 @@
+{-# LANGUAGE CPP #-}
+{-|
+
+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 Hledger.Cli.Commands.Balance
+where
+import Hledger.Data.Utils
+import Hledger.Data.Types
+import Hledger.Data.Amount
+import Hledger.Data.AccountName
+import Hledger.Data.Posting
+import Hledger.Data.Ledger
+import Hledger.Cli.Options
+#if __GLASGOW_HASKELL__ <= 610
+import Prelude hiding ( putStr )
+import System.IO.UTF8
+#endif
+
+
+-- | Print a balance report.
+balance :: [Opt] -> [String] -> Journal -> IO ()
+balance opts args j = do
+ t <- getCurrentLocalTime
+ putStr $ showBalanceReport opts (optsToFilterSpec opts args t) j
+
+-- | Generate a balance report with the specified options for this ledger.
+showBalanceReport :: [Opt] -> FilterSpec -> Journal -> String
+showBalanceReport opts filterspec j = acctsstr ++ totalstr
+ where
+ l = journalToLedger filterspec j
+ 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 (fromMaybe 99999 $ depthFromOpts opts) l
+ totalstr | NoTotal `elem` opts = ""
+ | notElem Empty opts && isZeroMixedAmount total = ""
+ | otherwise = printf "--------------------\n%s\n" $ padleft 20 $ showMixedAmountWithoutPrice 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 $ showMixedAmountWithoutPrice $ abalance $ ledgerAccount l a
+ parents = parentAccountNames a
+ interestingparents = filter (`elem` interestingaccts) parents
+ depthspacer = replicate (indentperlevel * length interestingparents) ' '
+ indentperlevel = 2
+ -- the partial name is the account's leaf name, prefixed by the
+ -- names of any boring parents immediately above
+ partialname = accountNameFromComponents $ reverse (map accountLeafName ps) ++ [accountLeafName a]
+ 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 = isJust d && Just (accountNameLevel a) == d where d = depthFromOpts opts
+ emptyflag = Empty `elem` opts
+ acct = ledgerAccount l a
+ notzero = not $ isZeroMixedAmount inclbalance where inclbalance = abalance acct
+ notlikesub = not $ isZeroMixedAmount exclbalance where exclbalance = sumPostings $ apostings acct
+ numinterestingsubs = length $ filter isInterestingTree subtrees
+ where
+ isInterestingTree = treeany (isInteresting opts l . aname)
+ subtrees = map (fromJust . ledgerAccountTreeAt l) $ ledgerSubAccounts l $ ledgerAccount l a
+
diff --git a/Hledger/Cli/Commands/Chart.hs b/Hledger/Cli/Commands/Chart.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Chart.hs
@@ -0,0 +1,108 @@
+{-|
+
+Generate balances pie chart
+
+-}
+
+module Hledger.Cli.Commands.Chart
+where
+import Hledger.Data.Utils
+import Hledger.Data.Types
+import Hledger.Data.Amount
+import Hledger.Data.Ledger
+import Hledger.Data.Commodity
+import Hledger.Cli.Options
+
+import Control.Monad (liftM3)
+import Graphics.Rendering.Chart
+import Data.Colour
+import Data.Colour.Names
+import Data.Colour.RGBSpace
+import Data.Colour.RGBSpace.HSL (hsl)
+import Data.Colour.SRGB.Linear (rgb)
+import Data.List
+import Safe (readDef)
+
+-- | Generate an image with the pie chart and write it to a file
+chart :: [Opt] -> [String] -> Journal -> IO ()
+chart opts args j = do
+ t <- getCurrentLocalTime
+ let chart = genPie opts (optsToFilterSpec opts args t) j
+ renderableToPNGFile (toRenderable chart) w h filename
+ where
+ filename = getOption opts ChartOutput chartoutput
+ (w,h) = parseSize $ getOption opts ChartSize chartsize
+
+-- | Extract string option value from a list of options or use the default
+getOption :: [Opt] -> (String->Opt) -> String -> String
+getOption opts opt def =
+ case reverse $ optValuesForConstructor opt opts of
+ [] -> def
+ x:_ -> x
+
+-- | Parse image size from a command-line option
+parseSize :: String -> (Int,Int)
+parseSize str = (read w, read h)
+ where
+ x = fromMaybe (error "Size should be in WIDTHxHEIGHT format") $ findIndex (=='x') str
+ (w,_:h) = splitAt x str
+
+-- | Generate pie chart
+genPie :: [Opt] -> FilterSpec -> Journal -> PieLayout
+genPie opts filterspec j = defaultPieLayout { pie_background_ = solidFillStyle $ opaque $ white
+ , pie_plot_ = pie_chart }
+ where
+ pie_chart = defaultPieChart { pie_data_ = map (uncurry accountPieItem) chartitems'
+ , pie_start_angle_ = (-90)
+ , pie_colors_ = mkColours hue
+ , pie_label_style_ = defaultFontStyle{font_size_=12}
+ }
+ chartitems' = debug "chart" $ top num samesignitems
+ (samesignitems, sign) = sameSignNonZero rawitems
+ rawitems = debug "raw" $ flatten $ balances $
+ ledgerAccountTree (fromMaybe 99999 $ depthFromOpts opts) $ journalToLedger filterspec j
+ top n t = topn ++ [other]
+ where
+ (topn,rest) = splitAt n $ reverse $ sortBy (comparing snd) t
+ other = ("other", sum $ map snd rest)
+ num = readDef (fromIntegral chartitems) (getOption opts ChartItems (show chartitems))
+ hue = if sign > 0 then red else green where (red, green) = (0, 110)
+ debug s = if Debug `elem` opts then ltrace s else id
+
+-- | Select the nonzero items with same sign as the first, and make
+-- them positive. Also return a 1 or -1 corresponding to the original sign.
+sameSignNonZero :: [(AccountName, Double)] -> ([(AccountName, Double)], Int)
+sameSignNonZero is | null nzs = ([], 1)
+ | otherwise = (map pos $ filter (test.snd) nzs, sign)
+ where
+ nzs = filter ((/=0).snd) is
+ pos (a,b) = (a, abs b)
+ sign = if snd (head nzs) >= 0 then 1 else (-1)
+ test = if sign > 0 then (>0) else (<0)
+
+-- | Convert all quantities of MixedAccount to a single commodity
+amountValue :: MixedAmount -> Double
+amountValue = quantity . convertMixedAmountTo unknown
+
+-- | Generate a tree of account names together with their balances.
+-- The balance of account is decremented by the balance of its subaccounts
+-- which are drawn on the chart.
+balances :: Tree Account -> Tree (AccountName, Double)
+balances (Node rootAcc subAccs) = Node newroot newsubs
+ where
+ newroot = (aname rootAcc,
+ amountValue $
+ abalance rootAcc - (sum . map (abalance . root)) subAccs)
+ newsubs = map balances subAccs
+
+-- | Build a single pie chart item
+accountPieItem :: AccountName -> Double -> PieItem
+accountPieItem accname balance = PieItem accname offset balance where offset = 0
+
+-- | Generate an infinite color list suitable for charts.
+mkColours :: Double -> [AlphaColour Double]
+mkColours hue = cycle $ [opaque $ rgbToColour $ hsl h s l | (h,s,l) <- liftM3 (,,)
+ [hue] [0.7] [0.1,0.2..0.7] ]
+
+rgbToColour :: (Fractional a) => RGB a -> Colour a
+rgbToColour (RGB r g b) = rgb r g b
diff --git a/Hledger/Cli/Commands/Convert.hs b/Hledger/Cli/Commands/Convert.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Convert.hs
@@ -0,0 +1,386 @@
+{-|
+Convert account data in CSV format (eg downloaded from a bank) to ledger
+format, and print it on stdout. See the manual for more details.
+-}
+
+module Hledger.Cli.Commands.Convert where
+import Hledger.Cli.Options (Opt(Debug))
+import Hledger.Cli.Version (versionstr)
+import Hledger.Data.Types (Journal,AccountName,Transaction(..),Posting(..),PostingType(..))
+import Hledger.Data.Utils (strip, spacenonewline, restofline, parseWithCtx, assertParse, assertParseEqual)
+import Hledger.Data.Parse (someamount, emptyCtx, ledgeraccountname)
+import Hledger.Data.Amount (nullmixedamt)
+import Safe (atDef, maximumDef)
+import System.IO (stderr)
+import Text.CSV (parseCSVFromFile, printCSV)
+import Text.Printf (hPrintf)
+import Text.RegexPR (matchRegexPR, gsubRegexPR)
+import Data.Maybe
+import Hledger.Data.Dates (firstJust, showDate, parsedate)
+import System.Locale (defaultTimeLocale)
+import Data.Time.Format (parseTime)
+import Control.Monad (when, guard, liftM)
+import Safe (readDef, readMay)
+import System.Directory (doesFileExist)
+import System.Exit (exitFailure)
+import System.FilePath.Posix (takeBaseName, replaceExtension)
+import Text.ParserCombinators.Parsec
+import Test.HUnit
+
+
+{- |
+A set of data definitions and account-matching patterns sufficient to
+convert a particular CSV data file into meaningful ledger transactions. See above.
+-}
+data CsvRules = CsvRules {
+ dateField :: Maybe FieldPosition,
+ statusField :: Maybe FieldPosition,
+ codeField :: Maybe FieldPosition,
+ descriptionField :: Maybe FieldPosition,
+ amountField :: Maybe FieldPosition,
+ currencyField :: Maybe FieldPosition,
+ baseCurrency :: Maybe String,
+ baseAccount :: AccountName,
+ accountRules :: [AccountRule]
+} deriving (Show, Eq)
+
+nullrules = CsvRules {
+ dateField=Nothing,
+ statusField=Nothing,
+ codeField=Nothing,
+ descriptionField=Nothing,
+ amountField=Nothing,
+ currencyField=Nothing,
+ baseCurrency=Nothing,
+ baseAccount="unknown",
+ accountRules=[]
+}
+
+type FieldPosition = Int
+
+type AccountRule = (
+ [(String, Maybe String)] -- list of regex match patterns with optional replacements
+ ,AccountName -- account name to use for a transaction matching this rule
+ )
+
+type CsvRecord = [String]
+
+
+-- | Read the CSV file named as an argument and print equivalent journal transactions,
+-- using/creating a .rules file.
+convert :: [Opt] -> [String] -> Journal -> IO ()
+convert opts args _ = do
+ when (null args) $ error "please specify a csv data file."
+ let csvfile = head args
+ csvparse <- parseCSVFromFile csvfile
+ let records = case csvparse of
+ Left e -> error $ show e
+ Right rs -> reverse $ filter (/= [""]) rs
+ let debug = Debug `elem` opts
+ rulesfile = rulesFileFor csvfile
+ exists <- doesFileExist rulesfile
+ if (not exists) then do
+ hPrintf stderr "creating conversion rules file %s, edit this file for better results\n" rulesfile
+ writeFile rulesfile initialRulesFileContent
+ else
+ hPrintf stderr "using conversion rules file %s\n" rulesfile
+ rules <- liftM (either (error.show) id) $ parseCsvRulesFile rulesfile
+ when debug $ hPrintf stderr "rules: %s\n" (show rules)
+ let requiredfields = max 2 (maxFieldIndex rules + 1)
+ badrecords = take 1 $ filter ((< requiredfields).length) records
+ if null badrecords
+ then mapM_ (printTxn debug rules) records
+ else do
+ hPrintf stderr (unlines [
+ "Warning, at least one CSV record does not contain a field referenced by the"
+ ,"conversion rules file, or has less than two fields. Are you converting a"
+ ,"valid CSV file ? First bad record:\n%s"
+ ]) (show $ head badrecords)
+ exitFailure
+
+-- | The highest (0-based) field index referenced in the field
+-- definitions, or -1 if no fields are defined.
+maxFieldIndex :: CsvRules -> Int
+maxFieldIndex r = maximumDef (-1) $ catMaybes [
+ dateField r
+ ,statusField r
+ ,codeField r
+ ,descriptionField r
+ ,amountField r
+ ,currencyField r
+ ]
+
+rulesFileFor :: FilePath -> FilePath
+rulesFileFor csvfile = replaceExtension csvfile ".rules"
+
+initialRulesFileContent :: String
+initialRulesFileContent =
+ "# csv conversion rules file generated by hledger "++versionstr++"\n" ++
+ "# Add rules to this file for more accurate conversion, see\n"++
+ "# http://hledger.org/MANUAL.html#convert\n" ++
+ "\n" ++
+ "base-account assets:bank:checking\n" ++
+ "date-field 0\n" ++
+ "description-field 4\n" ++
+ "amount-field 1\n" ++
+ "currency $\n" ++
+ "\n" ++
+ "# account-assigning rules\n" ++
+ "\n" ++
+ "SPECTRUM\n" ++
+ "expenses:health:gym\n" ++
+ "\n" ++
+ "ITUNES\n" ++
+ "BLKBSTR=BLOCKBUSTER\n" ++
+ "expenses:entertainment\n" ++
+ "\n" ++
+ "(TO|FROM) SAVINGS\n" ++
+ "assets:bank:savings\n"
+
+-- rules file parser
+
+parseCsvRulesFile :: FilePath -> IO (Either ParseError CsvRules)
+parseCsvRulesFile f = do
+ s <- readFile f
+ return $ parseCsvRules f s
+
+parseCsvRules :: FilePath -> String -> Either ParseError CsvRules
+parseCsvRules rulesfile s = runParser csvrulesfile nullrules{baseAccount=takeBaseName rulesfile} rulesfile s
+
+csvrulesfile :: GenParser Char CsvRules CsvRules
+csvrulesfile = do
+ many blankorcommentline
+ many definitions
+ r <- getState
+ ars <- many accountrule
+ many blankorcommentline
+ eof
+ return r{accountRules=ars}
+
+-- | Real independent parser choice, even when alternative matches share a prefix.
+choice' parsers = choice $ map try (init parsers) ++ [last parsers]
+
+definitions :: GenParser Char CsvRules ()
+definitions = do
+ choice' [
+ datefield
+ ,statusfield
+ ,codefield
+ ,descriptionfield
+ ,amountfield
+ ,currencyfield
+ ,basecurrency
+ ,baseaccount
+ ,commentline
+ ] "definition"
+ return ()
+
+datefield = do
+ string "date-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{dateField=readMay v}
+
+codefield = do
+ string "code-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{codeField=readMay v}
+
+statusfield = do
+ string "status-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{statusField=readMay v}
+
+descriptionfield = do
+ string "description-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{descriptionField=readMay v}
+
+amountfield = do
+ string "amount-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{amountField=readMay v}
+
+currencyfield = do
+ string "currency-field"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{currencyField=readMay v}
+
+basecurrency = do
+ string "currency"
+ many1 spacenonewline
+ v <- restofline
+ r <- getState
+ setState r{baseCurrency=Just v}
+
+baseaccount = do
+ string "base-account"
+ many1 spacenonewline
+ v <- ledgeraccountname
+ optional newline
+ r <- getState
+ setState r{baseAccount=v}
+
+accountrule :: GenParser Char CsvRules AccountRule
+accountrule = do
+ many blankorcommentline
+ pats <- many1 matchreplacepattern
+ guard $ length pats >= 2
+ let pats' = init pats
+ acct = either (fail.show) id $ runParser ledgeraccountname () "" $ fst $ last pats
+ many blankorcommentline
+ return (pats',acct)
+ "account rule"
+
+blanklines = many1 blankline >> return ()
+
+blankline = many spacenonewline >> newline >> return () "blank line"
+
+commentchar = oneOf ";#"
+
+commentline = many spacenonewline >> commentchar >> restofline >> return () "comment line"
+
+blankorcommentline = choice' [blankline, commentline]
+
+matchreplacepattern = do
+ notFollowedBy commentchar
+ matchpat <- many1 (noneOf "=\n")
+ replpat <- optionMaybe $ do {char '='; many $ noneOf "\n"}
+ newline
+ return (matchpat,replpat)
+
+printTxn :: Bool -> CsvRules -> CsvRecord -> IO ()
+printTxn debug rules rec = do
+ when debug $ hPrintf stderr "record: %s" (printCSV [rec])
+ putStr $ show $ transactionFromCsvRecord rules rec
+
+-- csv record conversion
+
+transactionFromCsvRecord :: CsvRules -> CsvRecord -> Transaction
+transactionFromCsvRecord rules fields =
+ let
+ date = parsedate $ normaliseDate $ maybe "1900/1/1" (atDef "" fields) (dateField rules)
+ status = maybe False (null . strip . (atDef "" fields)) (statusField rules)
+ code = maybe "" (atDef "" fields) (codeField rules)
+ desc = maybe "" (atDef "" fields) (descriptionField rules)
+ comment = ""
+ precomment = ""
+ amountstr = maybe "" (atDef "" fields) (amountField rules)
+ amountstr' = strnegate amountstr where strnegate ('-':s) = s
+ strnegate s = '-':s
+ currency = maybe (fromMaybe "" $ baseCurrency rules) (atDef "" fields) (currencyField rules)
+ amountstr'' = currency ++ amountstr'
+ amountparse = runParser someamount emptyCtx "" amountstr''
+ amount = either (const nullmixedamt) id amountparse
+ unknownacct | (readDef 0 amountstr' :: Double) < 0 = "income:unknown"
+ | otherwise = "expenses:unknown"
+ (acct,newdesc) = identify (accountRules rules) unknownacct desc
+ t = Transaction {
+ tdate=date,
+ teffectivedate=Nothing,
+ tstatus=status,
+ tcode=code,
+ tdescription=newdesc,
+ tcomment=comment,
+ tpreceding_comment_lines=precomment,
+ tpostings=[
+ Posting {
+ pstatus=False,
+ paccount=acct,
+ pamount=amount,
+ pcomment="",
+ ptype=RegularPosting,
+ ptransaction=Just t
+ },
+ Posting {
+ pstatus=False,
+ paccount=baseAccount rules,
+ pamount=(-amount),
+ pcomment="",
+ ptype=RegularPosting,
+ ptransaction=Just t
+ }
+ ]
+ }
+ in t
+
+-- | Convert some date string with unknown format to YYYY/MM/DD.
+normaliseDate :: String -> String
+normaliseDate s = maybe "0000/00/00" showDate $
+ firstJust
+ [parseTime defaultTimeLocale "%Y/%m/%e" s
+ -- can't parse a month without leading 0, try adding one
+ ,parseTime defaultTimeLocale "%Y/%m/%e" (take 5 s ++ "0" ++ drop 5 s)
+ ,parseTime defaultTimeLocale "%Y-%m-%e" s
+ ,parseTime defaultTimeLocale "%Y-%m-%e" (take 5 s ++ "0" ++ drop 5 s)
+ ,parseTime defaultTimeLocale "%m/%e/%Y" s
+ ,parseTime defaultTimeLocale "%m/%e/%Y" ('0':s)
+ ,parseTime defaultTimeLocale "%m-%e-%Y" s
+ ,parseTime defaultTimeLocale "%m-%e-%Y" ('0':s)
+ ]
+
+-- | Apply account matching rules to a transaction description to obtain
+-- the most appropriate account and a new description.
+identify :: [AccountRule] -> String -> String -> (String,String)
+identify rules defacct desc | null matchingrules = (defacct,desc)
+ | otherwise = (acct,newdesc)
+ where
+ matchingrules = filter ismatch rules :: [AccountRule]
+ where ismatch = any (isJust . flip matchRegexPR (caseinsensitive desc) . fst) . fst
+ (prs,acct) = head matchingrules
+ p_ms_r = filter (\(_,m,_) -> isJust m) $ map (\(p,r) -> (p, matchRegexPR (caseinsensitive p) desc, r)) prs
+ (p,_,r) = head p_ms_r
+ newdesc = case r of Just rpat -> gsubRegexPR (caseinsensitive p) rpat desc
+ Nothing -> desc
+
+caseinsensitive = ("(?i)"++)
+
+tests_Convert = TestList [
+
+ "convert rules parsing: empty file" ~: do
+ -- let assertMixedAmountParse parseresult mixedamount =
+ -- (either (const "parse error") showMixedAmountDebug parseresult) ~?= (showMixedAmountDebug mixedamount)
+ assertParseEqual (parseCsvRules "unknown" "") nullrules
+
+ ,"convert rules parsing: accountrule" ~: do
+ assertParseEqual (parseWithCtx nullrules accountrule "A\na\n") -- leading blank line required
+ ([("A",Nothing)], "a")
+
+ ,"convert rules parsing: trailing comments" ~: do
+ assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#\n")
+
+ ,"convert rules parsing: trailing blank lines" ~: do
+ assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n \n")
+
+ -- not supported
+ -- ,"convert rules parsing: no final newline" ~: do
+ -- assertParse (parseWithCtx nullrules csvrulesfile "A\na")
+ -- assertParse (parseWithCtx nullrules csvrulesfile "A\na\n# \n#")
+ -- assertParse (parseWithCtx nullrules csvrulesfile "A\na\n\n ")
+
+ -- (nullrules{
+ -- -- dateField=Maybe FieldPosition,
+ -- -- statusField=Maybe FieldPosition,
+ -- -- codeField=Maybe FieldPosition,
+ -- -- descriptionField=Maybe FieldPosition,
+ -- -- amountField=Maybe FieldPosition,
+ -- -- currencyField=Maybe FieldPosition,
+ -- -- baseCurrency=Maybe String,
+ -- -- baseAccount=AccountName,
+ -- accountRules=[
+ -- ([("A",Nothing)], "a")
+ -- ]
+ -- })
+
+ ]
diff --git a/Hledger/Cli/Commands/Histogram.hs b/Hledger/Cli/Commands/Histogram.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Histogram.hs
@@ -0,0 +1,50 @@
+{-# LANGUAGE CPP #-}
+{-|
+
+Print a histogram report.
+
+-}
+
+module Hledger.Cli.Commands.Histogram
+where
+import Hledger.Data
+import Hledger.Cli.Options
+#if __GLASGOW_HASKELL__ <= 610
+import Prelude hiding ( putStr )
+import System.IO.UTF8
+#endif
+
+
+barchar = '*'
+
+-- | Print a histogram of some statistic per reporting interval, such as
+-- number of postings per day.
+histogram :: [Opt] -> [String] -> Journal -> IO ()
+histogram opts args j = do
+ t <- getCurrentLocalTime
+ putStr $ showHistogram opts (optsToFilterSpec opts args t) j
+
+showHistogram :: [Opt] -> FilterSpec -> Journal -> String
+showHistogram opts filterspec j = concatMap (printDayWith countBar) dayps
+ where
+ i = intervalFromOpts opts
+ interval | i == NoInterval = Daily
+ | otherwise = i
+ fullspan = journalDateSpan j
+ days = filter (DateSpan Nothing Nothing /=) $ splitSpan interval fullspan
+ dayps = [(s, filter (isPostingInDateSpan s) ps) | s <- days]
+ -- same as Register
+ -- should count transactions, not postings ?
+ ps = sortBy (comparing postingDate) $ filterempties $ filter matchapats $ filterdepth $ journalPostings j
+ filterempties
+ | Empty `elem` opts = id
+ | otherwise = filter (not . isZeroMixedAmount . pamount)
+ matchapats = matchpats apats . paccount
+ apats = acctpats filterspec
+ filterdepth | interval == NoInterval = filter (\p -> accountNameLevel (paccount p) <= depth)
+ | otherwise = id
+ depth = fromMaybe 99999 $ depthFromOpts opts
+
+printDayWith f (DateSpan b _, ts) = printf "%s %s\n" (show $ fromJust b) (f ts)
+
+countBar ps = replicate (length ps) barchar
diff --git a/Hledger/Cli/Commands/Print.hs b/Hledger/Cli/Commands/Print.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Print.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE CPP #-}
+{-|
+
+A ledger-compatible @print@ command.
+
+-}
+
+module Hledger.Cli.Commands.Print
+where
+import Hledger.Data
+import Hledger.Cli.Options
+#if __GLASGOW_HASKELL__ <= 610
+import Prelude hiding ( putStr )
+import System.IO.UTF8
+#endif
+
+
+-- | Print ledger transactions in standard format.
+print' :: [Opt] -> [String] -> Journal -> IO ()
+print' opts args j = do
+ t <- getCurrentLocalTime
+ putStr $ showTransactions (optsToFilterSpec opts args t) j
+
+showTransactions :: FilterSpec -> Journal -> String
+showTransactions filterspec j =
+ concatMap (showTransactionForPrint effective) $ sortBy (comparing tdate) txns
+ where
+ effective = EffectiveDate == whichdate filterspec
+ txns = jtxns $ filterJournalTransactions filterspec j
diff --git a/Hledger/Cli/Commands/Register.hs b/Hledger/Cli/Commands/Register.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Register.hs
@@ -0,0 +1,150 @@
+{-# LANGUAGE CPP #-}
+{-|
+
+A ledger-compatible @register@ command.
+
+-}
+
+module Hledger.Cli.Commands.Register (
+ register
+ ,showRegisterReport
+ ,showPostingWithBalance
+ ,tests_Register
+) where
+
+import Safe (headMay, lastMay)
+import Hledger.Data
+import Hledger.Cli.Options
+#if __GLASGOW_HASKELL__ <= 610
+import Prelude hiding ( putStr )
+import System.IO.UTF8
+#endif
+
+
+-- | Print a register report.
+register :: [Opt] -> [String] -> Journal -> IO ()
+register opts args j = do
+ t <- getCurrentLocalTime
+ putStr $ showRegisterReport opts (optsToFilterSpec opts args t) j
+
+-- | Generate the register report, which is a list of postings with transaction
+-- info and a running balance.
+showRegisterReport :: [Opt] -> FilterSpec -> Journal -> String
+showRegisterReport opts filterspec j = showPostingsWithBalance ps nullposting startbal
+ where
+ ps | interval == NoInterval = displayableps
+ | otherwise = summarisePostings interval depth empty filterspan displayableps
+ startbal = sumPostings precedingps
+ (precedingps,displayableps,_) =
+ postingsMatchingDisplayExpr (displayExprFromOpts opts) $ journalPostings $ filterJournalPostings filterspec j
+ (interval, depth, empty) = (intervalFromOpts opts, depthFromOpts opts, Empty `elem` opts)
+ filterspan = datespan filterspec
+
+-- | Convert a list of postings into summary postings, one per interval.
+summarisePostings :: Interval -> Maybe Int -> Bool -> DateSpan -> [Posting] -> [Posting]
+summarisePostings interval depth empty filterspan ps = concatMap summarisespan $ splitSpan interval reportspan
+ where
+ summarisespan s = summarisePostingsInDateSpan s depth empty (postingsinspan s)
+ postingsinspan s = filter (isPostingInDateSpan s) ps
+ dataspan = postingsDateSpan ps
+ reportspan | empty = filterspan `orDatesFrom` dataspan
+ | otherwise = dataspan
+
+-- | Combine two datespans, filling any unspecified dates in the first
+-- with dates from the second.
+orDatesFrom (DateSpan a1 b1) (DateSpan a2 b2) = DateSpan a b
+ where a = if isJust a1 then a1 else a2
+ b = if isJust b1 then b1 else b2
+
+-- | Date-sort and split a list of postings into three spans - postings matched
+-- by the given display expression, and the preceding and following postings.
+postingsMatchingDisplayExpr :: Maybe String -> [Posting] -> ([Posting],[Posting],[Posting])
+postingsMatchingDisplayExpr d ps = (before, matched, after)
+ where
+ sorted = sortBy (comparing postingDate) ps
+ (before, rest) = break (displayExprMatches d) sorted
+ (matched, after) = span (displayExprMatches d) rest
+
+-- | Does this display expression allow this posting to be displayed ?
+-- Raises an error if the display expression can't be parsed.
+displayExprMatches :: Maybe String -> Posting -> Bool
+displayExprMatches Nothing _ = True
+displayExprMatches (Just d) p = (fromparse $ parsewith datedisplayexpr d) p
+
+-- XXX confusing, refactor
+-- | Given a date span (representing a reporting interval) and a list of
+-- postings within it: aggregate the postings so there is only one per
+-- account, and adjust their date/description so that they 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.
+--
+-- When a depth argument is present, postings to accounts of greater
+-- depth are aggregated where possible.
+--
+-- The showempty flag forces the display of a zero-posting span
+-- and also zero-posting accounts within the span.
+summarisePostingsInDateSpan :: DateSpan -> Maybe Int -> Bool -> [Posting] -> [Posting]
+summarisePostingsInDateSpan (DateSpan b e) depth showempty ps
+ | null ps && (isNothing b || isNothing e) = []
+ | null ps && showempty = [summaryp]
+ | otherwise = summaryps'
+ where
+ summaryp = summaryPosting b' ("- "++ showDate (addDays (-1) e'))
+ b' = fromMaybe (maybe nulldate postingDate $ headMay ps) b
+ e' = fromMaybe (maybe (addDays 1 nulldate) postingDate $ lastMay ps) e
+ summaryPosting date desc = nullposting{ptransaction=Just nulltransaction{tdate=date,tdescription=desc}}
+
+ summaryps' = (if showempty then id else filter (not . isZeroMixedAmount . pamount)) summaryps
+ summaryps = [summaryp{paccount=a,pamount=balancetoshowfor a} | a <- clippedanames]
+ anames = sort $ nub $ map paccount ps
+ -- aggregate balances by account, like journalToLedger, then do depth-clipping
+ (_,_,exclbalof,inclbalof) = groupPostings ps
+ clippedanames = nub $ map (clipAccountName d) anames
+ isclipped a = accountNameLevel a >= d
+ d = fromMaybe 99999 $ depth
+ balancetoshowfor a =
+ (if isclipped a then inclbalof else exclbalof) (if null a then "top" else a)
+
+{- |
+Show postings one per line, plus transaction info for the first posting of
+each transaction, and a running balance. Eg:
+
+@
+date (10) description (20) account (22) amount (11) balance (12)
+DDDDDDDDDD dddddddddddddddddddd aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
+ aaaaaaaaaaaaaaaaaaaaaa AAAAAAAAAAA AAAAAAAAAAAA
+@
+-}
+showPostingsWithBalance :: [Posting] -> Posting -> MixedAmount -> String
+showPostingsWithBalance [] _ _ = ""
+showPostingsWithBalance (p:ps) pprev bal = this ++ showPostingsWithBalance ps p bal'
+ where
+ this = showPostingWithBalance isfirst p bal'
+ isfirst = ptransaction p /= ptransaction pprev
+ bal' = bal + pamount p
+
+-- | Show one posting and running balance, with or without transaction info.
+showPostingWithBalance :: Bool -> Posting -> MixedAmount -> String
+showPostingWithBalance withtxninfo p b = concatBottomPadded [txninfo ++ pstr ++ " ", bal] ++ "\n"
+ where
+ ledger3ishlayout = False
+ datedescwidth = if ledger3ishlayout then 34 else 32
+ txninfo = if withtxninfo then printf "%s %s " date desc else replicate datedescwidth ' '
+ date = showDate da
+ datewidth = 10
+ descwidth = datedescwidth - datewidth - 2
+ desc = printf ("%-"++(show descwidth)++"s") $ elideRight descwidth de :: String
+ pstr = showPostingForRegister p
+ bal = padleft 12 (showMixedAmountOrZeroWithoutPrice b)
+ (da,de) = case ptransaction p of Just (Transaction{tdate=da',tdescription=de'}) -> (da',de')
+ Nothing -> (nulldate,"")
+
+tests_Register :: Test
+tests_Register = TestList [
+
+ "summarisePostings" ~: do
+ summarisePostings Quarterly Nothing False (DateSpan Nothing Nothing) [] ~?= []
+
+ ]
diff --git a/Hledger/Cli/Commands/Stats.hs b/Hledger/Cli/Commands/Stats.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Stats.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE CPP #-}
+{-|
+
+Print some statistics for the ledger.
+
+-}
+
+module Hledger.Cli.Commands.Stats
+where
+import Hledger.Data
+import Hledger.Cli.Options
+#if __GLASGOW_HASKELL__ <= 610
+import Prelude hiding ( putStr )
+import System.IO.UTF8
+#endif
+import qualified Data.Map as Map
+
+
+-- | Print various statistics for the ledger.
+stats :: [Opt] -> [String] -> Journal -> IO ()
+stats opts args j = do
+ today <- getCurrentDay
+ putStr $ showStats opts args (journalToLedger nullfilterspec j) today
+
+showStats :: [Opt] -> [String] -> Ledger -> Day -> String
+showStats _ _ l today =
+ heading ++ unlines (map (uncurry (printf fmt)) stats)
+ where
+ heading = underline $ printf "Ledger statistics as of %s" (show today)
+ fmt = "%-" ++ show w1 ++ "s: %-" ++ show w2 ++ "s"
+ w1 = maximum $ map (length . fst) stats
+ w2 = maximum $ map (length . show . snd) stats
+ stats = [
+ ("File", filepath $ journal l)
+ ,("Period", printf "%s to %s (%d days)" (start span) (end span) days)
+ ,("Last transaction", maybe "none" show lastdate ++ showelapsed lastelapsed)
+ ,("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)
+-- ,("Payees/descriptions", show $ length $ nub $ map tdescription ts)
+ ,("Accounts", show $ length $ accounts l)
+ ,("Account tree depth", show $ maximum $ map (accountNameLevel.aname) $ accounts l)
+ ,("Commodities", printf "%s (%s)" (show $ length $ cs) (intercalate ", " $ sort $ map symbol cs))
+ -- 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 tdate) $ jtxns $ journal l
+ lastdate | null ts = Nothing
+ | otherwise = Just $ tdate $ last ts
+ lastelapsed = maybe Nothing (Just . diffDays today) lastdate
+ showelapsed Nothing = ""
+ showelapsed (Just days) = printf " (%d %s)" days' direction
+ where days' = abs days
+ direction | days >= 0 = "days ago"
+ | otherwise = "days from now"
+ 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 = tdate t
+ txnrate30 = fromIntegral tnum30 / 30 :: Double
+ tnum7 = length $ filter withinlast7 ts
+ withinlast7 t = d >= addDays (-7) today && (d<=today) where d = tdate t
+ txnrate7 = fromIntegral tnum7 / 7 :: Double
+ cs = Map.elems $ commodities l
+
diff --git a/Hledger/Cli/Commands/Vty.hs b/Hledger/Cli/Commands/Vty.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Vty.hs
@@ -0,0 +1,379 @@
+{-|
+
+A simple text UI for hledger, based on the vty library.
+
+-}
+
+module Hledger.Cli.Commands.Vty
+where
+import Safe (headDef)
+import Graphics.Vty
+import Hledger.Data
+import Hledger.Cli.Options
+import Hledger.Cli.Commands.Balance
+import Hledger.Cli.Commands.Register
+import Hledger.Cli.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 vty 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 at startup
+ ,ajournal :: Journal -- ^ parsed journal
+ ,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
+ ,largs :: [String] -- ^ command-line args, possibly narrowed for this location
+ } 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 vty (curses-style) ui.
+vty :: [Opt] -> [String] -> Journal -> IO ()
+vty opts args j = do
+ v <- mkVty
+ DisplayRegion w h <- display_bounds $ terminal v
+ let opts' = SubTotal:opts
+ t <- getCurrentLocalTime
+ let a = enter t BalanceScreen args
+ AppState {
+ av=v
+ ,aw=fromIntegral w
+ ,ah=fromIntegral h
+ ,amsg=helpmsg
+ ,aopts=opts'
+ ,aargs=args
+ ,ajournal=j
+ ,abuf=[]
+ ,alocs=[]
+ }
+ go a
+
+-- | Update the screen, wait for the next event, repeat.
+go :: AppState -> IO ()
+go a@AppState{av=av,aopts=opts} = do
+ when (notElem DebugVty opts) $ update av (renderScreen a)
+ k <- next_event av
+ t <- getCurrentLocalTime
+ 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 t BalanceScreen a
+ EvKey (KASCII 'r') [] -> go $ resetTrailAndEnter t RegisterScreen a
+ EvKey (KASCII 'p') [] -> go $ resetTrailAndEnter t PrintScreen a
+ EvKey KRight [] -> go $ drilldown t a
+ EvKey KEnter [] -> go $ drilldown t a
+ EvKey KLeft [] -> go $ backout t 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 = setPosY 0
+
+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
+
+-- | Get the filter pattern args in effect for the current ui location.
+currentArgs :: AppState -> [String]
+currentArgs (AppState {alocs=Loc{largs=as}:_}) = as
+currentArgs (AppState {aargs=as}) = as
+
+screen :: AppState -> Screen
+screen a = scr where (Loc scr _ _ _) = loc a
+
+-- | Enter a new screen, with possibly new args, adding the new ui location to the stack.
+enter :: LocalTime -> Screen -> [String] -> AppState -> AppState
+enter t scr@BalanceScreen args a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
+enter t scr@RegisterScreen args a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
+enter t scr@PrintScreen args a = updateData t $ pushLoc Loc{scr=scr,sy=0,cy=0,largs=args} a
+
+resetTrailAndEnter :: LocalTime -> Screen -> AppState -> AppState
+resetTrailAndEnter t scr a = enter t scr (aargs a) $ clearLocs a
+
+-- | Regenerate the display data appropriate for the current screen.
+updateData :: LocalTime -> AppState -> AppState
+updateData t a@AppState{aopts=opts,ajournal=j} =
+ case screen a of
+ BalanceScreen -> a{abuf=lines $ showBalanceReport opts fspec j}
+ RegisterScreen -> a{abuf=lines $ showRegisterReport opts fspec j}
+ PrintScreen -> a{abuf=lines $ showTransactions fspec j}
+ where fspec = optsToFilterSpec opts (currentArgs a) t
+
+backout :: LocalTime -> AppState -> AppState
+backout t a | screen a == BalanceScreen = a
+ | otherwise = updateData t $ popLoc a
+
+drilldown :: LocalTime -> AppState -> AppState
+drilldown t a =
+ case screen a of
+ BalanceScreen -> enter t RegisterScreen [currentAccountName a] a
+ RegisterScreen -> scrollToTransaction e $ enter t PrintScreen (currentArgs a) a
+ PrintScreen -> a
+ where e = currentTransaction 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.
+scrollToTransaction :: Maybe Transaction -> AppState -> AppState
+scrollToTransaction Nothing a = a
+scrollToTransaction (Just t) a@AppState{abuf=buf} = setCursorY cy $ setScrollY sy a
+ where
+ entryfirstline = head $ lines $ showTransaction t
+ halfph = pageHeight a `div` 2
+ y = fromMaybe 0 $ findIndex (== entryfirstline) buf
+ sy = max 0 $ y - halfph
+ cy = y - sy
+
+-- | Get the transaction containing the posting currently highlighted by
+-- the cursor on the register screen (or best guess). Results undefined
+-- while on other screens.
+currentTransaction :: AppState -> Maybe Transaction
+currentTransaction a@AppState{ajournal=j,abuf=buf} = ptransaction p
+ where
+ p = headDef nullposting $ filter ismatch $ journalPostings j
+ ismatch p = postingDate p == parsedate (take 10 datedesc)
+ && take 70 (showPostingWithBalance False p nullmixedamt) == (datedesc ++ acctamt)
+ datedesc = take 32 $ fromMaybe "" $ find (not . (" " `isPrefixOf`)) $ headDef "" rest : reverse above
+ acctamt = drop 32 $ headDef "" rest
+ (above,rest) = splitAt y buf
+ y = posY a
+
+-- renderers
+
+renderScreen :: AppState -> Picture
+renderScreen (a@AppState{aw=w,ah=h,abuf=buf,amsg=msg}) =
+ Picture {pic_cursor = Cursor (fromIntegral cx) (fromIntegral cy)
+ ,pic_image = mainimg
+ <->
+ renderStatus w msg
+ ,pic_background = Background ' ' def_attr
+ }
+ where
+ (cx, cy) = (0, cursorY a)
+ sy = scrollY a
+-- 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
+-- trying for more speed
+ mainimg = vert_cat (map (string defaultattr) above)
+ <->
+ string currentlineattr thisline
+ <->
+ vert_cat (map (string defaultattr) below)
+ (thisline,below) | null rest = (blankline,[])
+ | otherwise = (head rest, tail rest)
+ (above,rest) = splitAt cy linestorender
+ linestorender = map padclipline $ take (h-1) $ drop sy $ buf ++ replicate h blankline
+ padclipline = take w . (++ blankline)
+ blankline = replicate w ' '
+
+padClipString :: Int -> Int -> String -> [String]
+padClipString h w s = rows
+ where
+ rows = map padclipline $ take h $ lines s ++ replicate h blankline
+ padclipline = take w . (++ blankline)
+ blankline = replicate w ' '
+
+renderString :: Attr -> String -> Image
+renderString attr s = vert_cat $ map (string attr) 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 = string statusattr . take w . (++ repeat ' ')
+
+-- the all-important theming engine!
+
+theme = Restrained
+
+data UITheme = Restrained | Colorful | Blood
+
+(defaultattr,
+ currentlineattr,
+ statusattr
+ ) = case theme of
+ Restrained -> (def_attr
+ ,def_attr `with_style` bold
+ ,def_attr `with_style` reverse_video
+ )
+ Colorful -> (def_attr `with_style` reverse_video
+ ,def_attr `with_fore_color` white `with_back_color` red
+ ,def_attr `with_fore_color` black `with_back_color` green
+ )
+ Blood -> (def_attr `with_style` reverse_video
+ ,def_attr `with_fore_color` white `with_back_color` red
+ ,def_attr `with_style` reverse_video
+ )
+
+halfbrightattr = def_attr `with_style` dim
+reverseattr = def_attr `with_style` reverse_video
+redattr = def_attr `with_fore_color` red
+greenattr = def_attr `with_fore_color` green
+reverseredattr = def_attr `with_style` reverse_video `with_fore_color` red
+reversegreenattr= def_attr `with_style` reverse_video `with_fore_color` green
diff --git a/Hledger/Cli/Commands/Web.hs b/Hledger/Cli/Commands/Web.hs
new file mode 100644
--- /dev/null
+++ b/Hledger/Cli/Commands/Web.hs
@@ -0,0 +1,345 @@
+{-# LANGUAGE CPP, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses #-}
+{-# OPTIONS_GHC -F -pgmFtrhsx #-}
+{-|
+A web-based UI.
+-}
+
+module Hledger.Cli.Commands.Web
+where
+import Codec.Binary.UTF8.String (decodeString)
+import Control.Applicative.Error (Failing(Success,Failure))
+import Control.Concurrent
+import Control.Monad.Reader (ask)
+import Data.IORef (newIORef, atomicModifyIORef)
+import System.Directory (getModificationTime)
+import System.IO.Storage (withStore, putValue, getValue)
+import System.Time (ClockTime, getClockTime, diffClockTimes, TimeDiff(TimeDiff))
+import Text.ParserCombinators.Parsec (parse)
+
+import Hack.Contrib.Constants (_TextHtmlUTF8)
+import Hack.Contrib.Response (set_content_type)
+import qualified Hack (Env, http)
+import qualified Hack.Contrib.Request (inputs, params, path)
+import qualified Hack.Contrib.Response (redirect)
+#ifdef WEBHAPPSTACK
+import System.Process (readProcess)
+import Hack.Handler.Happstack (runWithConfig,ServerConf(ServerConf))
+#else
+import Hack.Handler.SimpleServer (run)
+#endif
+
+import Network.Loli (loli, io, get, post, html, text, public)
+import Network.Loli.Type (AppUnit)
+import Network.Loli.Utils (update)
+
+import HSP hiding (Request,catch)
+import qualified HSP (Request(..))
+
+import Hledger.Cli.Commands.Add (journalAddTransaction)
+import Hledger.Cli.Commands.Balance
+import Hledger.Cli.Commands.Histogram
+import Hledger.Cli.Commands.Print
+import Hledger.Cli.Commands.Register
+import Hledger.Data
+import Hledger.Cli.Options hiding (value)
+#ifdef MAKE
+import Paths_hledger_make (getDataFileName)
+#else
+import Paths_hledger (getDataFileName)
+#endif
+import Hledger.Cli.Utils (openBrowserOn)
+
+
+tcpport = 5000 :: Int
+homeurl = printf "http://localhost:%d/" tcpport
+browserdelay = 100000 -- microseconds
+
+web :: [Opt] -> [String] -> Journal -> IO ()
+web opts args j = do
+ unless (Debug `elem` opts) $ forkIO browser >> return ()
+ server opts args j
+
+browser :: IO ()
+browser = putStrLn "starting web browser" >> threadDelay browserdelay >> openBrowserOn homeurl >> return ()
+
+server :: [Opt] -> [String] -> Journal -> IO ()
+server opts args j =
+ -- server initialisation
+ withStore "hledger" $ do -- IO ()
+ printf "starting web server on port %d\n" tcpport
+ t <- getCurrentLocalTime
+ webfiles <- getDataFileName "web"
+ putValue "hledger" "journal" j
+#ifdef WEBHAPPSTACK
+ hostname <- readProcess "hostname" [] "" `catch` \_ -> return "hostname"
+ runWithConfig (ServerConf tcpport hostname) $ -- (Env -> IO Response) -> IO ()
+#else
+ run tcpport $ -- (Env -> IO Response) -> IO ()
+#endif
+ \env -> do -- IO Response
+ -- general request handler
+ let opts' = opts ++ [Period $ unwords $ map decodeString $ reqParamUtf8 env "p"]
+ args' = args ++ map decodeString (reqParamUtf8 env "a")
+ j' <- fromJust `fmap` getValue "hledger" "journal"
+ j'' <- journalReloadIfChanged opts' args' j'
+ -- declare path-specific request handlers
+ let command :: [String] -> ([Opt] -> FilterSpec -> Journal -> String) -> AppUnit
+ command msgs f = string msgs $ f opts' (optsToFilterSpec opts' args' t) j''
+ (loli $ -- State Loli () -> (Env -> IO Response)
+ do
+ get "/balance" $ command [] showBalanceReport -- String -> ReaderT Env (StateT Response IO) () -> State Loli ()
+ get "/register" $ command [] showRegisterReport
+ get "/histogram" $ command [] showHistogram
+ get "/transactions" $ ledgerpage [] j'' (showTransactions (optsToFilterSpec opts' args' t))
+ post "/transactions" $ handleAddform j''
+ get "/env" $ getenv >>= (text . show)
+ get "/params" $ getenv >>= (text . show . Hack.Contrib.Request.params)
+ get "/inputs" $ getenv >>= (text . show . Hack.Contrib.Request.inputs)
+ public (Just webfiles) ["/style.css"]
+ get "/" $ redirect ("transactions") Nothing
+ ) env
+
+getenv = ask
+response = update
+redirect u c = response $ Hack.Contrib.Response.redirect u c
+
+reqParamUtf8 :: Hack.Env -> String -> [String]
+reqParamUtf8 env p = map snd $ filter ((==p).fst) $ Hack.Contrib.Request.params env
+
+journalReloadIfChanged :: [Opt] -> [String] -> Journal -> IO Journal
+journalReloadIfChanged opts _ j@Journal{filepath=f,filereadtime=tread} = do
+ tmod <- journalFileModifiedTime j
+ let newer = diffClockTimes tmod tread > (TimeDiff 0 0 0 0 0 0 0)
+ -- when (Debug `elem` opts) $ printf "checking file, last modified %s, last read %s, %s\n" (show tmod) (show tread) (show newer)
+ if newer
+ then do
+ when (Verbose `elem` opts) $ printf "%s has changed, reloading\n" f
+ reload j
+ else return j
+
+journalFileModifiedTime :: Journal -> IO ClockTime
+journalFileModifiedTime Journal{filepath=f}
+ | null f = getClockTime
+ | otherwise = getModificationTime f `Prelude.catch` \_ -> getClockTime
+
+reload :: Journal -> IO Journal
+reload Journal{filepath=f} = do
+ j' <- readJournal f
+ putValue "hledger" "journal" j'
+ return j'
+
+ledgerpage :: [String] -> Journal -> (Journal -> String) -> AppUnit
+ledgerpage msgs j f = do
+ env <- getenv
+ j' <- io $ journalReloadIfChanged [] [] j
+ hsp msgs $ const
<% addform env %>
<% f j' %>
+
+-- | A loli directive to serve a string in pre tags within the hledger web
+-- layout.
+string :: [String] -> String -> AppUnit
+string msgs s = hsp msgs $ const
<% s %>
+
+-- | A loli directive to serve a hsp template wrapped in the hledger web
+-- layout. The hack environment is passed in to every hsp template as an
+-- argument, since I don't see how to get it within the hsp monad.
+-- A list of messages is also passed, eg for form errors.
+hsp :: [String] -> (Hack.Env -> HSP XML) -> AppUnit
+hsp msgs f = do
+ env <- getenv
+ let contenthsp = f env
+ pagehsp = hledgerpage env msgs title contenthsp
+ html =<< (io $ do
+ hspenv <- hackEnvToHspEnv env
+ (_,xml) <- runHSP html4Strict pagehsp hspenv
+ return $ addDoctype $ renderAsHTML xml)
+ response $ set_content_type _TextHtmlUTF8
+ where
+ title = ""
+ addDoctype = ("\n" ++)
+ hackEnvToHspEnv :: Hack.Env -> IO HSPEnv
+ hackEnvToHspEnv env = do
+ x <- newIORef 0
+ let req = HSP.Request (reqParamUtf8 env) (Hack.http env)
+ num = NumberGen (atomicModifyIORef x (\a -> (a+1,a)))
+ return $ HSPEnv req num
+
+-- htmlToHsp :: Html -> HSP XML
+-- htmlToHsp h = return $ cdata $ showHtml h
+
+-- views
+
+hledgerpage :: Hack.Env -> [String] -> String -> HSP XML -> HSP XML
+hledgerpage env msgs title content =
+
+
+
+
+ <% title %>
+
+
+ <% navbar env %>
+
+
+getParamOrNull p = (decodeString . fromMaybe "") `fmap` getParam p
+
+navlinks :: Hack.Env -> HSP XML
+navlinks _ = do
+ a <- getParamOrNull "a"
+ p <- getParamOrNull "p"
+ let addparams=(++(printf "?a=%s&p=%s" a p))
+ link s = <% s %>
+
+ <% link "transactions" %> |
+ <% link "register" %> |
+ <% link "balance" %>
+
+
+searchform :: Hack.Env -> HSP XML
+searchform env = do
+ a <- getParamOrNull "a"
+ p <- getParamOrNull "p"
+ let resetlink | null a && null p =
+ | otherwise = <% nbsp %>reset
+ where u = dropWhile (=='/') $ Hack.Contrib.Request.path env
+
+
+addform :: Hack.Env -> HSP XML
+addform env = do
+ today <- io $ liftM showDate $ getCurrentDay
+ let inputs = Hack.Contrib.Request.inputs env
+ date = decodeString $ fromMaybe today $ lookup "date" inputs
+ desc = decodeString $ fromMaybe "" $ lookup "desc" inputs
+
+
+
+
+
+
+
+help :: String -> HSP XML
+help topic = ?
+ where u = printf "http://hledger.org/MANUAL.html%s" l :: String
+ l | null topic = ""
+ | otherwise = '#':topic
+
+transactionfields :: Int -> Hack.Env -> HSP XML
+transactionfields n env = do
+ let inputs = Hack.Contrib.Request.inputs env
+ acct = decodeString $ fromMaybe "" $ lookup acctvar inputs
+ amt = decodeString $ fromMaybe "" $ lookup amtvar inputs
+
+
+
+
+.. _hledger: README.html
+.. _`ledger file`: http://joyful.com/repos/hledger/sample.ledger
+.. _timelog: http://joyful.com/repos/hledger/sample.timelog
+.. _command line: SCREENSHOTS.html#hledger-screen-1
+.. _curses: SCREENSHOTS.html#sshot
+.. _web interface: http://demo.hledger.org
+.. _mail list: http://list.hledger.org
+.. _issue tracker: http://bugs.hledger.org
+.. _binaries: http://hledger.org/binaries/
+.. _manual: MANUAL.html
+.. _news: NEWS.html
+.. _screenshots: SCREENSHOTS.html
+.. _hledger-lib api docs: http://joyful.com/repos/hledger/hledger-lib/dist/doc/html/hledger-lib/index.html
+.. _hledger api docs: http://joyful.com/repos/hledger/dist/doc/html/hledger/index.html
+.. _hledger-lib sourcegraph report: http://joyful.com/repos/hledger/hledger-lib/SourceGraph/hledger-lib.html
+.. _hledger sourcegraph report: http://joyful.com/repos/hledger/SourceGraph/hledger.html
+.. _developer notes: http://joyful.com/darcsweb/darcsweb.cgi?r=hledger;a=plainblob;f=/NOTES
+.. _benchmark: http://hledger.org/profs/latest.bench
+.. _profile: http://hledger.org/profs/latest.prof
+.. _heap: http://hledger.org/profs/latest.ps
+.. _coverage: http://hledger.org/profs/coverage/hpc_index_fun.html
+.. _browse the repo: http://joyful.com/darcsweb/darcsweb.cgi?r=hledger
+.. _email me: mailto:simon@joyful.com
+.. _Simon Michael: http://joyful.com
+.. _co.: http://hledger.org/CONTRIBUTORS.html
+.. _hackage page: http://hackage.haskell.org/package/hledger
+.. _#ledger: irc://irc.freenode.net/#ledger
+.. _haskell: http://haskell.org
+.. _ledger: http://wiki.github.com/jwiegley/ledger
+.. _umm: http://www.korgwal.com/umm/
+.. _ledger-reports: http://dockerz.net/repos/ledger-reports
+.. _html reports: http://dockerz.net/software/hledger_report_sample/report.html
+.. _some extra tips: http://podcastle.org/2009/10/09/pc-miniature-38-accounting-for-dragons/
diff --git a/Tests.hs b/Tests.hs
deleted file mode 100644
--- a/Tests.hs
+++ /dev/null
@@ -1,1114 +0,0 @@
-{- |
-
-This module contains hledger's unit tests. These are built in to hledger,
-and can be run at any time by doing @hledger test@ (or, with a few more
-options, by doing @make unittest@ in the hledger source tree.)
-
-Other kinds of tests:
-
-hledger's functional tests are a set of shell/command-line tests defined
-by .test files in the tests\/ subdirectory. These can be run by doing
-@make functest@ in the hledger source tree.
-
-hledger's doctests are shell tests defined in literal blocks in haddock
-documentation in the source, run by doing @make doctest@ in the hledger
-source tree. They are no longer used, but here is an example:
-
-@
-$ hledger -f sample.ledger balance o
- $1 expenses:food
- $-2 income
- $-1 gifts
- $-1 salary
---------------------
- $-1
-@
-
--}
-
-module Tests
-where
-import qualified Data.Map as Map
-import Data.Time.Format
-import System.Locale (defaultTimeLocale)
-import Test.HUnit.Tools (runVerboseTests)
-import System.Exit (exitFailure, exitWith, ExitCode(ExitSuccess)) -- base 3 compatible
-import System.Time (ClockTime(TOD))
-
-import Commands.All
-import Ledger -- including testing utils in Ledger.Utils
-import Options
-import Utils
-
-
--- | Run unit tests.
-runtests :: [Opt] -> [String] -> IO ()
-runtests opts args = do
- (counts,_) <- runner ts
- if errors counts > 0 || (failures counts > 0)
- then exitFailure
- else exitWith ExitSuccess
- where
- runner | Verbose `elem` opts = runVerboseTests
- | otherwise = liftM (flip (,) 0) . runTestTT
- ts = TestList $ filter matchname $ tflatten tests -- show flat test names
- -- ts = tfilter matchname $ TestList tests -- show hierarchical test names
- matchname = matchpats args . tname
-
--- | unit tests, augmenting the ones defined in each module. Where that is
--- inconvenient due to import cycles or whatever, we define them here.
-tests :: Test
-tests = TestList [
- tests_Ledger,
- tests_Commands,
-
- "account directive" ~:
- let sameParse str1 str2 = do l1 <- journalFromString str1
- l2 <- journalFromString str2
- l1 `is` l2
- in TestList
- [
- "account directive 1" ~: sameParse
- "2008/12/07 One\n test:from $-1\n test:to $1\n"
- "!account test\n2008/12/07 One\n from $-1\n to $1\n"
-
- ,"account directive 2" ~: sameParse
- "2008/12/07 One\n test:foo:from $-1\n test:foo:to $1\n"
- "!account test\n!account foo\n2008/12/07 One\n from $-1\n to $1\n"
-
- ,"account directive 3" ~: sameParse
- "2008/12/07 One\n test:from $-1\n test:to $1\n"
- "!account test\n!account foo\n!end\n2008/12/07 One\n from $-1\n to $1\n"
-
- ,"account directive 4" ~: sameParse
- ("2008/12/07 One\n alpha $-1\n beta $1\n" ++
- "!account outer\n2008/12/07 Two\n aigh $-2\n bee $2\n" ++
- "!account inner\n2008/12/07 Three\n gamma $-3\n delta $3\n" ++
- "!end\n2008/12/07 Four\n why $-4\n zed $4\n" ++
- "!end\n2008/12/07 Five\n foo $-5\n bar $5\n"
- )
- ("2008/12/07 One\n alpha $-1\n beta $1\n" ++
- "2008/12/07 Two\n outer:aigh $-2\n outer:bee $2\n" ++
- "2008/12/07 Three\n outer:inner:gamma $-3\n outer:inner:delta $3\n" ++
- "2008/12/07 Four\n outer:why $-4\n outer:zed $4\n" ++
- "2008/12/07 Five\n foo $-5\n bar $5\n"
- )
- ]
-
- ,"accountnames" ~:
- accountnames ledger7 `is`
- ["assets","assets:cash","assets:checking","assets:saving","equity","equity:opening balances",
- "expenses","expenses:food","expenses:food:dining","expenses:phone","expenses:vacation",
- "liabilities","liabilities:credit cards","liabilities:credit cards:discover"]
-
- ,"accountNameTreeFrom" ~: do
- accountNameTreeFrom ["a"] `is` Node "top" [Node "a" []]
- accountNameTreeFrom ["a","b"] `is` Node "top" [Node "a" [], Node "b" []]
- accountNameTreeFrom ["a","a:b"] `is` Node "top" [Node "a" [Node "a:b" []]]
- accountNameTreeFrom ["a:b:c"] `is` Node "top" [Node "a" [Node "a:b" [Node "a:b:c" []]]]
-
- ,"balance report tests" ~:
- let (opts,args) `gives` es = do
- l <- sampleledgerwithopts opts args
- t <- getCurrentLocalTime
- showBalanceReport opts (optsToFilterSpec opts args t) l `is` unlines es
- in TestList
- [
-
- "balance report with no args" ~:
- ([], []) `gives`
- [" $-1 assets"
- ," $1 bank:saving"
- ," $-2 cash"
- ," $2 expenses"
- ," $1 food"
- ," $1 supplies"
- ," $-2 income"
- ," $-1 gifts"
- ," $-1 salary"
- ," $1 liabilities:debts"
- ]
-
- ,"balance report can be limited with --depth" ~:
- ([Depth "1"], []) `gives`
- [" $-1 assets"
- ," $2 expenses"
- ," $-2 income"
- ," $1 liabilities"
- ]
-
- ,"balance report with account pattern o" ~:
- ([SubTotal], ["o"]) `gives`
- [" $1 expenses:food"
- ," $-2 income"
- ," $-1 gifts"
- ," $-1 salary"
- ,"--------------------"
- ," $-1"
- ]
-
- ,"balance report with account pattern o and --depth 1" ~:
- ([Depth "1"], ["o"]) `gives`
- [" $1 expenses"
- ," $-2 income"
- ,"--------------------"
- ," $-1"
- ]
-
- ,"balance report with account pattern a" ~:
- ([], ["a"]) `gives`
- [" $-1 assets"
- ," $1 bank:saving"
- ," $-2 cash"
- ," $-1 income:salary"
- ," $1 liabilities:debts"
- ,"--------------------"
- ," $-1"
- ]
-
- ,"balance report with account pattern e" ~:
- ([], ["e"]) `gives`
- [" $-1 assets"
- ," $1 bank:saving"
- ," $-2 cash"
- ," $2 expenses"
- ," $1 food"
- ," $1 supplies"
- ," $-2 income"
- ," $-1 gifts"
- ," $-1 salary"
- ," $1 liabilities:debts"
- ]
-
- ,"balance report with unmatched parent of two matched subaccounts" ~:
- ([], ["cash","saving"]) `gives`
- [" $-1 assets"
- ," $1 bank:saving"
- ," $-2 cash"
- ,"--------------------"
- ," $-1"
- ]
-
- ,"balance report with multi-part account name" ~:
- ([], ["expenses:food"]) `gives`
- [" $1 expenses:food"
- ,"--------------------"
- ," $1"
- ]
-
- ,"balance report with negative account pattern" ~:
- ([], ["not:assets"]) `gives`
- [" $2 expenses"
- ," $1 food"
- ," $1 supplies"
- ," $-2 income"
- ," $-1 gifts"
- ," $-1 salary"
- ," $1 liabilities:debts"
- ,"--------------------"
- ," $1"
- ]
-
- ,"balance report negative account pattern always matches full name" ~:
- ([], ["not:e"]) `gives` []
-
- ,"balance report negative patterns affect totals" ~:
- ([], ["expenses","not:food"]) `gives`
- [" $1 expenses:supplies"
- ,"--------------------"
- ," $1"
- ]
-
- ,"balance report with -E shows zero-balance accounts" ~:
- ([SubTotal,Empty], ["assets"]) `gives`
- [" $-1 assets"
- ," $1 bank"
- ," $0 checking"
- ," $1 saving"
- ," $-2 cash"
- ,"--------------------"
- ," $-1"
- ]
-
- ,"balance report with cost basis" ~: do
- j <- journalFromString $ unlines
- [""
- ,"2008/1/1 test "
- ," a:b 10h @ $50"
- ," c:d "
- ,""
- ]
- let j' = canonicaliseAmounts True j -- enable cost basis adjustment
- showBalanceReport [] nullfilterspec nullledger{journal=j'} `is`
- unlines
- [" $500 a:b"
- ," $-500 c:d"
- ]
-
- ,"balance report elides zero-balance root account(s)" ~: do
- l <- ledgerFromStringWithOpts []
- (unlines
- ["2008/1/1 one"
- ," test:a 1"
- ," test:b"
- ])
- showBalanceReport [] nullfilterspec l `is`
- unlines
- [" 1 test:a"
- ," -1 test:b"
- ]
-
- ]
-
- ,"balanceTransaction" ~: do
- assertBool "detect unbalanced entry, sign error"
- (isLeft $ balanceTransaction
- (Transaction (parsedate "2007/01/28") Nothing False "" "test" ""
- [Posting False "a" (Mixed [dollars 1]) "" RegularPosting Nothing,
- Posting False "b" (Mixed [dollars 1]) "" RegularPosting Nothing
- ] ""))
- assertBool "detect unbalanced entry, multiple missing amounts"
- (isLeft $ balanceTransaction
- (Transaction (parsedate "2007/01/28") Nothing False "" "test" ""
- [Posting False "a" missingamt "" RegularPosting Nothing,
- Posting False "b" missingamt "" RegularPosting Nothing
- ] ""))
- let e = balanceTransaction (Transaction (parsedate "2007/01/28") Nothing False "" "test" ""
- [Posting False "a" (Mixed [dollars 1]) "" RegularPosting Nothing,
- Posting False "b" missingamt "" RegularPosting Nothing
- ] "")
- assertBool "one missing amount should be ok" (isRight e)
- assertEqual "balancing amount is added"
- (Mixed [dollars (-1)])
- (case e of
- Right e' -> (pamount $ last $ tpostings e')
- Left _ -> error "should not happen")
-
- ,"cacheLedger" ~:
- length (Map.keys $ accountmap $ cacheLedger journal7) `is` 15
-
- ,"canonicaliseAmounts" ~:
- "use the greatest precision" ~:
- journalPrecisions (canonicaliseAmounts False $ journalWithAmounts ["1","2.00"]) `is` [2,2]
-
- ,"commodities" ~:
- commodities ledger7 `is` [Commodity {symbol="$", side=L, spaced=False, comma=False, precision=2}]
-
- ,"dateSpanFromOpts" ~: do
- let todaysdate = parsedate "2008/11/26"
- let gives = is . show . dateSpanFromOpts todaysdate
- [] `gives` "DateSpan Nothing Nothing"
- [Begin "2008", End "2009"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"
- [Period "in 2008"] `gives` "DateSpan (Just 2008-01-01) (Just 2009-01-01)"
- [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
- tz <- getCurrentTimeZone
- let now = utcToLocalTime tz now'
- nowstr = showtime now
- yesterday = prevday today
- clockin = TimeLogEntry In
- mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S"
- showtime = formatTime defaultTimeLocale "%H:%M"
- assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ entriesFromTimeLogEntries now es)
-
- assertEntriesGiveStrings "started yesterday, split session at midnight"
- [clockin (mktime yesterday "23:00:00") ""]
- ["23:00-23:59","00:00-"++nowstr]
- assertEntriesGiveStrings "split multi-day sessions at each midnight"
- [clockin (mktime (addDays (-2) today) "23:00:00") ""]
- ["23:00-23:59","00:00-23:59","00:00-"++nowstr]
- assertEntriesGiveStrings "auto-clock-out if needed"
- [clockin (mktime today "00:00:00") ""]
- ["00:00-"++nowstr]
- let future = utcToLocalTime tz $ addUTCTime 100 now'
- futurestr = showtime future
- assertEntriesGiveStrings "use the clockin time for auto-clockout if it's in the future"
- [clockin future ""]
- [printf "%s-%s" futurestr futurestr]
-
- ,"expandAccountNames" ~:
- expandAccountNames ["assets:cash","assets:checking","expenses:vacation"] `is`
- ["assets","assets:cash","assets:checking","expenses","expenses:vacation"]
-
- ,"intervalFromOpts" ~: do
- let gives = is . intervalFromOpts
- [] `gives` NoInterval
- [WeeklyOpt] `gives` Weekly
- [MonthlyOpt] `gives` Monthly
- [QuarterlyOpt] `gives` Quarterly
- [YearlyOpt] `gives` Yearly
- [Period "weekly"] `gives` Weekly
- [Period "monthly"] `gives` Monthly
- [Period "quarterly"] `gives` Quarterly
- [WeeklyOpt, Period "yearly"] `gives` Yearly
-
- ,"isAccountNamePrefixOf" ~: do
- "assets" `isAccountNamePrefixOf` "assets" `is` False
- "assets" `isAccountNamePrefixOf` "assets:bank" `is` True
- "assets" `isAccountNamePrefixOf` "assets:bank:checking" `is` True
- "my assets" `isAccountNamePrefixOf` "assets:bank" `is` False
-
- ,"isTransactionBalanced" ~: do
- let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""
- [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)
- ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t)
- ] ""
- assertBool "detect balanced" (isTransactionBalanced t)
- let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""
- [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)
- ,Posting False "c" (Mixed [dollars (-1.01)]) "" RegularPosting (Just t)
- ] ""
- assertBool "detect unbalanced" (not $ isTransactionBalanced t)
- let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""
- [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)
- ] ""
- assertBool "detect unbalanced, one posting" (not $ isTransactionBalanced t)
- let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""
- [Posting False "b" (Mixed [dollars 0]) "" RegularPosting (Just t)
- ] ""
- assertBool "one zero posting is considered balanced for now" (isTransactionBalanced t)
- let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""
- [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)
- ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t)
- ,Posting False "d" (Mixed [dollars 100]) "" VirtualPosting (Just t)
- ] ""
- assertBool "virtual postings don't need to balance" (isTransactionBalanced t)
- let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""
- [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)
- ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t)
- ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting (Just t)
- ] ""
- assertBool "balanced virtual postings need to balance among themselves" (not $ isTransactionBalanced t)
- let t = Transaction (parsedate "2009/01/01") Nothing False "" "a" ""
- [Posting False "b" (Mixed [dollars 1.00]) "" RegularPosting (Just t)
- ,Posting False "c" (Mixed [dollars (-1.00)]) "" RegularPosting (Just t)
- ,Posting False "d" (Mixed [dollars 100]) "" BalancedVirtualPosting (Just t)
- ,Posting False "e" (Mixed [dollars (-100)]) "" BalancedVirtualPosting (Just t)
- ] ""
- assertBool "balanced virtual postings need to balance among themselves (2)" (isTransactionBalanced t)
-
- ,"isSubAccountNameOf" ~: do
- "assets" `isSubAccountNameOf` "assets" `is` False
- "assets:bank" `isSubAccountNameOf` "assets" `is` True
- "assets:bank:checking" `isSubAccountNameOf` "assets" `is` False
- "assets:bank" `isSubAccountNameOf` "my assets" `is` False
-
- ,"default year" ~: do
- rl <- journalFromString defaultyear_ledger_str
- tdate (head $ jtxns rl) `is` fromGregorian 2009 1 1
- return ()
-
- ,"ledgerFile" ~: do
- assertBool "ledgerFile should parse an empty file" (isRight $ parseWithCtx emptyCtx ledgerFile "")
- r <- journalFromString "" -- don't know how to get it from ledgerFile
- assertBool "ledgerFile parsing an empty file should give an empty ledger" $ null $ jtxns r
-
- ,"normaliseMixedAmount" ~: do
- normaliseMixedAmount (Mixed []) ~?= Mixed [nullamt]
-
- ,"parsedate" ~: do
- parsedate "2008/02/03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1
- parsedate "2008-02-03" `is` parsetimewith "%Y/%m/%d" "2008/02/03" date1
-
- ,"period expressions" ~: do
- let todaysdate = parsedate "2008/11/26"
- let str `gives` result = show (parsewith (periodexpr todaysdate) str) `is` ("Right " ++ result)
- "from aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
- "aug to oct" `gives` "(NoInterval,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
- "every day from aug to oct" `gives` "(Daily,DateSpan (Just 2008-08-01) (Just 2008-10-01))"
- "daily from aug" `gives` "(Daily,DateSpan (Just 2008-08-01) Nothing)"
- "every week to 2009" `gives` "(Weekly,DateSpan Nothing (Just 2009-01-01))"
-
- ,"print report tests" ~: TestList
- [
-
- "print expenses" ~:
- do
- let args = ["expenses"]
- l <- sampleledgerwithopts [] args
- t <- getCurrentLocalTime
- showTransactions (optsToFilterSpec [] args t) l `is` unlines
- ["2008/06/03 * eat & shop"
- ," expenses:food $1"
- ," expenses:supplies $1"
- ," assets:cash $-2"
- ,""
- ]
-
- , "print report with depth arg" ~:
- do
- l <- sampleledger
- t <- getCurrentLocalTime
- showTransactions (optsToFilterSpec [Depth "2"] [] t) l `is` unlines
- ["2008/01/01 income"
- ," income:salary $-1"
- ,""
- ,"2008/06/01 gift"
- ," income:gifts $-1"
- ,""
- ,"2008/06/03 * eat & shop"
- ," expenses:food $1"
- ," expenses:supplies $1"
- ," assets:cash $-2"
- ,""
- ,"2008/12/31 * pay off"
- ," liabilities:debts $1"
- ,""
- ]
-
- ]
-
- ,"punctuatethousands 1" ~: punctuatethousands "" `is` ""
-
- ,"punctuatethousands 2" ~: punctuatethousands "1234567.8901" `is` "1,234,567.8901"
-
- ,"punctuatethousands 3" ~: punctuatethousands "-100" `is` "-100"
-
- ,"register report tests" ~:
- let registerdates = filter (not . null) . map (strip . take 10) . lines
- in
- TestList
- [
-
- "register report with no args" ~:
- do
- l <- sampleledger
- showRegisterReport [] (optsToFilterSpec [] [] t1) l `is` unlines
- ["2008/01/01 income assets:bank:checking $1 $1"
- ," income:salary $-1 0"
- ,"2008/06/01 gift assets:bank:checking $1 $1"
- ," income:gifts $-1 0"
- ,"2008/06/02 save assets:bank:saving $1 $1"
- ," assets:bank:checking $-1 0"
- ,"2008/06/03 eat & shop expenses:food $1 $1"
- ," expenses:supplies $1 $2"
- ," assets:cash $-2 0"
- ,"2008/12/31 pay off liabilities:debts $1 $1"
- ," assets:bank:checking $-1 0"
- ]
-
- ,"register report with cleared option" ~:
- do
- let opts = [Cleared]
- l <- ledgerFromStringWithOpts opts sample_ledger_str
- showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
- ["2008/06/03 eat & shop expenses:food $1 $1"
- ," expenses:supplies $1 $2"
- ," assets:cash $-2 0"
- ,"2008/12/31 pay off liabilities:debts $1 $1"
- ," assets:bank:checking $-1 0"
- ]
-
- ,"register report with uncleared option" ~:
- do
- let opts = [UnCleared]
- l <- ledgerFromStringWithOpts opts sample_ledger_str
- showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
- ["2008/01/01 income assets:bank:checking $1 $1"
- ," income:salary $-1 0"
- ,"2008/06/01 gift assets:bank:checking $1 $1"
- ," income:gifts $-1 0"
- ,"2008/06/02 save assets:bank:saving $1 $1"
- ," assets:bank:checking $-1 0"
- ]
-
- ,"register report sorts by date" ~:
- do
- l <- ledgerFromStringWithOpts [] $ unlines
- ["2008/02/02 a"
- ," b 1"
- ," c"
- ,""
- ,"2008/01/01 d"
- ," e 1"
- ," f"
- ]
- registerdates (showRegisterReport [] (optsToFilterSpec [] [] t1) l) `is` ["2008/01/01","2008/02/02"]
-
- ,"register report with account pattern" ~:
- do
- l <- sampleledger
- showRegisterReport [] (optsToFilterSpec [] ["cash"] t1) l `is` unlines
- ["2008/06/03 eat & shop assets:cash $-2 $-2"
- ]
-
- ,"register report with account pattern, case insensitive" ~:
- do
- l <- sampleledger
- showRegisterReport [] (optsToFilterSpec [] ["cAsH"] t1) l `is` unlines
- ["2008/06/03 eat & shop assets:cash $-2 $-2"
- ]
-
- ,"register report with display expression" ~:
- do
- l <- sampleledger
- let gives displayexpr =
- (registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is`)
- where opts = [Display displayexpr]
- "d<[2008/6/2]" `gives` ["2008/01/01","2008/06/01"]
- "d<=[2008/6/2]" `gives` ["2008/01/01","2008/06/01","2008/06/02"]
- "d=[2008/6/2]" `gives` ["2008/06/02"]
- "d>=[2008/6/2]" `gives` ["2008/06/02","2008/06/03","2008/12/31"]
- "d>[2008/6/2]" `gives` ["2008/06/03","2008/12/31"]
-
- ,"register report with period expression" ~:
- do
- l <- sampleledger
- let periodexpr `gives` dates = do
- l' <- sampleledgerwithopts opts []
- registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l') `is` dates
- where opts = [Period periodexpr]
- "" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]
- "2008" `gives` ["2008/01/01","2008/06/01","2008/06/02","2008/06/03","2008/12/31"]
- "2007" `gives` []
- "june" `gives` ["2008/06/01","2008/06/02","2008/06/03"]
- "monthly" `gives` ["2008/01/01","2008/06/01","2008/12/01"]
- "quarterly" `gives` ["2008/01/01","2008/04/01","2008/10/01"]
- let opts = [Period "yearly"]
- showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
- ["2008/01/01 - 2008/12/31 assets:bank:saving $1 $1"
- ," assets:cash $-2 $-1"
- ," expenses:food $1 0"
- ," expenses:supplies $1 $1"
- ," income:gifts $-1 0"
- ," income:salary $-1 $-1"
- ," liabilities:debts $1 0"
- ]
- let opts = [Period "quarterly"]
- registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/10/01"]
- let opts = [Period "quarterly",Empty]
- registerdates (showRegisterReport opts (optsToFilterSpec opts [] t1) l) `is` ["2008/01/01","2008/04/01","2008/07/01","2008/10/01"]
-
- ]
-
- , "register report with depth arg" ~:
- do
- l <- sampleledger
- let opts = [Depth "2"]
- showRegisterReport opts (optsToFilterSpec opts [] t1) l `is` unlines
- ["2008/01/01 income income:salary $-1 $-1"
- ,"2008/06/01 gift income:gifts $-1 $-2"
- ,"2008/06/03 eat & shop expenses:food $1 $-1"
- ," expenses:supplies $1 0"
- ," assets:cash $-2 $-2"
- ,"2008/12/31 pay off liabilities:debts $1 $-1"
- ]
-
- ,"show dollars" ~: show (dollars 1) ~?= "$1.00"
-
- ,"show hours" ~: show (hours 1) ~?= "1.0h"
-
- ,"unicode in balance layout" ~: do
- l <- ledgerFromStringWithOpts []
- "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
- showBalanceReport [] (optsToFilterSpec [] [] t1) l `is` unlines
- [" -100 актив:наличные"
- ," 100 расходы:покупки"]
-
- ,"unicode in register layout" ~: do
- l <- ledgerFromStringWithOpts []
- "2009/01/01 * медвежья шкура\n расходы:покупки 100\n актив:наличные\n"
- showRegisterReport [] (optsToFilterSpec [] [] t1) l `is` unlines
- ["2009/01/01 медвежья шкура расходы:покупки 100 100"
- ," актив:наличные -100 0"]
-
- ,"smart dates" ~: do
- let gives = is . fixSmartDateStr (parsedate "2008/11/26")
- "1999-12-02" `gives` "1999/12/02"
- "1999.12.02" `gives` "1999/12/02"
- "1999/3/2" `gives` "1999/03/02"
- "19990302" `gives` "1999/03/02"
- "2008/2" `gives` "2008/02/01"
- "20/2" `gives` "0020/02/01"
- "1000" `gives` "1000/01/01"
- "4/2" `gives` "2008/04/02"
- "2" `gives` "2008/11/02"
- "January" `gives` "2008/01/01"
- "feb" `gives` "2008/02/01"
- "today" `gives` "2008/11/26"
- "yesterday" `gives` "2008/11/25"
- "tomorrow" `gives` "2008/11/27"
- "this day" `gives` "2008/11/26"
- "last day" `gives` "2008/11/25"
- "next day" `gives` "2008/11/27"
- "this week" `gives` "2008/11/24" -- last monday
- "last week" `gives` "2008/11/17" -- previous monday
- "next week" `gives` "2008/12/01" -- next monday
- "this month" `gives` "2008/11/01"
- "last month" `gives` "2008/10/01"
- "next month" `gives` "2008/12/01"
- "this quarter" `gives` "2008/10/01"
- "last quarter" `gives` "2008/07/01"
- "next quarter" `gives` "2009/01/01"
- "this year" `gives` "2008/01/01"
- "last year" `gives` "2007/01/01"
- "next year" `gives` "2009/01/01"
--- "last wed" `gives` "2008/11/19"
--- "next friday" `gives` "2008/11/28"
--- "next january" `gives` "2009/01/01"
-
- ,"subAccounts" ~: do
- l <- liftM cacheLedger' sampleledger
- let a = ledgerAccount l "assets"
- map aname (ledgerSubAccounts l a) `is` ["assets:bank","assets:cash"]
-
- -- ,"summarisePostingsInDateSpan" ~: do
- -- let gives (b,e,depth,showempty,ps) =
- -- (summarisePostingsInDateSpan (mkdatespan b e) depth showempty ps `is`)
- -- let ps =
- -- [
- -- nullposting{lpdescription="desc",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]}
- -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 2]}
- -- ,nullposting{lpdescription="desc",lpaccount="expenses:food", lpamount=Mixed [dollars 4]}
- -- ,nullposting{lpdescription="desc",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 8]}
- -- ]
- -- ("2008/01/01","2009/01/01",0,9999,False,[]) `gives`
- -- []
- -- ("2008/01/01","2009/01/01",0,9999,True,[]) `gives`
- -- [
- -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31"}
- -- ]
- -- ("2008/01/01","2009/01/01",0,9999,False,ts) `gives`
- -- [
- -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food", lpamount=Mixed [dollars 4]}
- -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:dining", lpamount=Mixed [dollars 10]}
- -- ,nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food:groceries",lpamount=Mixed [dollars 1]}
- -- ]
- -- ("2008/01/01","2009/01/01",0,2,False,ts) `gives`
- -- [
- -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses:food",lpamount=Mixed [dollars 15]}
- -- ]
- -- ("2008/01/01","2009/01/01",0,1,False,ts) `gives`
- -- [
- -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="expenses",lpamount=Mixed [dollars 15]}
- -- ]
- -- ("2008/01/01","2009/01/01",0,0,False,ts) `gives`
- -- [
- -- nullposting{lpdate=parsedate "2008/01/01",lpdescription="- 2008/12/31",lpaccount="",lpamount=Mixed [dollars 15]}
- -- ]
-
- ]
-
-
--- fixtures/test data
-
-date1 = parsedate "2008/11/26"
-t1 = LocalTime date1 midday
-
-sampleledger = ledgerFromStringWithOpts [] sample_ledger_str
-sampleledgerwithopts opts _ = ledgerFromStringWithOpts opts sample_ledger_str
-
-sample_ledger_str = unlines
- ["; A sample ledger file."
- ,";"
- ,"; Sets up this account tree:"
- ,"; assets"
- ,"; bank"
- ,"; checking"
- ,"; saving"
- ,"; cash"
- ,"; expenses"
- ,"; food"
- ,"; supplies"
- ,"; income"
- ,"; gifts"
- ,"; salary"
- ,"; liabilities"
- ,"; debts"
- ,""
- ,"2008/01/01 income"
- ," assets:bank:checking $1"
- ," income:salary"
- ,""
- ,"2008/06/01 gift"
- ," assets:bank:checking $1"
- ," income:gifts"
- ,""
- ,"2008/06/02 save"
- ," assets:bank:saving $1"
- ," assets:bank:checking"
- ,""
- ,"2008/06/03 * eat & shop"
- ," expenses:food $1"
- ," expenses:supplies $1"
- ," assets:cash"
- ,""
- ,"2008/12/31 * pay off"
- ," liabilities:debts $1"
- ," assets:bank:checking"
- ,""
- ,""
- ,";final comment"
- ]
-
-defaultyear_ledger_str = unlines
- ["Y2009"
- ,""
- ,"01/01 A"
- ," a $1"
- ," b"
- ]
-
-write_sample_ledger = writeFile "sample.ledger" sample_ledger_str
-
-entry2_str = unlines
- ["2007/01/27 * joes diner"
- ," expenses:food:dining $10.00"
- ," expenses:gifts $10.00"
- ," assets:checking $-20.00"
- ,""
- ]
-
-entry3_str = unlines
- ["2007/01/01 * opening balance"
- ," assets:cash $4.82"
- ," equity:opening balances"
- ,""
- ,"2007/01/01 * opening balance"
- ," assets:cash $4.82"
- ," equity:opening balances"
- ,""
- ,"2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
- ," assets:checking"
- ,""
- ]
-
-periodic_entry1_str = unlines
- ["~ monthly from 2007/2/2"
- ," assets:saving $200.00"
- ," assets:checking"
- ,""
- ]
-
-periodic_entry2_str = unlines
- ["~ monthly from 2007/2/2"
- ," assets:saving $200.00 ;auto savings"
- ," assets:checking"
- ,""
- ]
-
-periodic_entry3_str = unlines
- ["~ monthly from 2007/01/01"
- ," assets:cash $4.82"
- ," equity:opening balances"
- ,""
- ,"~ monthly from 2007/01/01"
- ," assets:cash $4.82"
- ," equity:opening balances"
- ,""
- ]
-
-ledger1_str = unlines
- [""
- ,"2007/01/27 * joes diner"
- ," expenses:food:dining $10.00"
- ," expenses:gifts $10.00"
- ," assets:checking $-20.00"
- ,""
- ,""
- ,"2007/01/28 coopportunity"
- ," expenses:food:groceries $47.18"
- ," assets:checking $-47.18"
- ,""
- ,""
- ]
-
-ledger2_str = unlines
- [";comment"
- ,"2007/01/27 * joes diner"
- ," expenses:food:dining $10.00"
- ," assets:checking $-47.18"
- ,""
- ]
-
-ledger3_str = unlines
- ["2007/01/27 * joes diner"
- ," expenses:food:dining $10.00"
- ,";intra-entry comment"
- ," assets:checking $-47.18"
- ,""
- ]
-
-ledger4_str = unlines
- ["!include \"somefile\""
- ,"2007/01/27 * joes diner"
- ," expenses:food:dining $10.00"
- ," assets:checking $-47.18"
- ,""
- ]
-
-ledger5_str = ""
-
-ledger6_str = unlines
- ["~ monthly from 2007/1/21"
- ," expenses:entertainment $16.23 ;netflix"
- ," assets:checking"
- ,""
- ,"; 2007/01/01 * opening balance"
- ,"; assets:saving $200.04"
- ,"; equity:opening balances "
- ,""
- ]
-
-ledger7_str = unlines
- ["2007/01/01 * opening balance"
- ," assets:cash $4.82"
- ," equity:opening balances "
- ,""
- ,"2007/01/01 * opening balance"
- ," income:interest $-4.82"
- ," equity:opening balances "
- ,""
- ,"2007/01/02 * ayres suites"
- ," expenses:vacation $179.92"
- ," assets:checking "
- ,""
- ,"2007/01/02 * auto transfer to savings"
- ," assets:saving $200.00"
- ," assets:checking "
- ,""
- ,"2007/01/03 * poquito mas"
- ," expenses:food:dining $4.82"
- ," assets:cash "
- ,""
- ,"2007/01/03 * verizon"
- ," expenses:phone $95.11"
- ," assets:checking "
- ,""
- ,"2007/01/03 * discover"
- ," liabilities:credit cards:discover $80.00"
- ," assets:checking "
- ,""
- ,"2007/01/04 * blue cross"
- ," expenses:health:insurance $90.00"
- ," assets:checking "
- ,""
- ,"2007/01/05 * village market liquor"
- ," expenses:food:dining $6.48"
- ," assets:checking "
- ,""
- ]
-
-journal7 = Journal
- []
- []
- [
- txnTieKnot $ Transaction {
- tdate=parsedate "2007/01/01",
- teffectivedate=Nothing,
- tstatus=False,
- tcode="*",
- tdescription="opening balance",
- tcomment="",
- tpostings=[
- Posting {
- pstatus=False,
- paccount="assets:cash",
- pamount=(Mixed [dollars 4.82]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- },
- Posting {
- pstatus=False,
- paccount="equity:opening balances",
- pamount=(Mixed [dollars (-4.82)]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- }
- ],
- tpreceding_comment_lines=""
- }
- ,
- txnTieKnot $ Transaction {
- tdate=parsedate "2007/02/01",
- teffectivedate=Nothing,
- tstatus=False,
- tcode="*",
- tdescription="ayres suites",
- tcomment="",
- tpostings=[
- Posting {
- pstatus=False,
- paccount="expenses:vacation",
- pamount=(Mixed [dollars 179.92]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- },
- Posting {
- pstatus=False,
- paccount="assets:checking",
- pamount=(Mixed [dollars (-179.92)]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- }
- ],
- tpreceding_comment_lines=""
- }
- ,
- txnTieKnot $ Transaction {
- tdate=parsedate "2007/01/02",
- teffectivedate=Nothing,
- tstatus=False,
- tcode="*",
- tdescription="auto transfer to savings",
- tcomment="",
- tpostings=[
- Posting {
- pstatus=False,
- paccount="assets:saving",
- pamount=(Mixed [dollars 200]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- },
- Posting {
- pstatus=False,
- paccount="assets:checking",
- pamount=(Mixed [dollars (-200)]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- }
- ],
- tpreceding_comment_lines=""
- }
- ,
- txnTieKnot $ Transaction {
- tdate=parsedate "2007/01/03",
- teffectivedate=Nothing,
- tstatus=False,
- tcode="*",
- tdescription="poquito mas",
- tcomment="",
- tpostings=[
- Posting {
- pstatus=False,
- paccount="expenses:food:dining",
- pamount=(Mixed [dollars 4.82]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- },
- Posting {
- pstatus=False,
- paccount="assets:cash",
- pamount=(Mixed [dollars (-4.82)]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- }
- ],
- tpreceding_comment_lines=""
- }
- ,
- txnTieKnot $ Transaction {
- tdate=parsedate "2007/01/03",
- teffectivedate=Nothing,
- tstatus=False,
- tcode="*",
- tdescription="verizon",
- tcomment="",
- tpostings=[
- Posting {
- pstatus=False,
- paccount="expenses:phone",
- pamount=(Mixed [dollars 95.11]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- },
- Posting {
- pstatus=False,
- paccount="assets:checking",
- pamount=(Mixed [dollars (-95.11)]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- }
- ],
- tpreceding_comment_lines=""
- }
- ,
- txnTieKnot $ Transaction {
- tdate=parsedate "2007/01/03",
- teffectivedate=Nothing,
- tstatus=False,
- tcode="*",
- tdescription="discover",
- tcomment="",
- tpostings=[
- Posting {
- pstatus=False,
- paccount="liabilities:credit cards:discover",
- pamount=(Mixed [dollars 80]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- },
- Posting {
- pstatus=False,
- paccount="assets:checking",
- pamount=(Mixed [dollars (-80)]),
- pcomment="",
- ptype=RegularPosting,
- ptransaction=Nothing
- }
- ],
- tpreceding_comment_lines=""
- }
- ]
- []
- []
- ""
- ""
- (TOD 0 0)
- ""
-
-ledger7 = cacheLedger journal7
-
-ledger8_str = unlines
- ["2008/1/1 test "
- ," a:b 10h @ $40"
- ," c:d "
- ,""
- ]
-
-timelogentry1_str = "i 2007/03/11 16:19:00 hledger\n"
-timelogentry1 = TimeLogEntry In (parsedatetime "2007/03/11 16:19:00") "hledger"
-
-timelogentry2_str = "o 2007/03/11 16:30:00\n"
-timelogentry2 = TimeLogEntry Out (parsedatetime "2007/03/11 16:30:00") ""
-
-a1 = Mixed [(hours 1){price=Just $ Mixed [Amount (comm "$") 10 Nothing]}]
-a2 = Mixed [(hours 2){price=Just $ Mixed [Amount (comm "EUR") 10 Nothing]}]
-a3 = Mixed $ amounts a1 ++ amounts a2
-
-journalWithAmounts :: [String] -> Journal
-journalWithAmounts as =
- Journal
- []
- []
- [t | a <- as, let t = nulltransaction{tdescription=a,tpostings=[nullposting{pamount=parse a,ptransaction=Just t}]}]
- []
- []
- ""
- ""
- (TOD 0 0)
- ""
- where parse = fromparse . parseWithCtx emptyCtx postingamount . (" "++)
-
diff --git a/Utils.hs b/Utils.hs
deleted file mode 100644
--- a/Utils.hs
+++ /dev/null
@@ -1,94 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-|
-
-Utilities for top-level modules and ghci. See also "Ledger.IO" and
-"Ledger.Utils".
-
--}
-
-module Utils
-where
-import Control.Monad.Error
-import Ledger
-import Options (Opt(..),ledgerFilePathFromOpts) -- ,optsToFilterSpec)
-import System.Directory (doesFileExist)
-import System.IO (stderr)
-#if __GLASGOW_HASKELL__ <= 610
-import System.IO.UTF8 (hPutStrLn)
-#else
-import System.IO (hPutStrLn)
-#endif
-import System.Exit
-import System.Process (readProcessWithExitCode)
-import System.Info (os)
-import System.Time (ClockTime,getClockTime)
-
-
--- | Parse the user's specified ledger file and run a hledger command on
--- it, or report a parse error. This function makes the whole thing go.
--- Warning, this provides only an uncached Ledger (no accountnametree or
--- accountmap), so cmd must cacheLedger'/crunchJournal if needed.
-withLedgerDo :: [Opt] -> [String] -> String -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO ()
-withLedgerDo opts args cmdname cmd = do
- -- We kludgily read the file before parsing to grab the full text, unless
- -- it's stdin, or it doesn't exist and we are adding. We read it strictly
- -- to let the add command work.
- f <- ledgerFilePathFromOpts opts
- let f' = if f == "-" then "/dev/null" else f
- fileexists <- doesFileExist f
- let creating = not fileexists && cmdname == "add"
- t <- getCurrentLocalTime
- tc <- getClockTime
- txt <- if creating then return "" else strictReadFile f'
- let runcmd = cmd opts args . mkLedger opts f tc txt
- if creating
- then runcmd nulljournal
- else (runErrorT . parseLedgerFile t) f >>= either parseerror runcmd
- where parseerror e = hPutStrLn stderr e >> exitWith (ExitFailure 1)
-
-mkLedger :: [Opt] -> FilePath -> ClockTime -> String -> Journal -> Ledger
-mkLedger opts f tc txt j = nullledger{journal=j'}
- where j' = (canonicaliseAmounts costbasis j){filepath=f,filereadtime=tc,jtext=txt}
- costbasis=CostBasis `elem` opts
-
--- | Get a Ledger from the given string and options, or raise an error.
-ledgerFromStringWithOpts :: [Opt] -> String -> IO Ledger
-ledgerFromStringWithOpts opts s = do
- tc <- getClockTime
- j <- journalFromString s
- return $ mkLedger opts "" tc s j
-
--- -- | Read a Ledger from the given file, or give an error.
--- readLedgerWithOpts :: [Opt] -> [String] -> FilePath -> IO Ledger
--- readLedgerWithOpts opts args f = do
--- t <- getCurrentLocalTime
--- readLedger f
-
--- -- | Convert a Journal to a canonicalised, cached and filtered Ledger
--- -- based on the command-line options/arguments and a reference time.
--- filterAndCacheLedgerWithOpts :: [Opt] -> [String] -> LocalTime -> String -> Journal -> Ledger
--- filterAndCacheLedgerWithOpts opts args = filterAndCacheLedger . optsToFilterSpec opts args
-
--- | Attempt to open a web browser on the given url, all platforms.
-openBrowserOn :: String -> IO ExitCode
-openBrowserOn u = trybrowsers browsers u
- where
- trybrowsers (b:bs) u = do
- (e,_,_) <- readProcessWithExitCode 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"]
- | otherwise = ["sensible-browser","gnome-www-browser","firefox"]
- -- jeffz: write a ffi binding for it using the Win32 package as a basis
- -- start by adding System/Win32/Shell.hsc and follow the style of any
- -- other module in that directory for types, headers, error handling and
- -- what not.
- -- ::ShellExecute(NULL, "open", "www.somepage.com", NULL, NULL, SW_SHOWNORMAL);
- -- ::ShellExecute(NULL, "open", "firefox.exe", "www.somepage.com" NULL, SW_SHOWNORMAL);
-
diff --git a/Version.hs b/Version.hs
deleted file mode 100644
--- a/Version.hs
+++ /dev/null
@@ -1,75 +0,0 @@
-{-# LANGUAGE CPP #-}
-{-
-Version-related utilities. See the Makefile for details of our version
-numbering policy.
--}
-
-module Version
-where
-import System.Info (os, arch)
-import Ledger.Utils
-import Options (progname)
-
--- version and PATCHLEVEL are set by the makefile
-version = "0.8.0"
-
-#ifdef PATCHLEVEL
-patchlevel = "." ++ show PATCHLEVEL -- must be numeric !
-#else
-patchlevel = ""
-#endif
-
-buildversion = version ++ patchlevel :: String
-
-binaryfilename = prettify $ splitAtElement '.' buildversion :: String
- where
- prettify (major:minor:bugfix:patches:[]) =
- printf "hledger-%s.%s%s%s-%s-%s%s" major minor bugfix' patches' os' arch suffix
- where
- bugfix'
- | bugfix `elem` ["0"{-,"98","99"-}] = ""
- | otherwise = '.' : bugfix
- patches'
- | patches/="0" = '+' : patches
- | otherwise = ""
- (os',suffix)
- | os == "darwin" = ("mac","")
- | os == "mingw32" = ("windows",".exe")
- | otherwise = (os,"")
- prettify (major:minor:bugfix:[]) = prettify [major,minor,bugfix,"0"]
- prettify (major:minor:[]) = prettify [major,minor,"0","0"]
- prettify (major:[]) = prettify [major,"0","0","0"]
- prettify [] = 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" major minor bugfix' patches'
- where
- bugfix'
- | bugfix `elem` ["0"{-,"98","99"-}] = ""
- | otherwise = '.' : bugfix
- patches'
- | patches/="0" = "+"++patches
- | otherwise = ""
- prettify s = intercalate "." s
-
-versionmsg = progname ++ "-" ++ versionstr ++ configmsg :: String
- where configmsg
- | null configflags = " with no extras"
- | otherwise = " with " ++ intercalate ", " configflags
-
-configflags = tail [""
-#ifdef CHART
- ,"chart"
-#endif
-#ifdef VTY
- ,"vty"
-#endif
-#if defined(WEB)
- ,"web (using simpleserver)"
-#elif defined(WEBHAPPSTACK)
- ,"web (using happstack)"
-#endif
- ]
diff --git a/data/sample.ledger b/data/sample.ledger
new file mode 100644
--- /dev/null
+++ b/data/sample.ledger
@@ -0,0 +1,40 @@
+; A sample ledger file.
+;
+; Sets up this account tree:
+; assets
+; bank
+; checking
+; saving
+; cash
+; expenses
+; food
+; supplies
+; income
+; gifts
+; salary
+; liabilities
+; debts
+
+2008/01/01 income
+ assets:bank:checking $1
+ income:salary
+
+2008/06/01 gift
+ assets:bank:checking $1
+ income:gifts
+
+2008/06/02 save
+ assets:bank:saving $1
+ assets:bank:checking
+
+2008/06/03 * eat & shop
+ expenses:food $1
+ expenses:supplies $1
+ assets:cash
+
+2008/12/31 * pay off
+ liabilities:debts $1
+ assets:bank:checking
+
+
+;final comment
diff --git a/data/sample.rules b/data/sample.rules
new file mode 100644
--- /dev/null
+++ b/data/sample.rules
@@ -0,0 +1,17 @@
+base-account assets:bank:checking
+date-field 0
+description-field 4
+amount-field 1
+currency $
+
+# account-assigning rules
+
+SPECTRUM
+expenses:health:gym
+
+ITUNES
+BLKBSTR=BLOCKBUSTER
+expenses:entertainment
+
+(TO|FROM) SAVINGS
+assets:bank:savings
diff --git a/data/sample.timelog b/data/sample.timelog
new file mode 100644
--- /dev/null
+++ b/data/sample.timelog
@@ -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
diff --git a/hledger.cabal b/hledger.cabal
--- a/hledger.cabal
+++ b/hledger.cabal
@@ -1,5 +1,5 @@
name: hledger
-version: 0.9
+version: 0.10
category: Finance
synopsis: A command-line (or curses or web-based) double-entry accounting tool.
description:
@@ -26,9 +26,14 @@
web/style.css
extra-tmp-files:
extra-source-files:
- README
- sample.ledger
- sample.timelog
+ README.rst
+ README2.rst
+ MANUAL.markdown
+ NEWS.rst
+ CONTRIBUTORS.rst
+ data/sample.ledger
+ data/sample.timelog
+ data/sample.rules
flag vty
description: enable the curses ui
@@ -38,48 +43,29 @@
description: enable the web ui (using simpleserver)
default: False
-flag webhappstack
- description: enable the web ui (using happstack)
- default: False
-
flag chart
description: enable the pie chart generation
default: False
--- minimal library so cabal list and ghc-pkg list will show this package
-library
- exposed-modules:
- Version
--- Build-Depends:
--- base >= 3 && < 5
--- ,containers
--- ,directory
--- ,filepath
--- ,old-time
--- ,parsec
--- ,time
--- ,utf8-string >= 0.3
--- ,HUnit
-
executable hledger
main-is: hledger.hs
other-modules:
- HledgerMain
- Options
Paths_hledger
- Tests
- Utils
- Version
- Commands.Add
- Commands.All
- Commands.Balance
- Commands.Convert
- Commands.Histogram
- Commands.Print
- Commands.Register
- Commands.Stats
+ Hledger.Cli.Main
+ Hledger.Cli.Options
+ Hledger.Cli.Tests
+ Hledger.Cli.Utils
+ Hledger.Cli.Version
+ Hledger.Cli.Commands.Add
+ Hledger.Cli.Commands.All
+ Hledger.Cli.Commands.Balance
+ Hledger.Cli.Commands.Convert
+ Hledger.Cli.Commands.Histogram
+ Hledger.Cli.Commands.Print
+ Hledger.Cli.Commands.Register
+ Hledger.Cli.Commands.Stats
build-depends:
- hledger-lib == 0.9
+ hledger-lib >= 0.10
,HUnit
,base >= 3 && < 5
,containers
@@ -93,7 +79,7 @@
,process
,regexpr >= 0.5.1
,safe >= 0.2
- ,testpack
+ ,testpack >= 1 && < 2
,time
,utf8-string >= 0.3
@@ -102,13 +88,13 @@
if flag(vty)
cpp-options: -DVTY
- other-modules:Commands.UI
+ other-modules:Hledger.Cli.Commands.Vty
build-depends:
vty >= 4.0.0.1
if flag(web)
cpp-options: -DWEB
- other-modules:Commands.Web
+ other-modules:Hledger.Cli.Commands.Web
build-depends:
hsp
,hsx
@@ -121,10 +107,60 @@
,HTTP >= 4000.0
,applicative-extras
- if flag(webhappstack)
- cpp-options: -DWEBHAPPSTACK
- other-modules:Commands.Web
+ if flag(chart)
+ cpp-options: -DCHART
+ other-modules:Hledger.Cli.Commands.Chart
build-depends:
+ Chart >= 0.11
+ ,colour
+
+library
+ exposed-modules:
+ Hledger.Cli.Main
+ Hledger.Cli.Options
+ Hledger.Cli.Tests
+ Hledger.Cli.Utils
+ Hledger.Cli.Version
+ Hledger.Cli.Commands.Add
+ Hledger.Cli.Commands.All
+ Hledger.Cli.Commands.Balance
+ Hledger.Cli.Commands.Convert
+ Hledger.Cli.Commands.Histogram
+ Hledger.Cli.Commands.Print
+ Hledger.Cli.Commands.Register
+ Hledger.Cli.Commands.Stats
+ build-depends:
+ hledger-lib >= 0.10
+ ,HUnit
+ ,base >= 3 && < 5
+ ,containers
+ ,csv
+ ,directory
+ ,filepath
+ ,mtl
+ ,old-locale
+ ,old-time
+ ,parsec
+ ,process
+ ,regexpr >= 0.5.1
+ ,safe >= 0.2
+ ,testpack >= 1 && < 2
+ ,time
+ ,utf8-string >= 0.3
+
+ -- should set patchlevel here as in Makefile
+ cpp-options: -DPATCHLEVEL=0
+
+ if flag(vty)
+ cpp-options: -DVTY
+ exposed-modules:Hledger.Cli.Commands.Vty
+ build-depends:
+ vty >= 4.0.0.1
+
+ if flag(web)
+ cpp-options: -DWEB
+ exposed-modules:Hledger.Cli.Commands.Web
+ build-depends:
hsp
,hsx
,xhtml >= 3000.2
@@ -132,17 +168,13 @@
,io-storage
,hack-contrib
,hack
- ,hack-handler-happstack
- ,happstack >= 0.3
- ,happstack-data >= 0.3
- ,happstack-server >= 0.3
- ,happstack-state >= 0.3
+ ,hack-handler-simpleserver
,HTTP >= 4000.0
,applicative-extras
if flag(chart)
cpp-options: -DCHART
- other-modules:Commands.Chart
+ exposed-modules:Hledger.Cli.Commands.Chart
build-depends:
Chart >= 0.11
,colour
diff --git a/hledger.hs b/hledger.hs
--- a/hledger.hs
+++ b/hledger.hs
@@ -1,39 +1,4 @@
#!/usr/bin/env runhaskell
-{-|
-hledger - a ledger-compatible text-based accounting tool.
-
-Copyright (c) 2007-2010 Simon Michael