diff --git a/CHANGES b/CHANGES --- a/CHANGES +++ b/CHANGES @@ -1,4 +1,10 @@ -API-ish changes in hledger-lib. For user-visible changes, see hledger. +API-ish changes in hledger-lib. +User-visible changes appear in hledger's change log. + + +0.25 (2015/4/7) + +- GHC 7.10 compatibility (#239) 0.24.1 (2015/3/15) diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -80,6 +80,7 @@ -- ** arithmetic costOfMixedAmount, divideMixedAmount, + averageMixedAmounts, isNegativeMixedAmount, isZeroMixedAmount, isReallyZeroMixedAmount, @@ -99,8 +100,10 @@ ) where import Data.Char (isDigit) -#ifndef DOUBLE -import Data.Decimal +#ifdef DOUBLE +roundTo = flip const +#else +import Data.Decimal (roundTo) #endif import Data.Function (on) import Data.List @@ -149,10 +152,8 @@ missingamt :: Amount missingamt = amount{acommodity="AUTO"} --- handy amount constructors for tests -#ifdef DOUBLE -roundTo = flip const -#endif +-- Handy amount constructors for tests. +-- usd/eur/gbp round their argument to a whole number of pennies/cents. num n = amount{acommodity="", aquantity=n} hrs n = amount{acommodity="h", aquantity=n, astyle=amountstyle{asprecision=2, ascommodityside=R}} usd n = amount{acommodity="$", aquantity=roundTo 2 n, astyle=amountstyle{asprecision=2}} @@ -479,6 +480,11 @@ -- | Divide a mixed amount's quantities by a constant. divideMixedAmount :: MixedAmount -> Quantity -> MixedAmount divideMixedAmount (Mixed as) d = Mixed $ map (flip divideAmount d) as + +-- | Calculate the average of some mixed amounts. +averageMixedAmounts :: [MixedAmount] -> MixedAmount +averageMixedAmounts [] = 0 +averageMixedAmounts as = sum as `divideMixedAmount` fromIntegral (length as) -- | Is this mixed amount negative, if it can be normalised to a single commodity ? isNegativeMixedAmount :: MixedAmount -> Maybe Bool diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE NoMonoLocalBinds #-} {-# LANGUAGE FlexibleContexts #-} {-| @@ -63,18 +64,24 @@ ) where -import Control.Applicative ((<*)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative.Compat ((<*)) +#endif import Control.Monad import Data.List import Data.Maybe +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format hiding (months) +#else import Data.Time.Format +import System.Locale (TimeLocale, defaultTimeLocale) +#endif import Data.Time.Calendar import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate import Data.Time.Clock import Data.Time.LocalTime import Safe (headMay, lastMay, readMay) -import System.Locale (defaultTimeLocale) import Test.HUnit import Text.Parsec import Text.Printf @@ -420,13 +427,23 @@ -- parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s -- ] +parsetime :: ParseTime t => TimeLocale -> String -> String -> Maybe t +parsetime = +#if MIN_VERSION_time(1,5,0) + parseTimeM True +#else + parseTime +#endif + + -- | Parse a couple of date string formats to a time type. parsedateM :: String -> Maybe Day parsedateM s = firstJust [ - parseTime defaultTimeLocale "%Y/%m/%d" s, - parseTime defaultTimeLocale "%Y-%m-%d" s + parsetime defaultTimeLocale "%Y/%m/%d" s, + parsetime defaultTimeLocale "%Y-%m-%d" s ] + -- -- | Parse a date-time string to a time type, or raise an error. -- parsedatetime :: String -> LocalTime -- parsedatetime s = fromMaybe (error' $ "could not parse timestamp \"" ++ s ++ "\"") @@ -440,7 +457,7 @@ -- | Parse a time string to a time type using the provided pattern, or -- return the default. parsetimewith :: ParseTime t => String -> String -> t -> t -parsetimewith pat s def = fromMaybe def $ parseTime defaultTimeLocale pat s +parsetimewith pat s def = fromMaybe def $ parsetime defaultTimeLocale pat s {-| Parse a date in any of the formats allowed in ledger's period expressions, diff --git a/Hledger/Data/OutputFormat.hs b/Hledger/Data/OutputFormat.hs --- a/Hledger/Data/OutputFormat.hs +++ b/Hledger/Data/OutputFormat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE CPP #-} module Hledger.Data.OutputFormat ( parseStringFormat , formatsp @@ -8,8 +9,10 @@ , tests ) where -import Control.Applicative ((<*)) import Numeric +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative.Compat ((<*)) +#endif import Data.Char (isPrint) import Data.Maybe import Test.HUnit diff --git a/Hledger/Data/TimeLog.hs b/Hledger/Data/TimeLog.hs --- a/Hledger/Data/TimeLog.hs +++ b/Hledger/Data/TimeLog.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-| A 'TimeLogEntry' is a clock-in, clock-out, or other directive in a timelog @@ -13,7 +14,9 @@ import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime +#if !(MIN_VERSION_time(1,5,0)) import System.Locale (defaultTimeLocale) +#endif import Test.HUnit import Text.Printf @@ -109,7 +112,12 @@ nowstr = showtime now yesterday = prevday today clockin = TimeLogEntry nullsourcepos In - mktime d = LocalTime d . fromMaybe midnight . parseTime defaultTimeLocale "%H:%M:%S" + mktime d = LocalTime d . fromMaybe midnight . +#if MIN_VERSION_time(1,5,0) + parseTimeM True defaultTimeLocale "%H:%M:%S" +#else + parseTime defaultTimeLocale "%H:%M:%S" +#endif showtime = formatTime defaultTimeLocale "%H:%M" assertEntriesGiveStrings name es ss = assertEqual name ss (map tdescription $ timeLogEntriesToTransactions now es) diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -19,7 +19,7 @@ module Hledger.Data.Types where -import Control.Monad.Error (ErrorT) +import Control.Monad.Except (ExceptT) import Data.Data #ifndef DOUBLE import Data.Decimal @@ -200,7 +200,7 @@ -- | A JournalUpdate is some transformation of a Journal. It can do I/O or -- raise an error. -type JournalUpdate = ErrorT String IO (Journal -> Journal) +type JournalUpdate = ExceptT String IO (Journal -> Journal) -- | The id of a data format understood by hledger, eg @journal@ or @csv@. type StorageFormat = String @@ -213,7 +213,7 @@ -- quickly check if this reader can probably handle the given file path and file content ,rDetector :: FilePath -> String -> Bool -- parse the given string, using the given parse rules file if any, returning a journal or error aware of the given file path - ,rParser :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal + ,rParser :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal } instance Show Reader where show r = rFormat r ++ " reader" diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -31,7 +31,7 @@ ) where import qualified Control.Exception as C -import Control.Monad.Error +import Control.Monad.Except import Data.List import Data.Maybe import System.Directory (doesFileExist, getHomeDirectory) @@ -127,7 +127,7 @@ firstSuccessOrBestError [] [] = return $ Left "no readers found" firstSuccessOrBestError errs (r:rs) = do dbgAtM 1 "trying reader" (rFormat r) - result <- (runErrorT . (rParser r) rulesfile assrt path') s + result <- (runExceptT . (rParser r) rulesfile assrt path') s dbgAtM 1 "reader result" $ either id show result case result of Right j -> return $ Right j -- success! Left e -> firstSuccessOrBestError (errs++[e]) rs -- keep trying @@ -235,7 +235,7 @@ tests_Hledger_Read_CsvReader, "journal" ~: do - r <- runErrorT $ parseWithCtx nullctx JournalReader.journal "" + r <- runExceptT $ parseWithCtx nullctx JournalReader.journal "" assertBool "journal should parse an empty file" (isRight $ r) jE <- readJournal Nothing Nothing True Nothing "" -- don't know how to get it from journal either error' (assertBool "journal parsing an empty file should give an empty journal" . null . jtxns) jE diff --git a/Hledger/Read/CsvReader.hs b/Hledger/Read/CsvReader.hs --- a/Hledger/Read/CsvReader.hs +++ b/Hledger/Read/CsvReader.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-| A reader for CSV data, using an extra rules file to help interpret the data. @@ -19,22 +20,28 @@ tests_Hledger_Read_CsvReader ) where -import Control.Applicative ((<$>), (<*)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative.Compat ((<$>), (<*)) +#endif import Control.Exception hiding (try) import Control.Monad -import Control.Monad.Error +import Control.Monad.Except -- import Test.HUnit import Data.Char (toLower, isDigit, isSpace) import Data.List import Data.Maybe import Data.Ord import Data.Time.Calendar (Day) +#if MIN_VERSION_time(1,5,0) +import Data.Time.Format (parseTimeM, defaultTimeLocale) +#else import Data.Time.Format (parseTime) +import System.Locale (defaultTimeLocale) +#endif import Safe import System.Directory (doesFileExist) import System.FilePath import System.IO (stderr) -import System.Locale (defaultTimeLocale) import Test.HUnit import Text.CSV (parseCSV, CSV) import Text.Parsec hiding (parse) @@ -63,7 +70,7 @@ -- | Parse and post-process a "Journal" from CSV data, or give an error. -- XXX currently ignores the string and reads from the file path -parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal +parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse rulesfile _ f s = do r <- liftIO $ readJournalFromCsv rulesfile f s case r of Left e -> throwError e @@ -92,7 +99,7 @@ if created then hPrintf stderr "creating default conversion rules file %s, edit this file for better results\n" rulesfile else hPrintf stderr "using conversion rules file %s\n" rulesfile - rules_ <- liftIO $ runErrorT $ parseRulesFile rulesfile + rules_ <- liftIO $ runExceptT $ parseRulesFile rulesfile let rules = case rules_ of Right (t::CsvRules) -> t Left err -> throwerr $ show err @@ -335,15 +342,15 @@ getDirective directivename = lookup directivename . rdirectives -parseRulesFile :: FilePath -> ErrorT String IO CsvRules +parseRulesFile :: FilePath -> ExceptT String IO CsvRules parseRulesFile f = do s <- liftIO $ (readFile' f >>= expandIncludes (takeDirectory f)) let rules = parseCsvRules f s case rules of - Left e -> ErrorT $ return $ Left $ show e + Left e -> ExceptT $ return $ Left $ show e Right r -> do - r_ <- liftIO $ runErrorT $ validateRules r - ErrorT $ case r_ of + r_ <- liftIO $ runExceptT $ validateRules r + ExceptT $ case r_ of Left e -> return $ Left $ show $ toParseError e Right r -> return $ Right r where @@ -369,13 +376,13 @@ runParser rulesp rules rulesfile s -- | Return the validated rules, or an error. -validateRules :: CsvRules -> ErrorT String IO CsvRules +validateRules :: CsvRules -> ExceptT String IO CsvRules validateRules rules = do - unless (isAssigned "date") $ ErrorT $ return $ Left "Please specify (at top level) the date field. Eg: date %1\n" + unless (isAssigned "date") $ ExceptT $ return $ Left "Please specify (at top level) the date field. Eg: date %1\n" unless ((amount && not (amountin || amountout)) || (not amount && (amountin && amountout))) - $ ErrorT $ return $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n" - ErrorT $ return $ Right rules + $ ExceptT $ return $ Left "Please specify (at top level) either the amount field, or both the amount-in and amount-out fields. Eg: amount %2\n" + ExceptT $ return $ Right rules where amount = isAssigned "amount" amountin = isAssigned "amount-in" @@ -410,7 +417,7 @@ commentline = many spacenonewline >> commentchar >> restofline >> return () "comment line" commentchar :: Stream [Char] m t => ParsecT [Char] CsvRules m Char -commentchar = oneOf ";#" +commentchar = oneOf ";#*" directive :: Stream [Char] m t => ParsecT [Char] CsvRules m (DirectiveName, String) directive = do @@ -713,7 +720,13 @@ parseDateWithFormatOrDefaultFormats :: Maybe DateFormat -> String -> Maybe Day parseDateWithFormatOrDefaultFormats mformat s = firstJust $ map parsewith formats where - parsewith = flip (parseTime defaultTimeLocale) s + parsetime = +#if MIN_VERSION_time(1,5,0) + parseTimeM True +#else + parseTime +#endif + parsewith = flip (parsetime defaultTimeLocale) s formats = maybe ["%Y/%-m/%-d" ,"%Y-%-m-%-d" diff --git a/Hledger/Read/JournalReader.hs b/Hledger/Read/JournalReader.hs --- a/Hledger/Read/JournalReader.hs +++ b/Hledger/Read/JournalReader.hs @@ -45,10 +45,12 @@ #endif ) where -import Control.Applicative ((<*)) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative.Compat ((<*)) +#endif import qualified Control.Exception as C import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import Data.Char (isNumber) import Data.List import Data.List.Split (wordsBy) @@ -87,7 +89,7 @@ -- | Parse and post-process a "Journal" from hledger's journal file -- format, or give an error. -parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal +parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse _ = parseJournalWith journal -- parsing utils @@ -98,7 +100,7 @@ -- | Given a JournalUpdate-generating parsec parser, file path and data string, -- parse and post-process a Journal so that it's ready to use, or give an error. -parseJournalWith :: (ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ErrorT String IO Journal +parseJournalWith :: (ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext)) -> Bool -> FilePath -> String -> ExceptT String IO Journal parseJournalWith p assrt f s = do tc <- liftIO getClockTime tl <- liftIO getCurrentLocalTime @@ -151,7 +153,7 @@ -- | Top-level journal parser. Returns a single composite, I/O performing, -- error-raising "JournalUpdate" (and final "JournalContext") which can be -- applied to an empty journal to get the final result. -journal :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate,JournalContext) +journal :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate,JournalContext) journal = do journalupdates <- many journalItem eof @@ -171,7 +173,7 @@ ] "journal transaction or directive" -- cf http://ledger-cli.org/3.0/doc/ledger3.html#Command-Directives -directive :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +directive :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate directive = do optional $ char '!' choice' [ @@ -189,7 +191,7 @@ ] "directive" -includedirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +includedirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate includedirective = do string "include" many1 spacenonewline @@ -197,7 +199,7 @@ outerState <- getState outerPos <- getPosition let curdir = takeDirectory (sourceName outerPos) - let (u::ErrorT String IO (Journal -> Journal, JournalContext)) = do + let (u::ExceptT String IO (Journal -> Journal, JournalContext)) = do filepath <- expandPath curdir filename txt <- readFileOrError outerPos filepath let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" @@ -210,18 +212,18 @@ return (u, ctx) Left err -> throwError $ inIncluded ++ show err where readFileOrError pos fp = - ErrorT $ liftM Right (readFile' fp) `C.catch` + ExceptT $ liftM Right (readFile' fp) `C.catch` \e -> return $ Left $ printf "%s reading %s:\n%s" (show pos) fp (show (e::C.IOException)) - r <- liftIO $ runErrorT u + r <- liftIO $ runExceptT u case r of Left err -> return $ throwError err - Right (ju, _finalparsectx) -> return $ ErrorT $ return $ Right ju + Right (ju, _finalparsectx) -> return $ ExceptT $ return $ Right ju journalAddFile :: (FilePath,String) -> Journal -> Journal journalAddFile f j@Journal{files=fs} = j{files=fs++[f]} -- NOTE: first encountered file to left, to avoid a reverse -accountdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +accountdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate accountdirective = do string "account" many1 spacenonewline @@ -229,16 +231,16 @@ newline pushParentAccount parent -- return $ return id - return $ ErrorT $ return $ Right id + return $ ExceptT $ return $ Right id -enddirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +enddirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate enddirective = do string "end" popParentAccount -- return (return id) - return $ ErrorT $ return $ Right id + return $ ExceptT $ return $ Right id -aliasdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +aliasdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate aliasdirective = do string "alias" many1 spacenonewline @@ -249,13 +251,13 @@ ,accountNameWithoutPostingType $ strip alias) return $ return id -endaliasesdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +endaliasesdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate endaliasesdirective = do string "end aliases" clearAccountAliases return (return id) -tagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +tagdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate tagdirective = do string "tag" "tag directive" many1 spacenonewline @@ -263,13 +265,13 @@ restofline return $ return id -endtagdirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +endtagdirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate endtagdirective = do (string "end tag" <|> string "pop") "end tag or pop directive" restofline return $ return id -defaultyeardirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +defaultyeardirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate defaultyeardirective = do char 'Y' "default year" many spacenonewline @@ -279,7 +281,7 @@ setYear y' return $ return id -defaultcommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +defaultcommoditydirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate defaultcommoditydirective = do char 'D' "default commodity" many1 spacenonewline @@ -288,7 +290,7 @@ restofline return $ return id -historicalpricedirective :: ParsecT [Char] JournalContext (ErrorT String IO) HistoricalPrice +historicalpricedirective :: ParsecT [Char] JournalContext (ExceptT String IO) HistoricalPrice historicalpricedirective = do char 'P' "historical price" many spacenonewline @@ -300,7 +302,7 @@ restofline return $ HistoricalPrice date symbol price -ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +ignoredpricecommoditydirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate ignoredpricecommoditydirective = do char 'N' "ignored-price commodity" many1 spacenonewline @@ -308,7 +310,7 @@ restofline return $ return id -commodityconversiondirective :: ParsecT [Char] JournalContext (ErrorT String IO) JournalUpdate +commodityconversiondirective :: ParsecT [Char] JournalContext (ExceptT String IO) JournalUpdate commodityconversiondirective = do char 'C' "commodity conversion" many1 spacenonewline @@ -320,7 +322,7 @@ restofline return $ return id -modifiertransaction :: ParsecT [Char] JournalContext (ErrorT String IO) ModifierTransaction +modifiertransaction :: ParsecT [Char] JournalContext (ExceptT String IO) ModifierTransaction modifiertransaction = do char '=' "modifier transaction" many spacenonewline @@ -328,7 +330,7 @@ postings <- postings return $ ModifierTransaction valueexpr postings -periodictransaction :: ParsecT [Char] JournalContext (ErrorT String IO) PeriodicTransaction +periodictransaction :: ParsecT [Char] JournalContext (ExceptT String IO) PeriodicTransaction periodictransaction = do char '~' "periodic transaction" many spacenonewline @@ -337,7 +339,7 @@ return $ PeriodicTransaction periodexpr postings -- | Parse a (possibly unbalanced) transaction. -transaction :: ParsecT [Char] JournalContext (ErrorT String IO) Transaction +transaction :: ParsecT [Char] JournalContext (ExceptT String IO) Transaction transaction = do -- ptrace "transaction" sourcepos <- getPosition @@ -906,7 +908,10 @@ return $ unlines $ samelinecomment:newlinecomments comment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String -comment = commentStartingWith "#;" +comment = commentStartingWith commentchars + +commentchars :: [Char] +commentchars = "#;*" semicoloncomment :: Stream [Char] m Char => ParsecT [Char] JournalContext m String semicoloncomment = commentStartingWith ";" diff --git a/Hledger/Read/TimelogReader.hs b/Hledger/Read/TimelogReader.hs --- a/Hledger/Read/TimelogReader.hs +++ b/Hledger/Read/TimelogReader.hs @@ -48,7 +48,7 @@ ) where import Control.Monad -import Control.Monad.Error +import Control.Monad.Except import Data.List (isPrefixOf, foldl') import Test.HUnit import Text.Parsec hiding (parse) @@ -78,10 +78,10 @@ -- | Parse and post-process a "Journal" from timeclock.el's timelog -- format, saving the provided file path and the current time, or give an -- error. -parse :: Maybe FilePath -> Bool -> FilePath -> String -> ErrorT String IO Journal +parse :: Maybe FilePath -> Bool -> FilePath -> String -> ExceptT String IO Journal parse _ = parseJournalWith timelogFile -timelogFile :: ParsecT [Char] JournalContext (ErrorT String IO) (JournalUpdate, JournalContext) +timelogFile :: ParsecT [Char] JournalContext (ExceptT String IO) (JournalUpdate, JournalContext) timelogFile = do items <- many timelogItem eof ctx <- getState @@ -98,7 +98,7 @@ ] "timelog entry, or default year or historical price directive" -- | Parse a timelog entry. -timelogentry :: ParsecT [Char] JournalContext (ErrorT String IO) TimeLogEntry +timelogentry :: ParsecT [Char] JournalContext (ExceptT String IO) TimeLogEntry timelogentry = do sourcepos <- getPosition code <- oneOf "bhioO" diff --git a/Hledger/Reports/MultiBalanceReports.hs b/Hledger/Reports/MultiBalanceReports.hs --- a/Hledger/Reports/MultiBalanceReports.hs +++ b/Hledger/Reports/MultiBalanceReports.hs @@ -41,7 +41,7 @@ -- (see 'BalanceType' and "Hledger.Cli.Balance"). newtype MultiBalanceReport = MultiBalanceReport ([DateSpan] ,[MultiBalanceReportRow] - ,[MixedAmount] + ,MultiBalanceTotalsRow ) -- | A row in a multi balance report has @@ -49,8 +49,14 @@ -- * An account name, with rendering hints -- -- * A list of amounts to be shown in each of the report's columns. -type MultiBalanceReportRow = (RenderableAccountName, [MixedAmount]) +-- +-- * The total of the row amounts. +-- +-- * The average of the row amounts. +type MultiBalanceReportRow = (RenderableAccountName, [MixedAmount], MixedAmount, MixedAmount) +type MultiBalanceTotalsRow = ([MixedAmount], MixedAmount, MixedAmount) + instance Show MultiBalanceReport where -- use ppShow to break long lists onto multiple lines -- we add some bogus extra shows here to help ppShow parse the output @@ -65,7 +71,7 @@ -- showing the change of balance, accumulated balance, or historical balance -- in each of the specified periods. multiBalanceReport :: ReportOpts -> Query -> Journal -> MultiBalanceReport -multiBalanceReport opts q j = MultiBalanceReport (displayspans, items, totals) +multiBalanceReport opts q j = MultiBalanceReport (displayspans, items, totalsrow) where symq = dbg "symq" $ filterQuery queryIsSym $ dbg "requested q" q depthq = dbg "depthq" $ filterQuery queryIsDepth q @@ -144,23 +150,29 @@ items :: [MultiBalanceReportRow] = dbg "items" $ - [((a, accountLeafName a, accountNameLevel a), displayedBals) + [((a, accountLeafName a, accountNameLevel a), displayedBals, rowtot, rowavg) | (a,changes) <- acctBalChanges , let displayedBals = case balancetype_ opts of HistoricalBalance -> drop 1 $ scanl (+) (startingBalanceFor a) changes CumulativeBalance -> drop 1 $ scanl (+) nullmixedamt changes _ -> changes + , let rowtot = sum displayedBals + , let rowavg = averageMixedAmounts displayedBals , empty_ opts || depth == 0 || any (not . isZeroMixedAmount) displayedBals ] totals :: [MixedAmount] = - dbg "totals" $ + -- dbg "totals" $ map sum balsbycol where - balsbycol = transpose [bs | ((a,_,_),bs) <- items, not (tree_ opts) || a `elem` highestlevelaccts] + balsbycol = transpose [bs | ((a,_,_),bs,_,_) <- items, not (tree_ opts) || a `elem` highestlevelaccts] highestlevelaccts = dbg "highestlevelaccts" $ [a | a <- displayedAccts, not $ any (`elem` displayedAccts) $ init $ expandAccountName a] + + totalsrow :: MultiBalanceTotalsRow = + dbg "totalsrow" $ + (totals, sum totals, averageMixedAmounts totals) dbg s = let p = "multiBalanceReport" in Hledger.Utils.dbg (p++" "++s) -- add prefix in this function's debug output -- dbg = const id -- exclude this function from debug output diff --git a/Hledger/Reports/ReportOptions.hs b/Hledger/Reports/ReportOptions.hs --- a/Hledger/Reports/ReportOptions.hs +++ b/Hledger/Reports/ReportOptions.hs @@ -85,6 +85,7 @@ ,balancetype_ :: BalanceType ,accountlistmode_ :: AccountListMode ,drop_ :: Int + ,row_total_ :: Bool ,no_total_ :: Bool } deriving (Show, Data, Typeable) @@ -117,6 +118,7 @@ def def def + def rawOptsToReportOpts :: RawOpts -> IO ReportOpts rawOptsToReportOpts rawopts = do @@ -146,6 +148,7 @@ ,balancetype_ = balancetypeopt rawopts ,accountlistmode_ = accountlistmodeopt rawopts ,drop_ = intopt "drop" rawopts + ,row_total_ = boolopt "row-total" rawopts ,no_total_ = boolopt "no-total" rawopts } diff --git a/Hledger/Utils.hs b/Hledger/Utils.hs --- a/Hledger/Utils.hs +++ b/Hledger/Utils.hs @@ -29,8 +29,7 @@ ) where import Control.Monad (liftM) -import Control.Monad.Error (MonadIO) -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Char import Data.List import qualified Data.Map as M @@ -55,26 +54,34 @@ -- strings +lowercase, uppercase :: String -> String lowercase = map toLower uppercase = map toUpper -- | Remove leading and trailing whitespace. +strip :: String -> String strip = lstrip . rstrip -- | Remove leading whitespace. +lstrip :: String -> String lstrip = dropWhile (`elem` " \t") :: String -> String -- XXX isSpace ? -- | Remove trailing whitespace. +rstrip :: String -> String rstrip = reverse . lstrip . reverse -- | Remove trailing newlines/carriage returns. +chomp :: String -> String chomp = reverse . dropWhile (`elem` "\r\n") . reverse +stripbrackets :: String -> String stripbrackets = dropWhile (`elem` "([") . reverse . dropWhile (`elem` "])") . reverse :: String -> String +elideLeft :: Int -> String -> String elideLeft width s = if length s > width then ".." ++ reverse (take (width - 2) $ reverse s) else s +elideRight :: Int -> String -> String elideRight width s = if length s > width then take (width - 2) s ++ ".." else s @@ -94,14 +101,17 @@ -- | Double-quote this string if it contains whitespace, single quotes -- or double-quotes, escaping the quotes as needed. +quoteIfNeeded :: String -> String quoteIfNeeded s | any (`elem` s) (quotechars++whitespacechars) = "\"" ++ escapeDoubleQuotes s ++ "\"" | otherwise = s -- | Single-quote this string if it contains whitespace or double-quotes. -- No good for strings containing single quotes. +singleQuoteIfNeeded :: String -> String singleQuoteIfNeeded s | any (`elem` s) whitespacechars = "'"++s++"'" | otherwise = s +quotechars, whitespacechars :: [Char] quotechars = "'\"" whitespacechars = " \t\n\r" diff --git a/Hledger/Utils/Regex.hs b/Hledger/Utils/Regex.hs --- a/Hledger/Utils/Regex.hs +++ b/Hledger/Utils/Regex.hs @@ -126,7 +126,7 @@ replaceAllBy :: Regex -> (String -> String) -> String -> String replaceAllBy re f s = start end where - (_, end, start) = foldl' go (0, s, id) $ getAllMatches $ match re s + (_, end, start) = foldl' go (0, s, id) $ (getAllMatches $ match re s :: [(Int, Int)]) go (ind,read,write) (off,len) = let (skip, start) = splitAt (off - ind) read (matched, remaining) = splitAt len start diff --git a/Hledger/Utils/UTF8IOCompat.hs b/Hledger/Utils/UTF8IOCompat.hs --- a/Hledger/Utils/UTF8IOCompat.hs +++ b/Hledger/Utils/UTF8IOCompat.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP #-} +-- {-# LANGUAGE CPP #-} {- | UTF-8 aware string IO functions that will work across multiple platforms diff --git a/hledger-lib.cabal b/hledger-lib.cabal --- a/hledger-lib.cabal +++ b/hledger-lib.cabal @@ -1,5 +1,5 @@ name: hledger-lib -version: 0.24.1 +version: 0.25 stability: stable category: Finance, Console synopsis: Core data types, parsers and utilities for the hledger accounting tool. @@ -17,7 +17,7 @@ maintainer: Simon Michael homepage: http://hledger.org bug-reports: http://hledger.org/bugs -tested-with: GHC==7.2.2, GHC==7.4.2, GHC==7.6.3, GHC==7.8.2 +tested-with: GHC==7.8.4, GHC==7.10.1 cabal-version: >= 1.10 build-type: Simple -- data-dir: data @@ -35,10 +35,17 @@ location: https://github.com/simonmichael/hledger flag double - Description: Use old Double number representation (instead of Decimal), for testing/benchmarking. - Default: False + description: Use old Double number representation (instead of Decimal), for testing/benchmarking. + default: False + manual: True +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 + library -- should set patchlevel here as in Makefile cpp-options: -DPATCHLEVEL=0 @@ -82,6 +89,7 @@ Hledger.Utils.UTF8IOCompat build-depends: base >= 4.3 && < 5 + ,base-compat >= 0.5.0 ,array ,blaze-markup >= 0.5.1 ,bytestring @@ -93,19 +101,22 @@ ,directory ,filepath ,mtl - ,old-locale + ,mtl-compat ,old-time ,parsec >= 3 ,regex-tdfa ,regexpr >= 0.5.1 ,safe >= 0.2 ,split >= 0.1 && < 0.3 - ,time ,transformers >= 0.2 && < 0.5 ,utf8-string >= 0.3.5 && < 1.1 ,HUnit 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 test-suite tests @@ -117,6 +128,7 @@ default-language: Haskell2010 build-depends: hledger-lib , base >= 4.3 && < 5 + , base-compat >= 0.5.0 , array , blaze-markup >= 0.5.1 , cmdargs @@ -128,7 +140,7 @@ , filepath , HUnit , mtl - , old-locale + , mtl-compat , old-time , parsec >= 3 , regex-tdfa @@ -137,10 +149,13 @@ , split , test-framework , test-framework-hunit - , time , transformers 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 -- cf http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html