hledger 0.26 → 0.27
raw patch · 20 files changed
+1357/−828 lines, 20 filesdep −transformersdep ~cmdargsdep ~haskelinedep ~hledgerPVP ok
version bump matches the API change (PVP)
Dependencies removed: transformers
Dependency ranges changed: cmdargs, haskeline, hledger, hledger-lib, regex-tdfa, safe, split, text
API changes (from Hackage documentation)
- Hledger.Cli.Add: esArgs :: EntryState -> [String]
- Hledger.Cli.Add: esDefDate :: EntryState -> Day
- Hledger.Cli.Add: esJournal :: EntryState -> Journal
- Hledger.Cli.Add: esOpts :: EntryState -> CliOpts
- Hledger.Cli.Add: esPostings :: EntryState -> [Posting]
- Hledger.Cli.Add: esSimilarTransaction :: EntryState -> Maybe Transaction
- Hledger.Cli.Add: esToday :: EntryState -> Day
- Hledger.Cli.Add: instance Exception RestartTransactionException
- Hledger.Cli.Add: instance Show EntryState
- Hledger.Cli.Add: instance Show RestartTransactionException
- Hledger.Cli.Add: instance Typeable EntryState
- Hledger.Cli.Add: instance Typeable RestartTransactionException
- Hledger.Cli.Options: CliOpts :: RawOpts -> String -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Maybe String -> [String] -> Bool -> Int -> Bool -> Maybe String -> Int -> ReportOpts -> CliOpts
- Hledger.Cli.Options: alias_ :: CliOpts -> [String]
- Hledger.Cli.Options: aliasesFromOpts :: CliOpts -> [AccountAlias]
- Hledger.Cli.Options: argsFlag :: FlagHelp -> Arg RawOpts
- Hledger.Cli.Options: available_width_ :: CliOpts -> Int
- Hledger.Cli.Options: checkCliOpts :: CliOpts -> IO CliOpts
- Hledger.Cli.Options: command_ :: CliOpts -> String
- Hledger.Cli.Options: data CliOpts
- Hledger.Cli.Options: debug_ :: CliOpts -> Int
- Hledger.Cli.Options: decodeRawOpts :: RawOpts -> RawOpts
- Hledger.Cli.Options: defAddonCommandMode :: Name -> Mode RawOpts
- Hledger.Cli.Options: defCommandMode :: [Name] -> Mode RawOpts
- Hledger.Cli.Options: defMode :: Mode RawOpts
- Hledger.Cli.Options: defaultOutputFormat :: [Char]
- Hledger.Cli.Options: defaultWidth :: Int
- Hledger.Cli.Options: defcliopts :: CliOpts
- Hledger.Cli.Options: detailedversionflag :: Flag RawOpts
- Hledger.Cli.Options: file_ :: CliOpts -> [FilePath]
- Hledger.Cli.Options: generalflagsgroup1 :: (String, [Flag RawOpts])
- Hledger.Cli.Options: generalflagsgroup2 :: (String, [Flag RawOpts])
- Hledger.Cli.Options: generalflagsgroup3 :: (String, [Flag RawOpts])
- Hledger.Cli.Options: getCliOpts :: Mode RawOpts -> IO CliOpts
- Hledger.Cli.Options: helpflags :: [Flag RawOpts]
- Hledger.Cli.Options: hledgerAddons :: IO ([String], [String])
- Hledger.Cli.Options: ignore_assertions_ :: CliOpts -> Bool
- Hledger.Cli.Options: inputflags :: [Flag RawOpts]
- Hledger.Cli.Options: instance Data CliOpts
- Hledger.Cli.Options: instance Default CliOpts
- Hledger.Cli.Options: instance Show CliOpts
- Hledger.Cli.Options: instance Typeable CliOpts
- Hledger.Cli.Options: journalFilePathFromOpts :: CliOpts -> IO [String]
- Hledger.Cli.Options: lineFormatFromOpts :: ReportOpts -> Either String [OutputFormat]
- Hledger.Cli.Options: maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
- Hledger.Cli.Options: no_new_accounts_ :: CliOpts -> Bool
- Hledger.Cli.Options: outputFileFromOpts :: CliOpts -> IO FilePath
- Hledger.Cli.Options: outputFormatFromOpts :: CliOpts -> String
- Hledger.Cli.Options: outputFormats :: [[Char]]
- Hledger.Cli.Options: output_file_ :: CliOpts -> Maybe FilePath
- Hledger.Cli.Options: output_format_ :: CliOpts -> Maybe String
- Hledger.Cli.Options: outputflags :: [Flag RawOpts]
- Hledger.Cli.Options: rawOptsToCliOpts :: RawOpts -> IO CliOpts
- Hledger.Cli.Options: rawopts_ :: CliOpts -> RawOpts
- Hledger.Cli.Options: registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
- Hledger.Cli.Options: reportflags :: [Flag RawOpts]
- Hledger.Cli.Options: reportopts_ :: CliOpts -> ReportOpts
- Hledger.Cli.Options: rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)
- Hledger.Cli.Options: rules_file_ :: CliOpts -> Maybe FilePath
- Hledger.Cli.Options: showModeHelp :: Mode a -> String
- Hledger.Cli.Options: tests_Hledger_Cli_Options :: Test
- Hledger.Cli.Options: widthFromOpts :: CliOpts -> Int
- Hledger.Cli.Options: width_ :: CliOpts -> Maybe String
- Hledger.Cli.Options: withAliases :: String -> [String] -> String
+ Hledger.Cli.Add: [esArgs] :: EntryState -> [String]
+ Hledger.Cli.Add: [esDefDate] :: EntryState -> Day
+ Hledger.Cli.Add: [esJournal] :: EntryState -> Journal
+ Hledger.Cli.Add: [esOpts] :: EntryState -> CliOpts
+ Hledger.Cli.Add: [esPostings] :: EntryState -> [Posting]
+ Hledger.Cli.Add: [esSimilarTransaction] :: EntryState -> Maybe Transaction
+ Hledger.Cli.Add: [esToday] :: EntryState -> Day
+ Hledger.Cli.Add: instance GHC.Exception.Exception Hledger.Cli.Add.RestartTransactionException
+ Hledger.Cli.Add: instance GHC.Show.Show Hledger.Cli.Add.EntryState
+ Hledger.Cli.Add: instance GHC.Show.Show Hledger.Cli.Add.RestartTransactionException
+ Hledger.Cli.Balance: balanceReportItemAsText :: ReportOpts -> StringFormat -> BalanceReportItem -> [String]
+ Hledger.Cli.CliOptions: CliOpts :: RawOpts -> String -> [FilePath] -> Maybe FilePath -> Maybe FilePath -> Maybe String -> [String] -> Bool -> Int -> Bool -> Maybe String -> Int -> ReportOpts -> CliOpts
+ Hledger.Cli.CliOptions: [alias_] :: CliOpts -> [String]
+ Hledger.Cli.CliOptions: [available_width_] :: CliOpts -> Int
+ Hledger.Cli.CliOptions: [command_] :: CliOpts -> String
+ Hledger.Cli.CliOptions: [debug_] :: CliOpts -> Int
+ Hledger.Cli.CliOptions: [file_] :: CliOpts -> [FilePath]
+ Hledger.Cli.CliOptions: [ignore_assertions_] :: CliOpts -> Bool
+ Hledger.Cli.CliOptions: [no_new_accounts_] :: CliOpts -> Bool
+ Hledger.Cli.CliOptions: [output_file_] :: CliOpts -> Maybe FilePath
+ Hledger.Cli.CliOptions: [output_format_] :: CliOpts -> Maybe String
+ Hledger.Cli.CliOptions: [rawopts_] :: CliOpts -> RawOpts
+ Hledger.Cli.CliOptions: [reportopts_] :: CliOpts -> ReportOpts
+ Hledger.Cli.CliOptions: [rules_file_] :: CliOpts -> Maybe FilePath
+ Hledger.Cli.CliOptions: [width_] :: CliOpts -> Maybe String
+ Hledger.Cli.CliOptions: aliasesFromOpts :: CliOpts -> [AccountAlias]
+ Hledger.Cli.CliOptions: argsFlag :: FlagHelp -> Arg RawOpts
+ Hledger.Cli.CliOptions: checkCliOpts :: CliOpts -> CliOpts
+ Hledger.Cli.CliOptions: data CliOpts
+ Hledger.Cli.CliOptions: decodeRawOpts :: RawOpts -> RawOpts
+ Hledger.Cli.CliOptions: defAddonCommandMode :: Name -> Mode RawOpts
+ Hledger.Cli.CliOptions: defCommandMode :: [Name] -> Mode RawOpts
+ Hledger.Cli.CliOptions: defMode :: Mode RawOpts
+ Hledger.Cli.CliOptions: defaultBalanceLineFormat :: StringFormat
+ Hledger.Cli.CliOptions: defaultOutputFormat :: [Char]
+ Hledger.Cli.CliOptions: defaultWidth :: Int
+ Hledger.Cli.CliOptions: defcliopts :: CliOpts
+ Hledger.Cli.CliOptions: detailedversionflag :: Flag RawOpts
+ Hledger.Cli.CliOptions: generalflagsgroup1 :: (String, [Flag RawOpts])
+ Hledger.Cli.CliOptions: generalflagsgroup2 :: (String, [Flag RawOpts])
+ Hledger.Cli.CliOptions: generalflagsgroup3 :: (String, [Flag RawOpts])
+ Hledger.Cli.CliOptions: getCliOpts :: Mode RawOpts -> IO CliOpts
+ Hledger.Cli.CliOptions: helpflags :: [Flag RawOpts]
+ Hledger.Cli.CliOptions: hledgerAddons :: IO ([String], [String])
+ Hledger.Cli.CliOptions: inputflags :: [Flag RawOpts]
+ Hledger.Cli.CliOptions: instance Data.Data.Data Hledger.Cli.CliOptions.CliOpts
+ Hledger.Cli.CliOptions: instance GHC.Show.Show Hledger.Cli.CliOptions.CliOpts
+ Hledger.Cli.CliOptions: instance System.Console.CmdArgs.Default.Default Hledger.Cli.CliOptions.CliOpts
+ Hledger.Cli.CliOptions: journalFilePathFromOpts :: CliOpts -> IO [String]
+ Hledger.Cli.CliOptions: lineFormatFromOpts :: ReportOpts -> Either String StringFormat
+ Hledger.Cli.CliOptions: maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName
+ Hledger.Cli.CliOptions: outputFileFromOpts :: CliOpts -> IO FilePath
+ Hledger.Cli.CliOptions: outputFormatFromOpts :: CliOpts -> String
+ Hledger.Cli.CliOptions: outputFormats :: [[Char]]
+ Hledger.Cli.CliOptions: outputflags :: [Flag RawOpts]
+ Hledger.Cli.CliOptions: rawOptsToCliOpts :: RawOpts -> IO CliOpts
+ Hledger.Cli.CliOptions: registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)
+ Hledger.Cli.CliOptions: reportflags :: [Flag RawOpts]
+ Hledger.Cli.CliOptions: rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)
+ Hledger.Cli.CliOptions: showModeHelp :: Mode a -> String
+ Hledger.Cli.CliOptions: tests_Hledger_Cli_CliOptions :: Test
+ Hledger.Cli.CliOptions: widthFromOpts :: CliOpts -> Int
+ Hledger.Cli.CliOptions: withAliases :: String -> [String] -> String
+ Hledger.Cli.Print: entriesReportAsText :: EntriesReport -> String
+ Hledger.Cli.Register: postingsReportItemAsText :: CliOpts -> Int -> Int -> PostingsReportItem -> String
+ Text.Tabular.AsciiWide: render :: (rh -> String) -> (ch -> String) -> (a -> String) -> Table rh ch a -> String
+ Text.Tabular.AsciiWide: renderColumns :: [Int] -> Header String -> String
+ Text.Tabular.AsciiWide: renderHLine :: [Int] -> Header String -> Properties -> [String]
+ Text.Tabular.AsciiWide: renderHLine' :: [Int] -> Char -> Header String -> String
- Hledger.Cli.Add: compareDescriptions :: [Char] -> [Char] -> Double
+ Hledger.Cli.Add: compareDescriptions :: String -> String -> Double
- Hledger.Cli.Add: defaultTo' :: b -> Wizard Haskeline b -> Wizard Haskeline b
+ Hledger.Cli.Add: defaultTo' :: a -> Wizard Haskeline a -> Wizard Haskeline a
- Hledger.Cli.Add: letterPairs :: [t] -> [[t]]
+ Hledger.Cli.Add: letterPairs :: [a] -> [[a]]
- Hledger.Cli.Histogram: countBar :: [a] -> [Char]
+ Hledger.Cli.Histogram: countBar :: Foldable t => t a -> [Char]
- Hledger.Cli.Histogram: printDayWith :: (PrintfArg t2, PrintfType t1) => (t -> t2) -> (DateSpan, t) -> t1
+ Hledger.Cli.Histogram: printDayWith :: (PrintfType t, PrintfArg t1) => (t2 -> t1) -> (DateSpan, t2) -> t
Files
- CHANGES +85/−1
- Hledger/Cli.hs +10/−4
- Hledger/Cli/Accounts.hs +1/−1
- Hledger/Cli/Add.hs +23/−14
- Hledger/Cli/Balance.hs +95/−50
- Hledger/Cli/Balancesheet.hs +1/−1
- Hledger/Cli/Cashflow.hs +1/−1
- Hledger/Cli/CliOptions.hs +590/−0
- Hledger/Cli/Histogram.hs +1/−1
- Hledger/Cli/Incomestatement.hs +1/−1
- Hledger/Cli/Main.hs +3/−3
- Hledger/Cli/Options.hs +0/−586
- Hledger/Cli/Print.hs +41/−3
- Hledger/Cli/Register.hs +50/−20
- Hledger/Cli/Stats.hs +1/−1
- Hledger/Cli/Utils.hs +1/−1
- README.md +40/−0
- Text/Tabular/AsciiWide.hs +75/−0
- bench/SimpleBench.hs +178/−0
- hledger.cabal +160/−140
CHANGES view
@@ -1,6 +1,90 @@ User-visible changes in hledger and hledger-lib. +0.27 (unreleased)++Account aliases:++- Regular expression account aliases are now fast enough that you can+ use lots of them without slowing things down. They now take+ O(aliases x accounts) time, instead of O(aliases x transactions);+ also, regular expressions are no longer recompiled unnecessarily.++Documentation:++- The hledger packages now have man pages, based on the current user+ manual, thanks to the mighty pandoc (#282).+ +Journal format:++- Dates must now begin with a digit (not /, eg).++- The comment directive longer requires an end comment, and will+ extend to the end of the file(s) without it.++Command-line interface:++- Output (balance reports, register reports, print output etc.)+ containing wide characters, eg chinese/japanese/korean characters,+ should now align correctly, when viewed in apps and fonts that show+ wide characters as double width (#242).+ +- The argument for --depth or depth: must now be positive.++add:++- Journal entries are now written with all amounts explicit, to avoid+ losing price info (#283).++- Fixed a bug which sometimes (when the same letter pair was repeated)+ caused it not to pick the most similar past transaction for defaults.+ +balance:++- There is now a -V/--value flag to report current market value (as in Ledger).+ It converts all reported amounts using their "default market price".+ "Market price" is the new name for "historical prices", defined with the P directive.+ The default market price for a commodity is the most recent one found in the journal on or before the report end date.+ + Unlike Ledger, hledger's -V uses only the market prices recorded+ with P directives; it does not use the "transaction prices"+ recorded as part of posting amounts (which are used by -B/--cost).+ Also, using both -B and -V at the same time is supported.++- Fixed a bug in amount normalization which caused amount styles+ (commodity symbol placement, decimal point character, etc.) to be+ lost in certain cases (#230, #276).++- The balance command's --format option can now adjust the rendering+ style of multi-commodity amounts, if you begin the format string+ with one of:+ + %_ - renders amounts on multiple lines, bottom-aligned (the default)+ %^ - renders amounts on multiple lines, top-aligned+ %, - renders amounts on one line, comma-separated+ +- The balance report's final total (and the line above it) now adapt+ themselves to a custom --format.++print:++- The --match option prints the journal entry that best matches a+ description (ie whose description field is most similar to the value+ given, and if there are several equally similar, the most recent).+ This was originally an add-on I used to guess account names for+ ledger-autosync. It's nice for quickly looking up a recent+ transaction from a guessed or partial description.++- print now always right-aligns the amounts in an entry, even when+ they are wider than 12 characters. (If there is a price, it's+ considered part of the amount for right-alignment.)++register:++- Amount columns now resize automatically, using more space if it's+ needed and available.++ 0.26 (2015/7/12) Account aliases:@@ -416,4 +500,4 @@ - allow text 1.1, drop data-pprint to build with GHC 7.8.x -0.22.1 (2014/1/6) and older: see http://hledger.org/release-notes or doc/CHANGES.md.+0.22.1 (2014/1/6) and older: see http://hledger.org/release-notes or doc/release-notes.md.
Hledger/Cli.hs view
@@ -18,7 +18,7 @@ module Hledger.Cli.Print, module Hledger.Cli.Register, module Hledger.Cli.Stats,- module Hledger.Cli.Options,+ module Hledger.Cli.CliOptions, module Hledger.Cli.Utils, module Hledger.Cli.Version, tests_Hledger_Cli,@@ -41,7 +41,7 @@ import Hledger.Cli.Print import Hledger.Cli.Register import Hledger.Cli.Stats-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Utils import Hledger.Cli.Version @@ -51,12 +51,12 @@ [ tests_Hledger -- ,tests_Hledger_Cli_Add- -- ,tests_Hledger_Cli_Balance+ ,tests_Hledger_Cli_Balance ,tests_Hledger_Cli_Balancesheet ,tests_Hledger_Cli_Cashflow -- ,tests_Hledger_Cli_Histogram ,tests_Hledger_Cli_Incomestatement- ,tests_Hledger_Cli_Options+ ,tests_Hledger_Cli_CliOptions -- ,tests_Hledger_Cli_Print ,tests_Hledger_Cli_Register -- ,tests_Hledger_Cli_Stats@@ -343,6 +343,7 @@ journal7 = nulljournal {jtxns = [ txnTieKnot Transaction {+ tindex=0, tsourcepos=nullsourcepos, tdate=parsedate "2007/01/01", tdate2=Nothing,@@ -359,6 +360,7 @@ } , txnTieKnot Transaction {+ tindex=0, tsourcepos=nullsourcepos, tdate=parsedate "2007/02/01", tdate2=Nothing,@@ -375,6 +377,7 @@ } , txnTieKnot Transaction {+ tindex=0, tsourcepos=nullsourcepos, tdate=parsedate "2007/01/02", tdate2=Nothing,@@ -391,6 +394,7 @@ } , txnTieKnot Transaction {+ tindex=0, tsourcepos=nullsourcepos, tdate=parsedate "2007/01/03", tdate2=Nothing,@@ -407,6 +411,7 @@ } , txnTieKnot Transaction {+ tindex=0, tsourcepos=nullsourcepos, tdate=parsedate "2007/01/03", tdate2=Nothing,@@ -423,6 +428,7 @@ } , txnTieKnot Transaction {+ tindex=0, tsourcepos=nullsourcepos, tdate=parsedate "2007/01/03", tdate2=Nothing,
Hledger/Cli/Accounts.hs view
@@ -23,7 +23,7 @@ import Hledger import Prelude hiding (putStrLn) import Hledger.Utils.UTF8IOCompat (putStrLn)-import Hledger.Cli.Options+import Hledger.Cli.CliOptions -- | Command line options for this command.
Hledger/Cli/Add.hs view
@@ -15,6 +15,7 @@ import Control.Monad.Trans (liftIO) import Data.Char (toUpper, toLower) import Data.List.Compat+import qualified Data.Set as S import Data.Maybe import Data.Time.Calendar (Day) import Data.Typeable (Typeable)@@ -29,7 +30,7 @@ import Text.Printf import Hledger-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Register (postingsReportAsText) @@ -351,7 +352,8 @@ journalAddTransaction :: Journal -> CliOpts -> Transaction -> IO Journal journalAddTransaction j@Journal{jtxns=ts} opts t = do let f = journalFilePath j- appendToJournalFileOrStdout f $ showTransaction t+ appendToJournalFileOrStdout f $ showTransactionUnelided t+ -- unelided shows all amounts explicitly, in case there's a price, cf #283 when (debug_ opts > 0) $ do putStrLn $ printf "\nAdded transaction to %s:" f putStrLn =<< registerFromString (show t)@@ -384,8 +386,9 @@ capitalize "" = "" capitalize (c:cs) = toUpper c : cs --- Find the most similar and recent transactions matching the given transaction description and report query.--- Transactions are listed with their "relevancy" score, most relevant first.+-- | Find the most similar and recent transactions matching the given+-- transaction description and report query. Transactions are listed+-- with their "relevancy" score, most relevant first. transactionsSimilarTo :: Journal -> Query -> String -> [(Double,Transaction)] transactionsSimilarTo j q desc = sortBy compareRelevanceAndRecency@@ -396,27 +399,33 @@ ts = filter (q `matchesTransaction`) $ jtxns j threshold = 0 -compareDescriptions :: [Char] -> [Char] -> Double+-- | Return a similarity measure, from 0 to 1, for two transaction+-- descriptions. This is like compareStrings, but first strips out+-- any numbers, to improve accuracy eg when there are bank transaction+-- ids from imported data.+compareDescriptions :: String -> String -> Double compareDescriptions s t = compareStrings s' t' where s' = simplify s t' = simplify t simplify = filter (not . (`elem` "0123456789")) --- | 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.+-- | Return a similarity measure, from 0 to 1, for two strings. This+-- was based on Simon White's string similarity algorithm+-- (http://www.catalysoft.com/articles/StrikeAMatch.html), later found+-- to be https://en.wikipedia.org/wiki/S%C3%B8rensen%E2%80%93Dice_coefficient,+-- modified to handle short strings better.+-- Todo: check out http://nlp.fi.muni.cz/raslan/2008/raslan08.pdf#page=14 . 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+compareStrings s1 s2 = 2 * commonpairs / totalpairs where- i = length $ intersect pairs1 pairs2- u = length pairs1 + length pairs2- pairs1 = wordLetterPairs $ uppercase s1- pairs2 = wordLetterPairs $ uppercase s2+ pairs1 = S.fromList $ wordLetterPairs $ uppercase s1+ pairs2 = S.fromList $ wordLetterPairs $ uppercase s2+ commonpairs = fromIntegral $ S.size $ S.intersection pairs1 pairs2+ totalpairs = fromIntegral $ S.size pairs1 + S.size pairs2 wordLetterPairs = concatMap letterPairs . words
Hledger/Cli/Balance.hs view
@@ -236,22 +236,24 @@ balancemode ,balance ,balanceReportAsText+ ,balanceReportItemAsText ,periodBalanceReportAsText ,cumulativeBalanceReportAsText ,historicalBalanceReportAsText ,tests_Hledger_Cli_Balance ) where +import Data.List (intercalate)+import Data.Maybe (fromMaybe, isJust) import System.Console.CmdArgs.Explicit as C import Text.CSV import Test.HUnit import Text.Printf (printf) import Text.Tabular as T-import Text.Tabular.AsciiArt+import Text.Tabular.AsciiWide import Hledger-import Hledger.Data.OutputFormat-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Utils @@ -263,13 +265,14 @@ flagNone ["tree"] (\opts -> setboolopt "tree" opts) "show accounts as a tree (default in simple reports)" ,flagNone ["flat"] (\opts -> setboolopt "flat" opts) "show accounts as a list (default in multicolumn mode)" ,flagReq ["drop"] (\s opts -> Right $ setopt "drop" s opts) "N" "flat mode: omit N leading account name parts"- ,flagReq ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "tree mode: use this custom line format"+ ,flagReq ["format"] (\s opts -> Right $ setopt "format" s opts) "FORMATSTR" "singlecolumn mode: use this custom line format" ,flagNone ["no-elide"] (\opts -> setboolopt "no-elide" opts) "tree mode: don't squash boring parent accounts" ,flagNone ["historical","H"] (\opts -> setboolopt "historical" opts) "multicolumn mode: show historical ending balances" ,flagNone ["cumulative"] (\opts -> setboolopt "cumulative" opts) "multicolumn mode: show accumulated ending balances" ,flagNone ["average","A"] (\opts -> setboolopt "average" opts) "multicolumn mode: show a row average column" ,flagNone ["row-total","T"] (\opts -> setboolopt "row-total" opts) "multicolumn mode: show a row total column" ,flagNone ["no-total","N"] (\opts -> setboolopt "no-total" opts) "don't show the final total row"+ ,flagNone ["value","V"] (setboolopt "value") "show amounts as their current market value in their default valuation commodity" ] ++ outputflags ,groupHidden = []@@ -288,25 +291,38 @@ let format = outputFormatFromOpts opts interval = intervalFromOpts ropts baltype = balancetype_ ropts+ valuedate = fromMaybe d $ queryEndDate False $ queryFromOpts d ropts case interval of NoInterval -> do let report = balanceReport ropts (queryFromOpts d ropts) j+ convert | value_ ropts = balanceReportValue j valuedate+ | otherwise = id render = case format of "csv" -> \ropts r -> (++ "\n") $ printCSV $ balanceReportAsCsv ropts r _ -> balanceReportAsText- writeOutput opts $ render ropts report+ writeOutput opts $ render ropts $ convert report _ -> do let report = multiBalanceReport ropts (queryFromOpts d ropts) j+ convert | value_ ropts = multiBalanceReportValue j valuedate+ | otherwise = id render = case format of "csv" -> \ropts r -> (++ "\n") $ printCSV $ multiBalanceReportAsCsv ropts r _ -> case baltype of PeriodBalance -> periodBalanceReportAsText CumulativeBalance -> cumulativeBalanceReportAsText HistoricalBalance -> historicalBalanceReportAsText- writeOutput opts $ render ropts report+ writeOutput opts $ render ropts $ convert report -- single-column balance reports +-- | Find the best commodity to convert to when asked to show the+-- market value of this commodity on the given date. That is, the one+-- in which it has most recently been market-priced, ie the commodity+-- mentioned in the most recent applicable historical price directive+-- before this date.+-- defaultValuationCommodity :: Journal -> Day -> Commodity -> Maybe Commodity+-- defaultValuationCommodity j d c = mpamount <$> commodityValue j d c+ -- | Render a single-column balance report as CSV. balanceReportAsCsv :: ReportOpts -> BalanceReport -> CSV balanceReportAsCsv opts (items, total) =@@ -321,15 +337,26 @@ balanceReportAsText :: ReportOpts -> BalanceReport -> String balanceReportAsText opts ((items, total)) = unlines $ concat lines ++ t where- lines = case lineFormatFromOpts opts of- Right f -> map (balanceReportItemAsText opts f) items- Left err -> [[err]]+ fmt = lineFormatFromOpts opts+ lines = case fmt of+ Right fmt -> map (balanceReportItemAsText opts fmt) items+ Left err -> [[err]] t = if no_total_ opts then []- else ["--------------------"- -- TODO: This must use the format somehow- ,padleft 20 $ showMixedAmountWithoutPrice total- ]+ else+ case fmt of+ Right fmt ->+ let+ -- abuse renderBalanceReportItem to render the total with similar format+ acctcolwidth = maximum' [length fullname | ((fullname, _, _), _) <- items]+ totallines = map rstrip $ renderBalanceReportItem fmt (replicate (acctcolwidth+1) ' ', 0, total)+ -- with a custom format, extend the line to the full report width;+ -- otherwise show the usual 20-char line for compatibility+ overlinewidth | isJust (format_ opts) = maximum' $ map length $ concat lines+ | otherwise = defaultTotalFieldWidth+ overline = replicate overlinewidth '-'+ in overline : totallines+ Left _ -> [] tests_balanceReportAsText = [ "balanceReportAsText" ~: do@@ -356,41 +383,59 @@ EUR -1 b USD -1 ; Account 'b' has two amounts. The account name is printed on the last line. -}--- | Render one balance report line item as plain text suitable for console output.-balanceReportItemAsText :: ReportOpts -> [OutputFormat] -> BalanceReportItem -> [String]-balanceReportItemAsText opts format ((_, accountName, depth), Mixed amounts) =- -- 'amounts' could contain several quantities of the same commodity with different price.- -- In order to combine them into single value (which is expected) we take the first price and- -- use it for the whole mixed amount. This could be suboptimal. XXX- let Mixed normAmounts = normaliseMixedAmountSquashPricesForDisplay (Mixed amounts) in- case normAmounts of- [] -> []- [a] -> [formatBalanceReportItem opts (Just accountName) depth a format]- (as) -> multiline as- where- multiline :: [Amount] -> [String]- multiline [] = []- multiline [a] = [formatBalanceReportItem opts (Just accountName) depth a format]- multiline (a:as) = (formatBalanceReportItem opts Nothing depth a format) : multiline as+-- | Render one balance report line item as plain text suitable for console output (or+-- whatever string format is specified). Note, prices will not be rendered, and+-- differently-priced quantities of the same commodity will appear merged.+-- The output will be one or more lines depending on the format and number of commodities.+balanceReportItemAsText :: ReportOpts -> StringFormat -> BalanceReportItem -> [String]+balanceReportItemAsText opts fmt ((_, accountName, depth), amt) =+ renderBalanceReportItem fmt (+ maybeAccountNameDrop opts accountName,+ depth,+ normaliseMixedAmountSquashPricesForDisplay amt+ ) -formatBalanceReportItem :: ReportOpts -> Maybe AccountName -> Int -> Amount -> [OutputFormat] -> String-formatBalanceReportItem _ _ _ _ [] = ""-formatBalanceReportItem opts accountName depth amount (fmt:fmts) =- s ++ (formatBalanceReportItem opts accountName depth amount fmts)+-- | Render a balance report item using the given StringFormat, generating one or more lines of text.+renderBalanceReportItem :: StringFormat -> (AccountName, Int, MixedAmount) -> [String]+renderBalanceReportItem fmt (acctname, depth, total) =+ lines $+ case fmt of+ OneLine comps -> concatOneLine $ render1 comps+ TopAligned comps -> concatBottomPadded $ render comps+ BottomAligned comps -> concatTopPadded $ render comps where- s = case fmt of- FormatLiteral l -> l- FormatField ljust min max field -> formatField opts accountName depth amount ljust min max field+ render1 = map (renderComponent1 (acctname, depth, total))+ render = map (renderComponent (acctname, depth, total)) -formatField :: ReportOpts -> Maybe AccountName -> Int -> Amount -> Bool -> Maybe Int -> Maybe Int -> HledgerFormatField -> String-formatField opts accountName depth total ljust min max field = case field of- AccountField -> formatValue ljust min max $ maybe "" (maybeAccountNameDrop opts) accountName- DepthSpacerField -> case min of- Just m -> formatValue ljust Nothing max $ replicate (depth * m) ' '- Nothing -> formatValue ljust Nothing max $ replicate depth ' '- TotalField -> formatValue ljust min max $ showAmountWithoutPrice total- _ -> ""+defaultTotalFieldWidth = 20 +-- | Render one StringFormat component for a balance report item.+renderComponent :: (AccountName, Int, MixedAmount) -> StringFormatComponent -> String+renderComponent _ (FormatLiteral s) = s+renderComponent (acctname, depth, total) (FormatField ljust min max field) = case field of+ DepthSpacerField -> formatString ljust Nothing max $ replicate d ' '+ where d = case min of+ Just m -> depth * m+ Nothing -> depth+ AccountField -> formatString ljust min max acctname+ TotalField -> fitStringMulti min max True False $ showMixedAmountWithoutPrice total+ _ -> ""++-- | Render one StringFormat component for a balance report item.+-- This variant is for use with OneLine string formats; it squashes+-- any multi-line rendered values onto one line, comma-and-space separated,+-- while still complying with the width spec.+renderComponent1 :: (AccountName, Int, MixedAmount) -> StringFormatComponent -> String+renderComponent1 _ (FormatLiteral s) = s+renderComponent1 (acctname, depth, total) (FormatField ljust min max field) = case field of+ AccountField -> formatString ljust min max ((intercalate ", " . lines) (indented acctname))+ where+ -- better to indent the account name here rather than use a DepthField component+ -- so that it complies with width spec. Uses a fixed indent step size.+ indented = ((replicate (depth*2) ' ')++)+ TotalField -> fitStringMulti min max True False $ ((intercalate ", " . map strip . lines) (showMixedAmountWithoutPrice total))+ _ -> ""+ -- multi-column balance reports -- | Render a multi-column balance report as CSV.@@ -425,7 +470,7 @@ render id (" "++) showMixedAmountOneLineWithoutPrice $ addtotalrow $ Table- (T.Group NoLine $ map (Header . padright acctswidth) accts)+ (T.Group NoLine $ map (Header . padRightWide acctswidth) accts) (T.Group NoLine $ map Header colheadings) (map rowvals items') where@@ -439,7 +484,7 @@ renderacct ((a,a',i),_,_,_) | tree_ opts = replicate ((i-1)*2) ' ' ++ a' | otherwise = maybeAccountNameDrop opts a- acctswidth = maximum $ map length $ accts+ acctswidth = maximum' $ map strWidth accts rowvals (_,as,rowtot,rowavg) = as ++ (if row_total_ opts then [rowtot] else []) ++ (if average_ opts then [rowavg] else [])@@ -459,7 +504,7 @@ render id (" "++) showMixedAmountOneLineWithoutPrice $ addtotalrow $ Table- (T.Group NoLine $ map (Header . padright acctswidth) accts)+ (T.Group NoLine $ map (Header . padRightWide acctswidth) accts) (T.Group NoLine $ map Header colheadings) (map rowvals items) where@@ -471,7 +516,7 @@ renderacct ((a,a',i),_,_,_) | tree_ opts = replicate ((i-1)*2) ' ' ++ a' | otherwise = maybeAccountNameDrop opts a- acctswidth = maximum $ map length $ accts+ acctswidth = maximum' $ map strWidth accts rowvals (_,as,rowtot,rowavg) = as ++ (if row_total_ opts then [rowtot] else []) ++ (if average_ opts then [rowavg] else [])@@ -491,7 +536,7 @@ render id (" "++) showMixedAmountOneLineWithoutPrice $ addtotalrow $ Table- (T.Group NoLine $ map (Header . padright acctswidth) accts)+ (T.Group NoLine $ map (Header . padRightWide acctswidth) accts) (T.Group NoLine $ map Header colheadings) (map rowvals items) where@@ -503,7 +548,7 @@ renderacct ((a,a',i),_,_,_) | tree_ opts = replicate ((i-1)*2) ' ' ++ a' | otherwise = maybeAccountNameDrop opts a- acctswidth = maximum $ map length $ accts+ acctswidth = maximum' $ map strWidth accts rowvals (_,as,rowtot,rowavg) = as ++ (if row_total_ opts then [rowtot] else []) ++ (if average_ opts then [rowavg] else [])
Hledger/Cli/Balancesheet.hs view
@@ -17,7 +17,7 @@ import Text.Shakespeare.Text import Hledger-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Balance
Hledger/Cli/Cashflow.hs view
@@ -20,7 +20,7 @@ import Text.Shakespeare.Text import Hledger-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Balance
+ Hledger/Cli/CliOptions.hs view
@@ -0,0 +1,590 @@+{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts #-}+{-|++Common cmdargs modes and flags, a command-line options type, and+related utilities used by hledger commands.++-}++module Hledger.Cli.CliOptions (++ -- * cmdargs flags & modes+ helpflags,+ detailedversionflag,+ inputflags,+ reportflags,+ outputflags,+ generalflagsgroup1,+ generalflagsgroup2,+ generalflagsgroup3,+ defMode,+ defCommandMode,+ defAddonCommandMode,+ argsFlag,+ showModeHelp,+ withAliases,++ -- * CLI options+ CliOpts(..),+ defcliopts,+ getCliOpts,+ decodeRawOpts,+ rawOptsToCliOpts,+ checkCliOpts,+ outputFormats,+ defaultOutputFormat,+ defaultBalanceLineFormat,++ -- possibly these should move into argsToCliOpts+ -- * CLI option accessors+ -- | These do the extra processing required for some options.+ aliasesFromOpts,+ journalFilePathFromOpts,+ rulesFilePathFromOpts,+ outputFileFromOpts,+ outputFormatFromOpts,+ defaultWidth,+ widthFromOpts,+ -- | For register:+ registerWidthsFromOpts,+ maybeAccountNameDrop,+ -- | For balance:+ lineFormatFromOpts,++ -- * Other utils+ hledgerAddons,++ -- * Tests+ tests_Hledger_Cli_CliOptions++)+where++import Prelude ()+import Prelude.Compat+import qualified Control.Exception as C+import Control.Monad (when)+#if !MIN_VERSION_base(4,8,0)+import Data.Functor.Compat ((<$>))+#endif+import Data.List.Compat+import Data.List.Split (splitOneOf)+import Data.Maybe+import Safe+import System.Console.CmdArgs+import System.Console.CmdArgs.Explicit+import System.Console.CmdArgs.Text+#ifndef mingw32_HOST_OS+import System.Console.Terminfo+#endif+import System.Directory+import System.Environment+import System.Exit (exitSuccess)+import System.FilePath+import Test.HUnit+import Text.Parsec++import Hledger+import Hledger.Cli.Version+++-- common cmdargs flags++-- | Common help flags: --help, --debug, --version...+helpflags :: [Flag RawOpts]+helpflags = [+ flagNone ["help","h"] (setboolopt "help") "show general help or (after command) command help"+ -- ,flagNone ["browse-args"] (setboolopt "browse-args") "use a web UI to select options and build up a command line"+ ,flagReq ["debug"] (\s opts -> Right $ setopt "debug" s opts) "N" "show debug output if N is 1-9 (default: 0)"+ ,flagNone ["version"] (setboolopt "version") "show version information"+ ]++-- | A hidden flag, just for the hledger executable.+detailedversionflag :: Flag RawOpts+detailedversionflag = flagNone ["version+"] (setboolopt "version+") "show version information with extra detail"++-- | Common input-related flags: --file, --rules-file, --alias...+inputflags :: [Flag RawOpts]+inputflags = [+ flagReq ["file","f"] (\s opts -> Right $ setopt "file" s opts) "FILE" "use a different input file. For stdin, use -"+ ,flagReq ["rules-file"] (\s opts -> Right $ setopt "rules-file" s opts) "RFILE" "CSV conversion rules file (default: FILE.rules)"+ ,flagReq ["alias"] (\s opts -> Right $ setopt "alias" s opts) "OLD=NEW" "display accounts named OLD as NEW"+ ,flagNone ["ignore-assertions"] (setboolopt "ignore-assertions") "ignore any balance assertions in the journal"+ ]++-- | Common report-related flags: --period, --cost, etc.+reportflags :: [Flag RawOpts]+reportflags = [+ flagReq ["begin","b"] (\s opts -> Right $ setopt "begin" s opts) "DATE" "include postings/txns on or after this date"+ ,flagReq ["end","e"] (\s opts -> Right $ setopt "end" s opts) "DATE" "include postings/txns before this date"+ ,flagNone ["daily","D"] (setboolopt "daily") "multiperiod/multicolumn report by day"+ ,flagNone ["weekly","W"] (setboolopt "weekly") "multiperiod/multicolumn report by week"+ ,flagNone ["monthly","M"] (setboolopt "monthly") "multiperiod/multicolumn report by month"+ ,flagNone ["quarterly","Q"] (setboolopt "quarterly") "multiperiod/multicolumn report by quarter"+ ,flagNone ["yearly","Y"] (setboolopt "yearly") "multiperiod/multicolumn report by year"+ ,flagReq ["period","p"] (\s opts -> Right $ setopt "period" s opts) "PERIODEXP" "set start date, end date, and/or reporting interval all at once (overrides the flags above)"+ ,flagNone ["date2","aux-date"] (setboolopt "date2") "use postings/txns' secondary dates instead"++ ,flagNone ["cleared","C"] (setboolopt "cleared") "include only cleared postings/txns"+ ,flagNone ["pending"] (setboolopt "pending") "include only pending postings/txns"+ ,flagNone ["uncleared","U"] (setboolopt "uncleared") "include only uncleared (and pending) postings/txns"+ ,flagNone ["real","R"] (setboolopt "real") "include only non-virtual postings"+ ,flagReq ["depth"] (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/postings deeper than N"+ ,flagNone ["empty","E"] (setboolopt "empty") "show empty/zero things which are normally omitted"+ ,flagNone ["cost","B"] (setboolopt "cost") "show amounts in their cost price's commodity"+ ]++-- | Common output-related flags: --output-file, --output-format...+outputflags = [+ flagReq ["output-file","o"] (\s opts -> Right $ setopt "output-file" s opts) "FILE[.FMT]" "write output to FILE instead of stdout. A recognised FMT suffix influences the format."+ ,flagReq ["output-format","O"] (\s opts -> Right $ setopt "output-format" s opts) "FMT" "select the output format. Supported formats: txt, csv."+ ]++argsFlag :: FlagHelp -> Arg RawOpts+argsFlag desc = flagArg (\s opts -> Right $ setopt "args" s opts) desc++generalflagstitle :: String+generalflagstitle = "\nGeneral flags"++generalflagsgroup1, generalflagsgroup2, generalflagsgroup3 :: (String, [Flag RawOpts])+generalflagsgroup1 = (generalflagstitle, inputflags ++ reportflags ++ helpflags)+generalflagsgroup2 = (generalflagstitle, inputflags ++ helpflags)+generalflagsgroup3 = (generalflagstitle, helpflags)++-- cmdargs mode constructors++-- | A basic mode template.+defMode :: Mode RawOpts+defMode = Mode {+ modeNames = []+ ,modeHelp = ""+ ,modeHelpSuffix = []+ ,modeValue = []+ ,modeCheck = Right+ ,modeReform = const Nothing+ ,modeExpandAt = True+ ,modeGroupFlags = Group {+ groupNamed = []+ ,groupUnnamed = [+ flagNone ["help","h","?"] (setboolopt "help") "Show command help."+ ]+ ,groupHidden = []+ }+ ,modeArgs = ([], Nothing)+ ,modeGroupModes = toGroup []+ }++-- | A basic subcommand mode with the given command name(s).+defCommandMode :: [Name] -> Mode RawOpts+defCommandMode names = defMode {+ modeNames=names+ ,modeValue=[("command", headDef "" names)]+ ,modeArgs = ([], Just $ argsFlag "[PATTERNS]")+ }++-- | A basic subcommand mode suitable for an add-on command.+defAddonCommandMode :: Name -> Mode RawOpts+defAddonCommandMode addon = defMode {+ modeNames = [addon]+ ,modeHelp = fromMaybe "" $ lookup (stripAddonExtension addon) standardAddonsHelp+ ,modeValue=[("command",addon)]+ ,modeGroupFlags = Group {+ groupUnnamed = []+ ,groupHidden = []+ ,groupNamed = [generalflagsgroup1]+ }+ ,modeArgs = ([], Just $ argsFlag "[ARGS]")+ }++-- | Built-in descriptions for some of the known external addons,+-- since we don't currently have any way to ask them.+standardAddonsHelp :: [(String,String)]+standardAddonsHelp = [+ ("chart", "generate simple balance pie charts")+ ,("interest", "generate interest transaction entries")+ ,("irr", "calculate internal rate of return")+ ,("vty", "start the curses-style interface")+ ,("web", "start the web interface")+ ,("accounts", "list account names")+ ,("balance-csv", "output a balance report as CSV")+ ,("equity", "show a transaction entry zeroing all accounts")+ ,("print-unique", "print only transactions with unique descriptions")+ ,("register-csv", "output a register report as CSV")+ ,("rewrite", "add specified postings to matched transaction entries")+ ,("addon", "dummy add-on command for testing")+ ,("addon2", "dummy add-on command for testing")+ ,("addon3", "dummy add-on command for testing")+ ,("addon4", "dummy add-on command for testing")+ ,("addon5", "dummy add-on command for testing")+ ,("addon6", "dummy add-on command for testing")+ ,("addon7", "dummy add-on command for testing")+ ,("addon8", "dummy add-on command for testing")+ ,("addon9", "dummy add-on command for testing")+ ]++-- | Get a mode's help message as a nicely wrapped string.+showModeHelp :: Mode a -> String+showModeHelp = (showText defaultWrap :: [Text] -> String) .+ (helpText [] HelpFormatDefault :: Mode a -> [Text])++-- | Add command aliases to the command's help string.+withAliases :: String -> [String] -> String+s `withAliases` [] = s+s `withAliases` as = s ++ " (" ++ intercalate ", " as ++ ")"+-- s `withAliases` (a:[]) = s ++ " (alias: " ++ a ++ ")"+-- s `withAliases` as = s ++ " (aliases: " ++ intercalate ", " as ++ ")"+++-- help_postscript = [+-- -- "DATES can be Y/M/D or smart dates like \"last month\"."+-- -- ,"PATTERNS are regular"+-- -- ,"expressions which filter by account name. Prefix a pattern with desc: to"+-- -- ,"filter by transaction description instead, prefix with not: to negate it."+-- -- ,"When using both, not: comes last."+-- ]+++-- CliOpts++-- | Command line options, used in the @hledger@ package and above.+-- This is the \"opts\" used throughout hledger CLI code.+-- representing the options that arguments that were provided at+-- startup on the command-line.+data CliOpts = CliOpts {+ rawopts_ :: RawOpts+ ,command_ :: String+ ,file_ :: [FilePath]+ ,rules_file_ :: Maybe FilePath+ ,output_file_ :: Maybe FilePath+ ,output_format_ :: Maybe String+ ,alias_ :: [String]+ ,ignore_assertions_ :: Bool+ ,debug_ :: Int -- ^ debug level, set by @--debug[=N]@. See also 'Hledger.Utils.debugLevel'.+ ,no_new_accounts_ :: Bool -- add+ ,width_ :: Maybe String -- ^ the --width value provided, if any+ ,available_width_ :: Int -- ^ estimated usable screen width, based on+ -- 1. the COLUMNS env var, if set+ -- 2. the width reported by the terminal, if supported+ -- 3. the default (80)+ ,reportopts_ :: ReportOpts+ } deriving (Show, Data, Typeable)++instance Default CliOpts where def = defcliopts++defcliopts :: CliOpts+defcliopts = CliOpts+ def+ def+ def+ def+ def+ def+ def+ def+ def+ def+ def+ defaultWidth+ def++-- | Convert possibly encoded option values to regular unicode strings.+decodeRawOpts :: RawOpts -> RawOpts+decodeRawOpts = map (\(name',val) -> (name', fromSystemString val))++-- | Default width for hledger console output, when not otherwise specified.+defaultWidth :: Int+defaultWidth = 80++-- | Parse raw option string values to the desired final data types.+-- Any relative smart dates will be converted to fixed dates based on+-- today's date. Parsing failures will raise an error.+-- Also records the terminal width, if supported.+rawOptsToCliOpts :: RawOpts -> IO CliOpts+rawOptsToCliOpts rawopts = checkCliOpts <$> do+ ropts <- rawOptsToReportOpts rawopts+ mcolumns <- readMay <$> getEnvSafe "COLUMNS"+ mtermwidth <-+#ifdef mingw32_HOST_OS+ return Nothing+#else+ setupTermFromEnv >>= return . flip getCapability termColumns+ -- XXX Throws a SetupTermError if the terminfo database could not be read, should catch+#endif+ let availablewidth = head $ catMaybes [mcolumns, mtermwidth, Just defaultWidth]+ return defcliopts {+ rawopts_ = rawopts+ ,command_ = stringopt "command" rawopts+ ,file_ = map stripquotes $ listofstringopt "file" rawopts+ ,rules_file_ = maybestringopt "rules-file" rawopts+ ,output_file_ = maybestringopt "output-file" rawopts+ ,output_format_ = maybestringopt "output-format" rawopts+ ,alias_ = map stripquotes $ listofstringopt "alias" rawopts+ ,debug_ = intopt "debug" rawopts+ ,ignore_assertions_ = boolopt "ignore-assertions" rawopts+ ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add+ ,width_ = maybestringopt "width" rawopts+ ,available_width_ = availablewidth+ ,reportopts_ = ropts+ }++-- | Do final validation of processed opts, raising an error if there is trouble.+checkCliOpts :: CliOpts -> CliOpts+checkCliOpts opts =+ either optserror (const opts) $ do+ -- XXX move to checkReportOpts or move _format to CliOpts+ case lineFormatFromOpts $ reportopts_ opts of+ Left err -> Left $ "could not parse format option: "++err+ Right _ -> Right ()+ -- XXX check registerWidthsFromOpts opts++-- Currently only used by some extras/ scripts:+-- | Parse hledger CLI options from the command line using the given+-- cmdargs mode, and either return them or, if a help flag is present,+-- print the mode help and exit the program.+getCliOpts :: Mode RawOpts -> IO CliOpts+getCliOpts mode' = do+ args' <- getArgs+ let rawopts = decodeRawOpts $ processValue mode' args'+ opts <- rawOptsToCliOpts rawopts+ debugArgs args' opts+ -- if any (`elem` args) ["--help","-h","-?"]+ when ("help" `inRawOpts` rawopts_ opts) $+ putStr (showModeHelp mode') >> exitSuccess+ return opts+ where+ -- | Print debug info about arguments and options if --debug is present.+ debugArgs :: [String] -> CliOpts -> IO ()+ debugArgs args' opts =+ when ("--debug" `elem` args') $ do+ progname' <- getProgName+ putStrLn $ "running: " ++ progname'+ putStrLn $ "raw args: " ++ show args'+ putStrLn $ "processed opts:\n" ++ show opts+ d <- getCurrentDay+ putStrLn $ "search query: " ++ show (queryFromOpts d $ reportopts_ opts)++-- CliOpts accessors++-- | Get the account name aliases from options, if any.+aliasesFromOpts :: CliOpts -> [AccountAlias]+aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp () ("--alias "++quoteIfNeeded a) a)+ . alias_++-- | Get the (tilde-expanded, absolute) journal file path from+-- 1. options, 2. an environment variable, or 3. the default.+-- Actually, returns one or more file paths. There will be more+-- than one if multiple -f options were provided.+journalFilePathFromOpts :: CliOpts -> IO [String]+journalFilePathFromOpts opts = do+ f <- defaultJournalPath+ d <- getCurrentDirectory+ mapM (expandPath d) $ ifEmpty (file_ opts) [f]+ where+ ifEmpty [] d = d+ ifEmpty l _ = l++-- | Get the expanded, absolute output file path from options,+-- or the default (-, meaning stdout).+outputFileFromOpts :: CliOpts -> IO FilePath+outputFileFromOpts opts = do+ d <- getCurrentDirectory+ case output_file_ opts of+ Just p -> expandPath d p+ Nothing -> return "-"++defaultOutputFormat = "txt"++outputFormats =+ [defaultOutputFormat] +++ ["csv"+ ]++-- | Get the output format from the --output-format option,+-- otherwise from a recognised file extension in the --output-file option,+-- otherwise the default (txt).+outputFormatFromOpts :: CliOpts -> String+outputFormatFromOpts opts =+ case output_format_ opts of+ Just f -> f+ Nothing ->+ case filePathExtension <$> output_file_ opts of+ Just ext | ext `elem` outputFormats -> ext+ _ -> defaultOutputFormat++-- -- | Get the file name without its last extension, from a file path.+-- filePathBaseFileName :: FilePath -> String+-- filePathBaseFileName = fst . splitExtension . snd . splitFileName++-- | Get the last file extension, without the dot, from a file path.+-- May return the null string.+filePathExtension :: FilePath -> String+filePathExtension = dropWhile (=='.') . snd . splitExtension . snd . splitFileName++-- | Get the (tilde-expanded) rules file path from options, if any.+rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)+rulesFilePathFromOpts opts = do+ d <- getCurrentDirectory+ maybe (return Nothing) (fmap Just . expandPath d) $ rules_file_ opts++-- | Get the width in characters to use for console output.+-- This comes from the --width option, or the COLUMNS environment+-- variable, or (on posix platforms) the current terminal width, or 80.+-- Will raise a parse error for a malformed --width argument.+widthFromOpts :: CliOpts -> Int+widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w+widthFromOpts CliOpts{width_=Just s} =+ case runParser (read `fmap` many1 digit <* eof) () "(unknown)" s of+ Left e -> optserror $ "could not parse width option: "++show e+ Right w -> w++-- for register:++-- | Get the width in characters to use for the register command's console output,+-- and also the description column width if specified (following the main width, comma-separated).+-- The widths will be as follows:+-- @+-- no --width flag - overall width is the available width (COLUMNS, or posix terminal width, or 80); description width is unspecified (auto)+-- --width W - overall width is W, description width is auto+-- --width W,D - overall width is W, description width is D+-- @+-- Will raise a parse error for a malformed --width argument.+registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)+registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing)+registerWidthsFromOpts CliOpts{width_=Just s} =+ case runParser registerwidthp () "(unknown)" s of+ Left e -> optserror $ "could not parse width option: "++show e+ Right ws -> ws+ where+ registerwidthp :: Stream [Char] m t => ParsecT [Char] st m (Int, Maybe Int)+ registerwidthp = do+ totalwidth <- read `fmap` many1 digit+ descwidth <- optionMaybe (char ',' >> read `fmap` many1 digit)+ eof+ return (totalwidth, descwidth)++-- | Drop leading components of accounts names as specified by --drop, but only in --flat mode.+maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName+maybeAccountNameDrop opts a | tree_ opts = a+ | otherwise = accountNameDrop (drop_ opts) a++-- for balance, currently:++-- | Parse the format option if provided, possibly returning an error,+-- otherwise get the default value.+lineFormatFromOpts :: ReportOpts -> Either String StringFormat+lineFormatFromOpts = maybe (Right defaultBalanceLineFormat) parseStringFormat . format_++-- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)"+defaultBalanceLineFormat :: StringFormat+defaultBalanceLineFormat = BottomAligned [+ FormatField False (Just 20) Nothing TotalField+ , FormatLiteral " "+ , FormatField True (Just 2) Nothing DepthSpacerField+ , FormatField True Nothing Nothing AccountField+ ]++-- Other utils++-- | Get the sorted unique precise names and display names of hledger+-- add-ons found in the current user's PATH. The precise names are the+-- add-on's filename with the "hledger-" prefix removed. The display+-- names have the file extension removed also, except when it's needed+-- for disambiguation.+--+-- -- Also when there are exactly two similar names, one with the .hs or+-- -- .lhs extension and the other with the .exe extension or no+-- -- extension - presumably source and compiled versions of a haskell+-- -- script - we exclude the source version.+--+-- This function can return add-on names which shadow built-in command+-- names, but hledger will ignore these.+--+hledgerAddons :: IO ([String],[String])+hledgerAddons = do+ exes <- hledgerExecutablesInPath+ let precisenames = -- concatMap dropRedundant $+ -- groupBy (\a b -> dropExtension a == dropExtension b) $+ map stripprefix exes+ let displaynames = concatMap stripext $+ groupBy (\a b -> dropExtension a == dropExtension b) precisenames+ return (precisenames, displaynames)+ where+ stripprefix = drop (length progname + 1)+ -- dropRedundant [f,f2] | takeExtension f `elem` ["",".exe"] && takeExtension f2 `elem` [".hs",".lhs"] = [f]+ -- dropRedundant fs = fs+ stripext [f] = [dropExtension f]+ stripext fs = fs++-- | Get the sorted unique filenames of all hledger-* executables in+-- the current user's PATH. Currently these are: files in any of the+-- PATH directories, named hledger-*, with either no extension (and no+-- periods in the name) or one of the addonExtensions. Limitations:+-- we do not currently check that the file is really a file (not eg a+-- directory) or whether it has execute permission.+hledgerExecutablesInPath :: IO [String]+hledgerExecutablesInPath = do+ pathdirs <- splitOneOf "[:;]" `fmap` getEnvSafe "PATH"+ pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs+ return $ nub $ sort $ filter isHledgerExeName pathfiles+ -- XXX should exclude directories and files without execute permission.+ -- These will do a stat for each hledger-*, probably ok.+ -- But they need paths, not just filenames+ -- hledgerexes <- filterM doesFileExist hledgernamed+ -- hledgerexes' <- filterM isExecutable hledgerexes+ -- return hledgerexes++-- isExecutable f = getPermissions f >>= (return . executable)++isHledgerExeName :: String -> Bool+isHledgerExeName = isRight . parsewith hledgerexenamep+ where+ hledgerexenamep = do+ _ <- string progname+ _ <- char '-'+ _ <- many1 (noneOf ".")+ optional (string "." >> choice' (map string addonExtensions))+ eof++stripAddonExtension :: String -> String+stripAddonExtension = regexReplace re "" where re = "\\.(" ++ intercalate "|" addonExtensions ++ ")$"++addonExtensions :: [String]+addonExtensions =+ ["bat"+ ,"com"+ ,"exe"+ ,"hs"+ ,"lhs"+ ,"pl"+ ,"py"+ ,"rb"+ ,"rkt"+ ,"sh"+ -- ,""+ ]++getEnvSafe :: String -> IO String+getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "") -- XXX should catch only isDoesNotExistError e++getDirectoryContentsSafe :: FilePath -> IO [String]+getDirectoryContentsSafe d =+ (filter (not . (`elem` [".",".."])) `fmap` getDirectoryContents d) `C.catch` (\(_::C.IOException) -> return [])++-- not used:+-- -- | Print debug info about arguments and options if --debug is present.+-- debugArgs :: [String] -> CliOpts -> IO ()+-- debugArgs args opts =+-- when ("--debug" `elem` args) $ do+-- progname <- getProgName+-- putStrLn $ "running: " ++ progname+-- putStrLn $ "raw args: " ++ show args+-- putStrLn $ "processed opts:\n" ++ show opts+-- d <- getCurrentDay+-- putStrLn $ "search query: " ++ (show $ queryFromOpts d $ reportopts_ opts)++-- tests++tests_Hledger_Cli_CliOptions :: Test+tests_Hledger_Cli_CliOptions = TestList+ [+ ]
Hledger/Cli/Histogram.hs view
@@ -14,7 +14,7 @@ import Text.Printf import Hledger-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Prelude hiding (putStr) import Hledger.Utils.UTF8IOCompat (putStr)
Hledger/Cli/Incomestatement.hs view
@@ -17,7 +17,7 @@ import Text.Shakespeare.Text import Hledger-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Balance
Hledger/Cli/Main.hs view
@@ -60,7 +60,7 @@ import Hledger.Cli.Print import Hledger.Cli.Register import Hledger.Cli.Stats-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Tests import Hledger.Cli.Utils import Hledger.Cli.Version@@ -144,7 +144,7 @@ args' = moveFlagsAfterCommand args cmdargsopts = processValue (mainmode addons) args' cmdargsopts' = decodeRawOpts cmdargsopts- rawOptsToCliOpts cmdargsopts' >>= checkCliOpts+ rawOptsToCliOpts cmdargsopts' -- | A hacky workaround for cmdargs not accepting flags before the -- subcommand name: try to detect and move such flags after the@@ -186,7 +186,7 @@ -- on the raw command-line arguments, cmdarg's interpretation of -- same, and hledger-* executables in the user's PATH. A somewhat -- complex mishmash of cmdargs and custom processing, hence all the- -- debugging support and tests. See also Hledger.Cli.Options and+ -- debugging support and tests. See also Hledger.Cli.CliOptions and -- command-line.test. -- some preliminary (imperfect) argument parsing to supplement cmdargs
− Hledger/Cli/Options.hs
@@ -1,586 +0,0 @@-{-# LANGUAGE CPP, ScopedTypeVariables, DeriveDataTypeable, FlexibleContexts #-}-{-|--Common cmdargs modes and flags, a command-line options type, and-related utilities used by hledger commands.---}--module Hledger.Cli.Options (-- -- * cmdargs flags & modes- helpflags,- detailedversionflag,- inputflags,- reportflags,- outputflags,- generalflagsgroup1,- generalflagsgroup2,- generalflagsgroup3,- defMode,- defCommandMode,- defAddonCommandMode,- argsFlag,- showModeHelp,- withAliases,-- -- * CLI options- CliOpts(..),- defcliopts,- getCliOpts,- decodeRawOpts,- rawOptsToCliOpts,- checkCliOpts,- outputFormats,- defaultOutputFormat,-- -- possibly these should move into argsToCliOpts- -- * CLI option accessors- -- | These do the extra processing required for some options.- aliasesFromOpts,- journalFilePathFromOpts,- rulesFilePathFromOpts,- outputFileFromOpts,- outputFormatFromOpts,- defaultWidth,- widthFromOpts,- -- | For register:- registerWidthsFromOpts,- maybeAccountNameDrop,- -- | For balance:- lineFormatFromOpts,-- -- * Other utils- hledgerAddons,-- -- * Tests- tests_Hledger_Cli_Options--)-where--import Prelude ()-import Prelude.Compat-import qualified Control.Exception as C-import Control.Monad (when)-import Data.List.Compat-import Data.List.Split (splitOneOf)-import Data.Maybe-import Safe-import System.Console.CmdArgs-import System.Console.CmdArgs.Explicit-import System.Console.CmdArgs.Text-#ifndef mingw32_HOST_OS-import System.Console.Terminfo-#endif-import System.Directory-import System.Environment-import System.Exit (exitSuccess)-import System.FilePath-import Test.HUnit-import Text.Parsec--import Hledger-import Hledger.Data.OutputFormat as OutputFormat-import Hledger.Cli.Version----- common cmdargs flags---- | Common help flags: --help, --debug, --version...-helpflags :: [Flag RawOpts]-helpflags = [- flagNone ["help","h"] (setboolopt "help") "show general help or (after command) command help"- -- ,flagNone ["browse-args"] (setboolopt "browse-args") "use a web UI to select options and build up a command line"- ,flagReq ["debug"] (\s opts -> Right $ setopt "debug" s opts) "N" "show debug output if N is 1-9 (default: 0)"- ,flagNone ["version"] (setboolopt "version") "show version information"- ]---- | A hidden flag, just for the hledger executable.-detailedversionflag :: Flag RawOpts-detailedversionflag = flagNone ["version+"] (setboolopt "version+") "show version information with extra detail"---- | Common input-related flags: --file, --rules-file, --alias...-inputflags :: [Flag RawOpts]-inputflags = [- flagReq ["file","f"] (\s opts -> Right $ setopt "file" s opts) "FILE" "use a different input file. For stdin, use -"- ,flagReq ["rules-file"] (\s opts -> Right $ setopt "rules-file" s opts) "RFILE" "CSV conversion rules file (default: FILE.rules)"- ,flagReq ["alias"] (\s opts -> Right $ setopt "alias" s opts) "OLD=NEW" "display accounts named OLD as NEW"- ,flagNone ["ignore-assertions"] (setboolopt "ignore-assertions") "ignore any balance assertions in the journal"- ]---- | Common report-related flags: --period, --cost, etc.-reportflags :: [Flag RawOpts]-reportflags = [- flagReq ["begin","b"] (\s opts -> Right $ setopt "begin" s opts) "DATE" "include postings/txns on or after this date"- ,flagReq ["end","e"] (\s opts -> Right $ setopt "end" s opts) "DATE" "include postings/txns before this date"- ,flagNone ["daily","D"] (setboolopt "daily") "multiperiod/multicolumn report by day"- ,flagNone ["weekly","W"] (setboolopt "weekly") "multiperiod/multicolumn report by week"- ,flagNone ["monthly","M"] (setboolopt "monthly") "multiperiod/multicolumn report by month"- ,flagNone ["quarterly","Q"] (setboolopt "quarterly") "multiperiod/multicolumn report by quarter"- ,flagNone ["yearly","Y"] (setboolopt "yearly") "multiperiod/multicolumn report by year"- ,flagReq ["period","p"] (\s opts -> Right $ setopt "period" s opts) "PERIODEXP" "set start date, end date, and/or reporting interval all at once (overrides the flags above)"- ,flagNone ["date2","aux-date"] (setboolopt "date2") "use postings/txns' secondary dates instead"-- ,flagNone ["cleared","C"] (setboolopt "cleared") "include only cleared postings/txns"- ,flagNone ["pending"] (setboolopt "pending") "include only pending postings/txns"- ,flagNone ["uncleared","U"] (setboolopt "uncleared") "include only uncleared (and pending) postings/txns"- ,flagNone ["real","R"] (setboolopt "real") "include only non-virtual postings"- ,flagReq ["depth"] (\s opts -> Right $ setopt "depth" s opts) "N" "hide accounts/postings deeper than N"- ,flagNone ["empty","E"] (setboolopt "empty") "show empty/zero things which are normally omitted"- ,flagNone ["cost","B"] (setboolopt "cost") "show amounts in their cost price's commodity"- ]---- | Common output-related flags: --output-file, --output-format...-outputflags = [- flagReq ["output-file","o"] (\s opts -> Right $ setopt "output-file" s opts) "FILE[.FMT]" "write output to FILE instead of stdout. A recognised FMT suffix influences the format."- ,flagReq ["output-format","O"] (\s opts -> Right $ setopt "output-format" s opts) "FMT" "select the output format. Supported formats: txt, csv."- ]--argsFlag :: FlagHelp -> Arg RawOpts-argsFlag desc = flagArg (\s opts -> Right $ setopt "args" s opts) desc--generalflagstitle :: String-generalflagstitle = "\nGeneral flags"--generalflagsgroup1, generalflagsgroup2, generalflagsgroup3 :: (String, [Flag RawOpts])-generalflagsgroup1 = (generalflagstitle, inputflags ++ reportflags ++ helpflags)-generalflagsgroup2 = (generalflagstitle, inputflags ++ helpflags)-generalflagsgroup3 = (generalflagstitle, helpflags)---- cmdargs mode constructors---- | A basic mode template.-defMode :: Mode RawOpts-defMode = Mode {- modeNames = []- ,modeHelp = ""- ,modeHelpSuffix = []- ,modeValue = []- ,modeCheck = Right- ,modeReform = const Nothing- ,modeExpandAt = True- ,modeGroupFlags = Group {- groupNamed = []- ,groupUnnamed = [- flagNone ["help","h","?"] (setboolopt "help") "Show command help."- ]- ,groupHidden = []- }- ,modeArgs = ([], Nothing)- ,modeGroupModes = toGroup []- }---- | A basic subcommand mode with the given command name(s).-defCommandMode :: [Name] -> Mode RawOpts-defCommandMode names = defMode {- modeNames=names- ,modeValue=[("command", headDef "" names)]- ,modeArgs = ([], Just $ argsFlag "[PATTERNS]")- }---- | A basic subcommand mode suitable for an add-on command.-defAddonCommandMode :: Name -> Mode RawOpts-defAddonCommandMode addon = defMode {- modeNames = [addon]- ,modeHelp = fromMaybe "" $ lookup (stripAddonExtension addon) standardAddonsHelp- ,modeValue=[("command",addon)]- ,modeGroupFlags = Group {- groupUnnamed = []- ,groupHidden = []- ,groupNamed = [generalflagsgroup1]- }- ,modeArgs = ([], Just $ argsFlag "[ARGS]")- }---- | Built-in descriptions for some of the known external addons,--- since we don't currently have any way to ask them.-standardAddonsHelp :: [(String,String)]-standardAddonsHelp = [- ("chart", "generate simple balance pie charts")- ,("interest", "generate interest transaction entries")- ,("irr", "calculate internal rate of return")- ,("vty", "start the curses-style interface")- ,("web", "start the web interface")- ,("accounts", "list account names")- ,("balance-csv", "output a balance report as CSV")- ,("equity", "show a transaction entry zeroing all accounts")- ,("print-unique", "print only transactions with unique descriptions")- ,("register-csv", "output a register report as CSV")- ,("rewrite", "add specified postings to matched transaction entries")- ,("addon", "dummy add-on command for testing")- ,("addon2", "dummy add-on command for testing")- ,("addon3", "dummy add-on command for testing")- ,("addon4", "dummy add-on command for testing")- ,("addon5", "dummy add-on command for testing")- ,("addon6", "dummy add-on command for testing")- ,("addon7", "dummy add-on command for testing")- ,("addon8", "dummy add-on command for testing")- ,("addon9", "dummy add-on command for testing")- ]---- | Get a mode's help message as a nicely wrapped string.-showModeHelp :: Mode a -> String-showModeHelp = (showText defaultWrap :: [Text] -> String) .- (helpText [] HelpFormatDefault :: Mode a -> [Text])---- | Add command aliases to the command's help string.-withAliases :: String -> [String] -> String-s `withAliases` [] = s-s `withAliases` as = s ++ " (" ++ intercalate ", " as ++ ")"--- s `withAliases` (a:[]) = s ++ " (alias: " ++ a ++ ")"--- s `withAliases` as = s ++ " (aliases: " ++ intercalate ", " as ++ ")"----- help_postscript = [--- -- "DATES can be Y/M/D or smart dates like \"last month\"."--- -- ,"PATTERNS are regular"--- -- ,"expressions which filter by account name. Prefix a pattern with desc: to"--- -- ,"filter by transaction description instead, prefix with not: to negate it."--- -- ,"When using both, not: comes last."--- ]----- CliOpts---- | Command line options, used in the @hledger@ package and above.--- This is the \"opts\" used throughout hledger CLI code.--- representing the options that arguments that were provided at--- startup on the command-line.-data CliOpts = CliOpts {- rawopts_ :: RawOpts- ,command_ :: String- ,file_ :: [FilePath]- ,rules_file_ :: Maybe FilePath- ,output_file_ :: Maybe FilePath- ,output_format_ :: Maybe String- ,alias_ :: [String]- ,ignore_assertions_ :: Bool- ,debug_ :: Int -- ^ debug level, set by @--debug[=N]@. See also 'Hledger.Utils.debugLevel'.- ,no_new_accounts_ :: Bool -- add- ,width_ :: Maybe String -- ^ the --width value provided, if any- ,available_width_ :: Int -- ^ estimated usable screen width, based on- -- 1. the COLUMNS env var, if set- -- 2. the width reported by the terminal, if supported- -- 3. the default (80)- ,reportopts_ :: ReportOpts- } deriving (Show, Data, Typeable)--instance Default CliOpts where def = defcliopts--defcliopts :: CliOpts-defcliopts = CliOpts- def- def- def- def- def- def- def- def- def- def- def- defaultWidth- def---- | Convert possibly encoded option values to regular unicode strings.-decodeRawOpts :: RawOpts -> RawOpts-decodeRawOpts = map (\(name',val) -> (name', fromSystemString val))---- | Default width for hledger console output, when not otherwise specified.-defaultWidth :: Int-defaultWidth = 80---- | Parse raw option string values to the desired final data types.--- Any relative smart dates will be converted to fixed dates based on--- today's date. Parsing failures will raise an error.--- Also records the terminal width, if supported.-rawOptsToCliOpts :: RawOpts -> IO CliOpts-rawOptsToCliOpts rawopts = do- ropts <- rawOptsToReportOpts rawopts- mcolumns <- readMay <$> getEnvSafe "COLUMNS"- mtermwidth <--#ifdef mingw32_HOST_OS- return Nothing-#else- setupTermFromEnv >>= return . flip getCapability termColumns- -- XXX Throws a SetupTermError if the terminfo database could not be read, should catch-#endif- let availablewidth = head $ catMaybes [mcolumns, mtermwidth, Just defaultWidth]- return defcliopts {- rawopts_ = rawopts- ,command_ = stringopt "command" rawopts- ,file_ = map stripquotes $ listofstringopt "file" rawopts- ,rules_file_ = maybestringopt "rules-file" rawopts- ,output_file_ = maybestringopt "output-file" rawopts- ,output_format_ = maybestringopt "output-format" rawopts- ,alias_ = map stripquotes $ listofstringopt "alias" rawopts- ,debug_ = intopt "debug" rawopts- ,ignore_assertions_ = boolopt "ignore-assertions" rawopts- ,no_new_accounts_ = boolopt "no-new-accounts" rawopts -- add- ,width_ = maybestringopt "width" rawopts- ,available_width_ = availablewidth- ,reportopts_ = ropts- }---- | Do final validation of processed opts, raising an error if there is trouble.-checkCliOpts :: CliOpts -> IO CliOpts -- or pure..-checkCliOpts opts@CliOpts{reportopts_=ropts} = do- case lineFormatFromOpts ropts of- Left err -> optserror $ "could not parse format option: "++err- Right _ -> return ()- -- XXX check registerWidthsFromOpts opts- return opts---- Currently only used by some extras/ scripts:--- | Parse hledger CLI options from the command line using the given--- cmdargs mode, and either return them or, if a help flag is present,--- print the mode help and exit the program.-getCliOpts :: Mode RawOpts -> IO CliOpts-getCliOpts mode' = do- args' <- getArgs- let rawopts = decodeRawOpts $ processValue mode' args'- opts <- rawOptsToCliOpts rawopts >>= checkCliOpts- debugArgs args' opts- -- if any (`elem` args) ["--help","-h","-?"]- when ("help" `inRawOpts` rawopts_ opts) $- putStr (showModeHelp mode') >> exitSuccess- return opts- where- -- | Print debug info about arguments and options if --debug is present.- debugArgs :: [String] -> CliOpts -> IO ()- debugArgs args' opts =- when ("--debug" `elem` args') $ do- progname' <- getProgName- putStrLn $ "running: " ++ progname'- putStrLn $ "raw args: " ++ show args'- putStrLn $ "processed opts:\n" ++ show opts- d <- getCurrentDay- putStrLn $ "search query: " ++ show (queryFromOpts d $ reportopts_ opts)---- CliOpts accessors---- | Get the account name aliases from options, if any.-aliasesFromOpts :: CliOpts -> [AccountAlias]-aliasesFromOpts = map (\a -> fromparse $ runParser accountaliasp () ("--alias "++quoteIfNeeded a) a)- . alias_---- | Get the (tilde-expanded, absolute) journal file path from--- 1. options, 2. an environment variable, or 3. the default.--- Actually, returns one or more file paths. There will be more--- than one if multiple -f options were provided.-journalFilePathFromOpts :: CliOpts -> IO [String]-journalFilePathFromOpts opts = do- f <- defaultJournalPath- d <- getCurrentDirectory- mapM (expandPath d) $ ifEmpty (file_ opts) [f]- where- ifEmpty [] d = d- ifEmpty l _ = l---- | Get the expanded, absolute output file path from options,--- or the default (-, meaning stdout).-outputFileFromOpts :: CliOpts -> IO FilePath-outputFileFromOpts opts = do- d <- getCurrentDirectory- case output_file_ opts of- Just p -> expandPath d p- Nothing -> return "-"--defaultOutputFormat = "txt"--outputFormats =- [defaultOutputFormat] ++- ["csv"- ]---- | Get the output format from the --output-format option,--- otherwise from a recognised file extension in the --output-file option,--- otherwise the default (txt).-outputFormatFromOpts :: CliOpts -> String-outputFormatFromOpts opts =- case output_format_ opts of- Just f -> f- Nothing ->- case filePathExtension <$> output_file_ opts of- Just ext | ext `elem` outputFormats -> ext- _ -> defaultOutputFormat---- -- | Get the file name without its last extension, from a file path.--- filePathBaseFileName :: FilePath -> String--- filePathBaseFileName = fst . splitExtension . snd . splitFileName---- | Get the last file extension, without the dot, from a file path.--- May return the null string.-filePathExtension :: FilePath -> String-filePathExtension = dropWhile (=='.') . snd . splitExtension . snd . splitFileName---- | Get the (tilde-expanded) rules file path from options, if any.-rulesFilePathFromOpts :: CliOpts -> IO (Maybe FilePath)-rulesFilePathFromOpts opts = do- d <- getCurrentDirectory- maybe (return Nothing) (fmap Just . expandPath d) $ rules_file_ opts---- | Get the width in characters to use for console output.--- This comes from the --width option, or the COLUMNS environment--- variable, or (on posix platforms) the current terminal width, or 80.--- Will raise a parse error for a malformed --width argument.-widthFromOpts :: CliOpts -> Int-widthFromOpts CliOpts{width_=Nothing, available_width_=w} = w-widthFromOpts CliOpts{width_=Just s} =- case runParser (read `fmap` many1 digit <* eof) () "(unknown)" s of- Left e -> optserror $ "could not parse width option: "++show e- Right w -> w---- for register:---- | Get the width in characters to use for the register command's console output,--- and also the description column width if specified (following the main width, comma-separated).--- The widths will be as follows:--- @--- no --width flag - overall width is the available width (COLUMNS, or posix terminal width, or 80); description width is unspecified (auto)--- --width W - overall width is W, description width is auto--- --width W,D - overall width is W, description width is D--- @--- Will raise a parse error for a malformed --width argument.-registerWidthsFromOpts :: CliOpts -> (Int, Maybe Int)-registerWidthsFromOpts CliOpts{width_=Nothing, available_width_=w} = (w, Nothing)-registerWidthsFromOpts CliOpts{width_=Just s} =- case runParser registerwidthp () "(unknown)" s of- Left e -> optserror $ "could not parse width option: "++show e- Right ws -> ws- where- registerwidthp :: Stream [Char] m t => ParsecT [Char] st m (Int, Maybe Int)- registerwidthp = do- totalwidth <- read `fmap` many1 digit- descwidth <- optionMaybe (char ',' >> read `fmap` many1 digit)- eof- return (totalwidth, descwidth)---- | Drop leading components of accounts names as specified by --drop, but only in --flat mode.-maybeAccountNameDrop :: ReportOpts -> AccountName -> AccountName-maybeAccountNameDrop opts a | tree_ opts = a- | otherwise = accountNameDrop (drop_ opts) a---- for balance, currently:---- | Parse the format option if provided, possibly returning an error,--- otherwise get the default value.-lineFormatFromOpts :: ReportOpts -> Either String [OutputFormat]-lineFormatFromOpts = maybe (Right defaultBalanceLineFormat) parseStringFormat . format_---- | Default line format for balance report: "%20(total) %2(depth_spacer)%-(account)"-defaultBalanceLineFormat :: [OutputFormat]-defaultBalanceLineFormat = [- FormatField False (Just 20) Nothing TotalField- , FormatLiteral " "- , FormatField True (Just 2) Nothing DepthSpacerField- , FormatField True Nothing Nothing AccountField- ]---- Other utils---- | Get the sorted unique precise names and display names of hledger--- add-ons found in the current user's PATH. The precise names are the--- add-on's filename with the "hledger-" prefix removed. The display--- names have the file extension removed also, except when it's needed--- for disambiguation.------ -- Also when there are exactly two similar names, one with the .hs or--- -- .lhs extension and the other with the .exe extension or no--- -- extension - presumably source and compiled versions of a haskell--- -- script - we exclude the source version.------ This function can return add-on names which shadow built-in command--- names, but hledger will ignore these.----hledgerAddons :: IO ([String],[String])-hledgerAddons = do- exes <- hledgerExecutablesInPath- let precisenames = -- concatMap dropRedundant $- -- groupBy (\a b -> dropExtension a == dropExtension b) $- map stripprefix exes- let displaynames = concatMap stripext $- groupBy (\a b -> dropExtension a == dropExtension b) precisenames- return (precisenames, displaynames)- where- stripprefix = drop (length progname + 1)- -- dropRedundant [f,f2] | takeExtension f `elem` ["",".exe"] && takeExtension f2 `elem` [".hs",".lhs"] = [f]- -- dropRedundant fs = fs- stripext [f] = [dropExtension f]- stripext fs = fs---- | Get the sorted unique filenames of all hledger-* executables in--- the current user's PATH. Currently these are: files in any of the--- PATH directories, named hledger-*, with either no extension (and no--- periods in the name) or one of the addonExtensions. Limitations:--- we do not currently check that the file is really a file (not eg a--- directory) or whether it has execute permission.-hledgerExecutablesInPath :: IO [String]-hledgerExecutablesInPath = do- pathdirs <- splitOneOf "[:;]" `fmap` getEnvSafe "PATH"- pathfiles <- concat `fmap` mapM getDirectoryContentsSafe pathdirs- return $ nub $ sort $ filter isHledgerExeName pathfiles- -- XXX should exclude directories and files without execute permission.- -- These will do a stat for each hledger-*, probably ok.- -- But they need paths, not just filenames- -- hledgerexes <- filterM doesFileExist hledgernamed- -- hledgerexes' <- filterM isExecutable hledgerexes- -- return hledgerexes---- isExecutable f = getPermissions f >>= (return . executable)--isHledgerExeName :: String -> Bool-isHledgerExeName = isRight . parsewith hledgerexenamep- where- hledgerexenamep = do- _ <- string progname- _ <- char '-'- _ <- many1 (noneOf ".")- optional (string "." >> choice' (map string addonExtensions))- eof--stripAddonExtension :: String -> String-stripAddonExtension = regexReplace re "" where re = "\\.(" ++ intercalate "|" addonExtensions ++ ")$"--addonExtensions :: [String]-addonExtensions =- ["bat"- ,"com"- ,"exe"- ,"hs"- ,"lhs"- ,"pl"- ,"py"- ,"rb"- ,"rkt"- ,"sh"- -- ,""- ]--getEnvSafe :: String -> IO String-getEnvSafe v = getEnv v `C.catch` (\(_::C.IOException) -> return "") -- XXX should catch only isDoesNotExistError e--getDirectoryContentsSafe :: FilePath -> IO [String]-getDirectoryContentsSafe d =- (filter (not . (`elem` [".",".."])) `fmap` getDirectoryContents d) `C.catch` (\(_::C.IOException) -> return [])---- not used:--- -- | Print debug info about arguments and options if --debug is present.--- debugArgs :: [String] -> CliOpts -> IO ()--- debugArgs args opts =--- when ("--debug" `elem` args) $ do--- progname <- getProgName--- putStrLn $ "running: " ++ progname--- putStrLn $ "raw args: " ++ show args--- putStrLn $ "processed opts:\n" ++ show opts--- d <- getCurrentDay--- putStrLn $ "search query: " ++ (show $ queryFromOpts d $ reportopts_ opts)---- tests--tests_Hledger_Cli_Options :: Test-tests_Hledger_Cli_Options = TestList- [- ]
Hledger/Cli/Print.hs view
@@ -7,6 +7,7 @@ module Hledger.Cli.Print ( printmode ,print'+ ,entriesReportAsText ,tests_Hledger_Cli_Print ) where@@ -17,14 +18,22 @@ import Text.CSV import Hledger-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Utils+import Hledger.Cli.Add ( transactionsSimilarTo ) printmode = (defCommandMode $ ["print"] ++ aliases) { modeHelp = "show transaction entries" `withAliases` aliases ,modeGroupFlags = Group {- groupUnnamed = outputflags+ groupUnnamed = [+ let matcharg = "STR"+ in+ flagReq ["match","m"] (\s opts -> Right $ setopt "match" s opts) matcharg+ ("show the transaction whose description is most similar to "++matcharg+ ++ ", and is most recent")+ ]+ ++ outputflags ,groupHidden = [] ,groupNamed = [generalflagsgroup1] }@@ -33,7 +42,13 @@ -- | Print journal transactions in standard format. print' :: CliOpts -> Journal -> IO ()-print' opts@CliOpts{reportopts_=ropts} j = do+print' opts j = do+ case maybestringopt "match" $ rawopts_ opts of+ Nothing -> printEntries opts j+ Just desc -> printMatch opts j desc++printEntries :: CliOpts -> Journal -> IO ()+printEntries opts@CliOpts{reportopts_=ropts} j = do d <- getCurrentDay let q = queryFromOpts d ropts fmt = outputFormatFromOpts opts@@ -119,6 +134,29 @@ status = show $ pstatus p account = showAccountName Nothing (ptype p) (paccount p) comment = chomp $ strip $ pcomment p++-- --match++-- | Print the transaction most closely and recently matching a description+-- (and the query, if any).+printMatch :: CliOpts -> Journal -> String -> IO ()+printMatch CliOpts{reportopts_=ropts} j desc = do+ d <- getCurrentDay+ let q = queryFromOpts d ropts+ case similarTransaction' j q desc of+ Nothing -> putStrLn "no matches found."+ Just t -> putStr $ showTransactionUnelided t++ where+ -- Identify the closest recent match for this description in past transactions.+ similarTransaction' :: Journal -> Query -> String -> Maybe Transaction+ similarTransaction' j q desc+ | null historymatches = Nothing+ | otherwise = Just $ snd $ head historymatches+ where+ historymatches = transactionsSimilarTo j q desc++-- tests tests_Hledger_Cli_Print = TestList [] -- tests_showTransactions
Hledger/Cli/Register.hs view
@@ -9,6 +9,7 @@ registermode ,register ,postingsReportAsText+ ,postingsReportItemAsText -- ,showPostingWithBalanceForVty ,tests_Hledger_Cli_Register ) where@@ -18,10 +19,9 @@ import System.Console.CmdArgs.Explicit import Text.CSV import Test.HUnit-import Text.Printf import Hledger-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Cli.Utils @@ -81,7 +81,12 @@ -- | Render a register report as plain text suitable for console output. postingsReportAsText :: CliOpts -> PostingsReport -> String-postingsReportAsText opts = unlines . map (postingsReportItemAsText opts) . snd+postingsReportAsText opts (_,items) = unlines $ map (postingsReportItemAsText opts amtwidth balwidth) items+ where+ amtwidth = maximum $ 12 : map (strWidth . showMixedAmount . itemamt) items+ balwidth = maximum $ 12 : map (strWidth . showMixedAmount . itembal) items+ itemamt (_,_,_,Posting{pamount=a},_) = a+ itembal (_,_,_,_,a) = a tests_postingsReportAsText = [ "postingsReportAsText" ~: do@@ -112,24 +117,52 @@ -- -- date and description are shown for the first posting of a transaction only. ---postingsReportItemAsText :: CliOpts -> PostingsReportItem -> String-postingsReportItemAsText opts (mdate, menddate, mdesc, p, b) =+-- Returns a string which can be multi-line, eg if the running balance+-- has multiple commodities. Does not yet support formatting control+-- like balance reports.+--+postingsReportItemAsText :: CliOpts -> Int -> Int -> PostingsReportItem -> String+postingsReportItemAsText opts preferredamtwidth preferredbalwidth (mdate, menddate, mdesc, p, b) =+ -- use elide*Width to be wide-char-aware+ -- trace (show (totalwidth, datewidth, descwidth, acctwidth, amtwidth, balwidth)) $ intercalate "\n" $- [printf ("%-"++datew++"s %-"++descw++"s %-"++acctw++"s %"++amtw++"s %"++balw++"s")- date desc acct amtfirstline balfirstline]+ [concat [fitString (Just datewidth) (Just datewidth) True True date+ ," "+ ,fitString (Just descwidth) (Just descwidth) True True desc+ ," "+ ,fitString (Just acctwidth) (Just acctwidth) True True acct+ ," "+ ,fitString (Just amtwidth) (Just amtwidth) True False amtfirstline+ ," "+ ,fitString (Just balwidth) (Just balwidth) True False balfirstline+ ]] ++- [printf (spacer ++ "%"++amtw++"s %"++balw++"s") a b | (a,b) <- zip amtrest balrest ]-+ [concat [spacer+ ,fitString (Just amtwidth) (Just amtwidth) True False a+ ," "+ ,fitString (Just balwidth) (Just balwidth) True False b+ ]+ | (a,b) <- zip amtrest balrest+ ] where -- calculate widths (totalwidth,mdescwidth) = registerWidthsFromOpts opts- amtwidth = 12- balwidth = 12 (datewidth, date) = case (mdate,menddate) of (Just _, Just _) -> (21, showDateSpan (DateSpan mdate menddate)) (Nothing, Just _) -> (21, "") (Just d, Nothing) -> (10, showDate d) _ -> (10, "")+ (amtwidth, balwidth)+ | shortfall <= 0 = (preferredamtwidth, preferredbalwidth)+ | otherwise = (adjustedamtwidth, adjustedbalwidth)+ where+ mincolwidth = 2 -- columns always show at least an ellipsis+ maxamtswidth = max 0 (totalwidth - (datewidth + 1 + mincolwidth + 2 + mincolwidth + 2 + 2))+ shortfall = (preferredamtwidth + preferredbalwidth) - maxamtswidth+ amtwidthproportion = fromIntegral preferredamtwidth / fromIntegral (preferredamtwidth + preferredbalwidth)+ adjustedamtwidth = round $ amtwidthproportion * fromIntegral maxamtswidth+ adjustedbalwidth = maxamtswidth - adjustedamtwidth+ remaining = totalwidth - (datewidth + 1 + 2 + amtwidth + 2 + balwidth) (descwidth, acctwidth) | hasinterval = (0, remaining - 2)@@ -137,16 +170,16 @@ where hasinterval = isJust menddate w = fromMaybe ((remaining - 2) `div` 2) mdescwidth- [datew,descw,acctw,amtw,balw] = map show [datewidth,descwidth,acctwidth,amtwidth,balwidth] -- gather content- desc = maybe "" (take descwidth . elideRight descwidth) mdesc+ desc = fromMaybe "" mdesc acct = parenthesise $ elideAccountName awidth $ paccount p where- (parenthesise, awidth) = case ptype p of- BalancedVirtualPosting -> (\s -> "["++s++"]", acctwidth-2)- VirtualPosting -> (\s -> "("++s++")", acctwidth-2)- _ -> (id,acctwidth)+ (parenthesise, awidth) =+ case ptype p of+ BalancedVirtualPosting -> (\s -> "["++s++"]", acctwidth-2)+ VirtualPosting -> (\s -> "("++s++")", acctwidth-2)+ _ -> (id,acctwidth) amt = showMixedAmountWithoutPrice $ pamount p bal = showMixedAmountWithoutPrice b -- alternate behaviour, show null amounts as 0 instead of blank@@ -158,9 +191,6 @@ (amtfirstline:amtrest) = take numlines $ amtlines ++ repeat "" -- posting amount is top-aligned (balfirstline:balrest) = take numlines $ replicate (numlines - ballen) "" ++ ballines -- balance amount is bottom-aligned spacer = replicate (totalwidth - (amtwidth + 2 + balwidth)) ' '---- XXX--- showPostingWithBalanceForVty showtxninfo p b = postingsReportItemAsText defreportopts $ mkpostingsReportItem showtxninfo p b tests_Hledger_Cli_Register :: Test tests_Hledger_Cli_Register = TestList
Hledger/Cli/Stats.hs view
@@ -21,7 +21,7 @@ import qualified Data.Map as Map import Hledger-import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Prelude hiding (putStr) import Hledger.Cli.Utils (writeOutput)
Hledger/Cli/Utils.hs view
@@ -53,7 +53,7 @@ import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) #endif -import Hledger.Cli.Options+import Hledger.Cli.CliOptions import Hledger.Data import Hledger.Read import Hledger.Utils
+ README.md view
@@ -0,0 +1,40 @@+# hledger++## lightweight, portable, dependable accounting tools++hledger is a computer program for easily tracking money, time, or other commodities,+on unix, mac and windows (and web-capable mobile devices, to some extent).++It is first a command-line tool, but there are also curses-style and+web interfaces, and a Haskell library+(http://hackage.haskell.org/package/hledger-lib) for building your own+programs and scripts (hledger is written in Haskell). hledger was+inspired by and is largely compatible with Ledger. hledger is free+software available under the GNU General Public License v3+.++hledger aims to help both computer experts and regular folks+to gain clarity and control in their finances and time management,+but currently it is a bit more suited to techies.+I use it every day to:++- track spending and income+- see time reports by day/week/month/project+- get accurate numbers for client billing and tax filing+- track invoices++Though limited in features, hledger is lightweight, usable and reliable.+For some, it is a simpler, less distracting, more future-proof alternative to Quicken or GnuCash.++For more, see http://hledger.org.++[](http://www.gnu.org/licenses/gpl.html)+[](http://hackage.haskell.org/package/hledger)+<!-- [](https://github.com/simonmichael/hledger/releases) -->+<!-- [](https://github.com/simonmichael/hledger/releases) -->+<!-- []() -->++[](https://travis-ci.org/simonmichael/hledger)+[](http://packdeps.haskellers.com/feed?needle=hledger)+[](http://bugs.hledger.org)+[](https://github.com/simonmichael/hledger/issues?q=label:bounty)+
+ Text/Tabular/AsciiWide.hs view
@@ -0,0 +1,75 @@+-- | Text.Tabular.AsciiArt from tabular-0.2.2.7, modified to treat+-- wide characters as double width.++module Text.Tabular.AsciiWide where++import Data.List (intersperse, transpose)+import Text.Tabular+import Hledger.Utils.String++-- | for simplicity, we assume that each cell is rendered+-- on a single line+render :: (rh -> String)+ -> (ch -> String)+ -> (a -> String)+ -> Table rh ch a+ -> String+render fr fc f (Table rh ch cells) =+ unlines $ [ bar SingleLine -- +--------------------------------------++ , renderColumns sizes ch2+ , bar DoubleLine -- +======================================++ ] +++ (renderRs $ fmap renderR $ zipHeader [] cells $ fmap fr rh) +++ [ bar SingleLine ] -- +--------------------------------------++ where+ bar = concat . renderHLine sizes ch2+ -- ch2 and cell2 include the row and column labels+ ch2 = Group DoubleLine [Header "", fmap fc ch]+ cells2 = headerContents ch2+ : zipWith (\h cs -> h : map f cs) rhStrings cells+ --+ renderR (cs,h) = renderColumns sizes $ Group DoubleLine+ [ Header h+ , fmap fst $ zipHeader "" (map f cs) ch]+ rhStrings = map fr $ headerContents rh+ -- maximum width for each column+ sizes = map (maximum . map strWidth) . transpose $ cells2+ renderRs (Header s) = [s]+ renderRs (Group p hs) = concat . intersperse sep . map renderRs $ hs+ where sep = renderHLine sizes ch2 p++-- | We stop rendering on the shortest list!+renderColumns :: [Int] -- ^ max width for each column+ -> Header String+ -> String+renderColumns is h = "| " ++ coreLine ++ " |"+ where+ coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h+ helper = either hsep (uncurry padLeftWide)+ hsep :: Properties -> String+ hsep NoLine = " "+ hsep SingleLine = " | "+ hsep DoubleLine = " || "++renderHLine :: [Int] -- ^ width specifications+ -> Header String+ -> Properties+ -> [String]+renderHLine _ _ NoLine = []+renderHLine w h SingleLine = [renderHLine' w '-' h]+renderHLine w h DoubleLine = [renderHLine' w '=' h]++renderHLine' :: [Int] -> Char -> Header String -> String+renderHLine' is sep h = [ '+', sep ] ++ coreLine ++ [sep, '+']+ where+ coreLine = concatMap helper $ flattenHeader $ zipHeader 0 is h+ helper = either vsep dashes+ dashes (i,_) = replicate i sep+ vsep NoLine = [sep]+ vsep SingleLine = sep : "+" ++ [sep]+ vsep DoubleLine = sep : "++" ++ [sep]++-- padLeft :: Int -> String -> String+-- padLeft l s = padding ++ s+-- where padding = replicate (l - length s) ' '+
+ bench/SimpleBench.hs view
@@ -0,0 +1,178 @@+-- a quick librarification of tools/simplebench.hs for cabal benchmarking++-- #!/usr/bin/env runhaskell+{- +bench.hs - simple benchmarking of command-line programs.+Requires html and tabular.+Simon Michael 2008-2015++Example:++$ simplebench.hs --help+...+$ cat - >bench.tests+-f sample.ledger -s balance+-f ~/.ledger -s balance+$ simplebench.hs -v hledger "ledger --no-cache" ledger+Using bench.tests+Running 2 tests 2 times in . with 3 executables at 2008-11-26 18:52:15.776357 UTC:+1: hledger -f sample.ledger -s balance [0.02s]+2: hledger -f sample.ledger -s balance [0.01s]+1: ledger --no-cache -f sample.ledger -s balance [0.02s]+2: ledger --no-cache -f sample.ledger -s balance [0.02s]+1: ledger -f sample.ledger -s balance [0.02s]+2: ledger -f sample.ledger -s balance [0.02s]+1: hledger -f ~/.ledger -s balance [3.56s]+2: hledger -f ~/.ledger -s balance [3.56s]+1: ledger --no-cache -f ~/.ledger -s balance [0.10s]+2: ledger --no-cache -f ~/.ledger -s balance [0.10s]+1: ledger -f ~/.ledger -s balance [0.10s]+2: ledger -f ~/.ledger -s balance [0.10s]++Summary (best iteration):++ || hledger | ledger --no-cache | ledger+============================++=========+===================+=======+-f sample.ledger -s balance || 0.01 | 0.02 | 0.02+ -f ~/.ledger -s balance || 3.56 | 0.10 | 0.10++-}++module SimpleBench+where++import Data.List+import System.Environment+-- import System.FilePath+import System.Process+import System.IO+import Text.Tabular+import qualified Text.Tabular.AsciiArt as TA+-- import qualified Text.Tabular.Html as TH+-- import Text.Html ((+++), renderHtml, stringToHtml)+import System.Exit+import Text.Printf+import Data.Time.Clock+import Data.Time.Format ()+import Control.Monad+import System.Console.GetOpt++usagehdr = "bench [-f testsfile] [-n iterations] [-p precision] executable1 [executable2 ...]\n" +++ "\n" +++ "Run some functional tests with each of the specified executables,\n" +++ "where a test is \"zero or more arguments supported by all executables\",\n" +++ "and report the best execution times.\n"+ +options = [+ Option "f" ["testsfile"] (ReqArg File "testsfile") "file containing tests, one per line, default: bench.tests"+ ,Option "n" ["iterations"] (ReqArg Num "iterations") "number of test iterations to run, default: 1"+ ,Option "p" ["precision"] (ReqArg Prec "precision") "show times with this precision, default: 2"+ ,Option "v" ["verbose"] (NoArg Verbose) "show intermediate results"+ ,Option "h" ["help"] (NoArg Help) "show this help"+ ] ++usageftr = "\n" +++ "Tips:\n" +++ "- executables may have arguments if enclosed in quotes\n" +++ "- tests can be commented out with #\n" +++ "- results are saved in benchresults.{html,txt}\n"++usage = usageInfo usagehdr options ++ usageftr++-- an option value+data Opt = File {value::String} + | Num {value::String} + | Prec {value::String} +-- I don't know how optValuesForConstructor etc. can have that +-- type signature with these, but it works..+-- | Some Int+ | Verbose+ | Help+ deriving (Eq,Show)++-- option value getters.+fileopt :: [Opt] -> String+fileopt = optValueWithDefault File "bench.tests"++precisionopt :: [Opt] -> Int+precisionopt = read . optValueWithDefault Prec "2"++numopt :: [Opt] -> Int+numopt = read . optValueWithDefault Num "1"++verboseopt :: [Opt] -> Bool+verboseopt = (Verbose `elem`)++-- options utilities+parseargs :: [String] -> ([Opt],[String])+parseargs as =+ case (getOpt Permute options as) of+ (opts,args,[]) -> (opts,args)+ (_,_,errs) -> error (concat errs ++ usage)++optValueWithDefault :: (String -> Opt) -> String -> [Opt] -> String+optValueWithDefault optcons def opts = + last $ def : optValuesForConstructor optcons opts++optValuesForConstructor :: (String -> Opt) -> [Opt] -> [String]+optValuesForConstructor optcons opts = concatMap get opts+ where get o = [v | optcons v == o] where v = value o++defaultMain = do+ args <- getArgs+ let (opts,exes) = parseargs args+ when (null exes) $ error $ "at least one executable needed\n" ++ usage+ let (file, num) = (fileopt opts, numopt opts)+ tests <- liftM (filter istest . lines) (readFile file)+ now <- getCurrentTime+ putStrLn $ printf "Using %s" file+ putStrLn $ printf "Running %d tests %d times with %d executables at %s:" + (length tests) num (length exes) (show now)+ let doexe t e = mapM (doiteration opts t e) [1..num]+ let dotest t = mapM (doexe t) exes+ hSetBuffering stdout NoBuffering+ results <- mapM dotest tests+ summarise opts tests exes results ++istest s = not (null s' || ("#" `isPrefixOf` s')) where s' = clean s+clean = unwords . words++doiteration :: [Opt] -> String -> String -> Int -> IO Float+doiteration opts test exe iteration = do+ let cmd = unwords [exe,clean test]+ when (verboseopt opts) $ putStr $ show iteration ++ ": " ++ cmd+ hFlush stdout+ t <- time cmd+ when (verboseopt opts) $ printf "\t[%ss]\n" (showtime opts t)+ return t++time :: String -> IO Float+time cmd = do+ t1 <- getCurrentTime+ ret <- system $ cmd ++ " >/dev/null 2>&1"+ case ret of+ ExitSuccess -> return ()+ ExitFailure f -> putStr $ printf " (error %d)" f+ t2 <- getCurrentTime+ return $ realToFrac $ diffUTCTime t2 t1++summarise :: [Opt] -> [String] -> [String] -> [[[Float]]] -> IO ()+summarise opts tests exes results = do+ putStrLn "\nSummary (best iteration):\n"+ let t = maketable opts tests exes results+ putStrLn $ TA.render id id id t+ -- let outname = "benchresults"+ -- writeFile (outname <.> "txt") $ TA.render id id id t+ -- writeFile (outname <.> "html") $ renderHtml $ TH.css TH.defaultCss +++ TH.render stringToHtml stringToHtml stringToHtml t++maketable :: [Opt] -> [String] -> [String] -> [[[Float]]] -> Table String String String+maketable opts rownames colnames results = Table rowhdrs colhdrs rows+ where+ rowhdrs = Group NoLine $ map Header $ padright rownames+ colhdrs = Group SingleLine $ map Header colnames+ rows = map (map (showtime opts . minimum)) results+ padright ss = map (printf (printf "%%-%ds" w)) ss+ where w = maximum $ map length ss++showtime :: [Opt] -> (Float -> String)+showtime opts = printf $ "%." ++ show (precisionopt opts) ++ "f"
hledger.cabal view
@@ -1,99 +1,86 @@+-- This file has been generated from package.yaml by hpack version 0.5.4.+--+-- see: https://github.com/sol/hpack+ name: hledger-version: 0.26+version: 0.27 stability: stable category: Finance, Console-synopsis: The main command-line interface for the hledger accounting tool.+synopsis: Command-line interface for the hledger accounting tool description:- hledger is a library and set of user tools for working- with financial data (or anything that can be tracked in a- double-entry accounting ledger.) It is a haskell port and- friendly fork of John Wiegley's Ledger. hledger provides- command-line, curses and web interfaces, and aims to be a- reliable, practical tool for daily use.-+ This is hledger’s command-line interface.+ Its basic function is to read a plain text file describing+ financial transactions and produce useful reports.+ hledger is a cross-platform program for tracking money, time, or+ any other commodity, using double-entry accounting and a simple,+ editable file format. It is inspired by and largely compatible+ with ledger(1). hledger provides command-line, curses and web+ interfaces, and aims to be a reliable, practical tool for daily+ use. license: GPL license-file: LICENSE author: Simon Michael <simon@joyful.com> maintainer: Simon Michael <simon@joyful.com> homepage: http://hledger.org-bug-reports: http://hledger.org/bugs-tested-with: GHC==7.8.4, GHC==7.10.1+bug-reports: http://bugs.hledger.org cabal-version: >= 1.10 build-type: Simple--- data-dir: data--- data-files:-extra-tmp-files:-extra-source-files: - test/test.hs- CHANGES+tested-with: GHC==7.4.2, GHC==7.6.3, GHC==7.8.4, GHC==7.10.2 +extra-source-files:+ CHANGES+ README.md+ test/test.hs+ source-repository head- type: git+ type: git location: https://github.com/simonmichael/hledger flag threaded- Description: Build with support for multithreaded execution- Default: True+ default: True+ description:+ Build with support for multithreaded execution flag curses- Description: On POSIX systems, enable curses support for auto-detecting terminal width.- Default: True+ default: True+ description: + On POSIX systems, enable curses support for auto-detecting terminal width. flag old-locale- description: A compatibility flag, set automatically by cabal.- If false then depend on time >= 1.5, - if true then depend on time < 1.5 together with old-locale. default: False-+ description: + A compatibility flag, set automatically by cabal.+ If false then depend on time >= 1.5, + if true then depend on time < 1.5 together with old-locale. library- cpp-options: -DVERSION="0.26"- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures- ghc-options: -fno-warn-type-defaults -fno-warn-orphans- default-language: Haskell2010- exposed-modules:- Hledger.Cli- Hledger.Cli.Main- Hledger.Cli.Options- Hledger.Cli.Tests- Hledger.Cli.Utils- Hledger.Cli.Version- Hledger.Cli.Add- Hledger.Cli.Accounts- Hledger.Cli.Balance- Hledger.Cli.Balancesheet- Hledger.Cli.Cashflow- Hledger.Cli.Histogram- Hledger.Cli.Incomestatement- Hledger.Cli.Print- Hledger.Cli.Register- Hledger.Cli.Stats+ ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans+ cpp-options: -DVERSION="0.27" build-depends:- hledger-lib == 0.26- ,base >= 4.3 && < 5- ,base-compat >= 0.8.1- -- ,cabal-file-th- ,containers- ,unordered-containers- ,cmdargs >= 0.10 && < 0.11- ,csv- -- ,data-pprint >= 0.2.1 && < 0.3- ,directory- ,filepath- ,haskeline >= 0.6 && <= 0.8- ,HUnit- ,mtl- ,mtl-compat- ,old-time- ,parsec >= 3- ,process- ,regex-tdfa- ,safe >= 0.2- ,split >= 0.1 && < 0.3- ,text >= 0.11- ,tabular >= 0.2 && < 0.3- ,utf8-string >= 0.3.5 && < 1.1- ,wizards == 1.0.*+ hledger-lib == 0.27+ , base >= 4.3 && < 5+ , base-compat >= 0.8.1+ , containers+ , unordered-containers+ , cmdargs >= 0.10 && < 0.11+ , csv+ , directory+ , filepath+ , haskeline >= 0.6 && <= 0.8+ , HUnit+ , mtl+ , mtl-compat+ , old-time+ , parsec >= 3+ , process+ , regex-tdfa+ , safe >= 0.2+ , split >= 0.1 && < 0.3+ , text >= 0.11+ , tabular >= 0.2 && < 0.3+ , utf8-string >= 0.3.5 && < 1.1+ , wizards == 1.0.*+ if impl(ghc >= 7.10) -- ghc 7.10 requires shakespeare 2.0.2.2+ build-depends: shakespeare >= 2.0.2.2 && < 2.1@@ -103,120 +90,152 @@ build-depends: shakespeare >= 1.0 && < 2.1 ,shakespeare-text >= 1.0 && < 1.2+ if flag(old-locale) build-depends: time < 1.5, old-locale else build-depends: time >= 1.5+ if impl(ghc >= 7.4) build-depends: pretty-show >= 1.6.4+ if !os(windows) && flag(curses) build-depends: terminfo + exposed-modules:+ Hledger.Cli+ Hledger.Cli.Main+ Hledger.Cli.CliOptions+ Hledger.Cli.Tests+ Hledger.Cli.Utils+ Hledger.Cli.Version+ Hledger.Cli.Add+ Hledger.Cli.Accounts+ Hledger.Cli.Balance+ Hledger.Cli.Balancesheet+ Hledger.Cli.Cashflow+ Hledger.Cli.Histogram+ Hledger.Cli.Incomestatement+ Hledger.Cli.Print+ Hledger.Cli.Register+ Hledger.Cli.Stats+ Text.Tabular.AsciiWide+ default-language: Haskell2010 executable hledger- main-is: hledger-cli.hs- hs-source-dirs: app- default-language: Haskell2010- cpp-options: -DVERSION="0.26"- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures- ghc-options: -fno-warn-type-defaults -fno-warn-orphans+ main-is: hledger-cli.hs+ hs-source-dirs:+ app+ ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans if flag(threaded)- ghc-options: -threaded- -- same as above:+ ghc-options: -threaded+ cpp-options: -DVERSION="0.27" build-depends:- hledger-lib == 0.26- ,hledger == 0.26- ,base >= 4.3 && < 5- ,base-compat >= 0.8.1- ,containers- ,unordered-containers- ,cmdargs >= 0.10 && < 0.11- ,csv- -- ,data-pprint >= 0.2.1 && < 0.3- ,directory- ,filepath- ,haskeline >= 0.6 && <= 0.8- ,HUnit- ,mtl- ,mtl-compat- ,old-time- ,parsec >= 3- ,process- ,regex-tdfa- ,safe >= 0.2- ,split >= 0.1 && < 0.3- ,tabular >= 0.2 && < 0.3- ,text >= 0.11- ,utf8-string >= 0.3.5 && < 1.1- ,wizards == 1.0.*- -- as above+ hledger-lib == 0.27+ , base >= 4.3 && < 5+ , base-compat >= 0.8.1+ , containers+ , unordered-containers+ , cmdargs >= 0.10 && < 0.11+ , csv+ , directory+ , filepath+ , haskeline >= 0.6 && <= 0.8+ , HUnit+ , mtl+ , mtl-compat+ , old-time+ , parsec >= 3+ , process+ , regex-tdfa+ , safe >= 0.2+ , split >= 0.1 && < 0.3+ , text >= 0.11+ , tabular >= 0.2 && < 0.3+ , utf8-string >= 0.3.5 && < 1.1+ , wizards == 1.0.*+ , hledger == 0.27+ if impl(ghc >= 7.10) build-depends: shakespeare >= 2.0.2.2 && < 2.1 else build-depends: shakespeare >= 1.0 && < 2.1 ,shakespeare-text >= 1.0 && < 1.2+ if flag(old-locale) build-depends: time < 1.5, old-locale else build-depends: time >= 1.5+ if impl(ghc >= 7.4) build-depends: pretty-show >= 1.6.4 + if !os(windows) && flag(curses)+ build-depends: terminfo -test-suite test- type: exitcode-stdio-1.0- main-is: test.hs- hs-source-dirs: test default-language: Haskell2010- ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures- ghc-options: -fno-warn-type-defaults -fno-warn-orphans- -- same as above:- build-depends: hledger-lib- , hledger- , base >= 4.3 && < 5- , base-compat >= 0.8.1- , cmdargs- , containers- , csv- -- , data-pprint >= 0.2.1 && < 0.3- , directory- , filepath- , haskeline- , HUnit- , mtl- , mtl-compat- , old-time- , parsec >= 3- , process- , regex-tdfa- , safe- , split- ,tabular >= 0.2 && < 0.3- , test-framework- , test-framework-hunit- , text- , transformers- , wizards == 1.0.*- -- as above++test-suite test+ type: exitcode-stdio-1.0+ main-is: test.hs+ hs-source-dirs:+ test+ ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures -fno-warn-type-defaults -fno-warn-orphans+ cpp-options: -DVERSION="0.27"+ build-depends:+ hledger-lib == 0.27+ , base >= 4.3 && < 5+ , base-compat >= 0.8.1+ , containers+ , unordered-containers+ , cmdargs >= 0.10 && < 0.11+ , csv+ , directory+ , filepath+ , haskeline >= 0.6 && <= 0.8+ , HUnit+ , mtl+ , mtl-compat+ , old-time+ , parsec >= 3+ , process+ , regex-tdfa+ , safe >= 0.2+ , split >= 0.1 && < 0.3+ , text >= 0.11+ , tabular >= 0.2 && < 0.3+ , utf8-string >= 0.3.5 && < 1.1+ , wizards == 1.0.*+ , hledger+ , test-framework+ , test-framework-hunit+ if impl(ghc >= 7.10) build-depends: shakespeare >= 2.0.2.2 && < 2.1 else build-depends: shakespeare >= 1.0 && < 2.1 ,shakespeare-text >= 1.0 && < 1.2+ if impl(ghc >= 7.4) build-depends: pretty-show >= 1.6.4+ if flag(old-locale) build-depends: time < 1.5, old-locale else build-depends: time >= 1.5 + if !os(windows) && flag(curses)+ build-depends: terminfo + default-language: Haskell2010+ benchmark bench type: exitcode-stdio-1.0 hs-source-dirs: bench main-is: bench.hs+ other-modules: SimpleBench ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-name-shadowing -fno-warn-missing-signatures ghc-options: -fno-warn-type-defaults -fno-warn-orphans default-language: Haskell2010@@ -231,6 +250,7 @@ process, filepath, directory+ if flag(old-locale) build-depends: time < 1.5, old-locale else