diff --git a/Hledger/Data/Amount.hs b/Hledger/Data/Amount.hs --- a/Hledger/Data/Amount.hs +++ b/Hledger/Data/Amount.hs @@ -64,9 +64,9 @@ fromInteger i = Mixed [Amount (comm "") (fromInteger i) Nothing] negate (Mixed as) = Mixed $ map negateAmountPreservingPrice as (+) (Mixed as) (Mixed bs) = normaliseMixedAmount $ Mixed $ as ++ bs - (*) = error "programming error, mixed amounts do not support multiplication" - abs = error "programming error, mixed amounts do not support abs" - signum = error "programming error, mixed amounts do not support signum" + (*) = error' "programming error, mixed amounts do not support multiplication" + abs = error' "programming error, mixed amounts do not support abs" + signum = error' "programming error, mixed amounts do not support signum" instance Ord MixedAmount where compare (Mixed as) (Mixed bs) = compare as bs @@ -153,6 +153,10 @@ isReallyZeroAmount = null . filter (`elem` "123456789") . printf ("%."++show zeroprecision++"f") . quantity where zeroprecision = 8 +-- | Is this amount negative ? The price is ignored. +isNegativeAmount :: Amount -> Bool +isNegativeAmount Amount{quantity=q} = q < 0 + -- | Access a mixed amount's components. amounts :: MixedAmount -> [Amount] amounts (Mixed as) = as @@ -165,6 +169,13 @@ -- | Is this mixed amount "really" zero ? See isReallyZeroAmount. isReallyZeroMixedAmount :: MixedAmount -> Bool isReallyZeroMixedAmount = all isReallyZeroAmount . amounts . normaliseMixedAmount + +-- | Is this mixed amount negative, if it can be normalised to a single commodity ? +isNegativeMixedAmount :: MixedAmount -> Maybe Bool +isNegativeMixedAmount m = case as of [a] -> Just $ isNegativeAmount a + _ -> Nothing + where + as = amounts $ normaliseMixedAmount m -- | Is this mixed amount "really" zero, after converting to cost -- commodities where possible ? diff --git a/Hledger/Data/Commodity.hs b/Hledger/Data/Commodity.hs --- a/Hledger/Data/Commodity.hs +++ b/Hledger/Data/Commodity.hs @@ -37,7 +37,7 @@ -- | Look up one of the hard-coded default commodities. For use in tests. comm :: String -> Commodity comm sym = fromMaybe - (error "commodity lookup failed") + (error' "commodity lookup failed") $ find (\(Commodity{symbol=s}) -> s==sym) defaultcommodities -- | Find the conversion rate between two commodities. Currently returns 1. diff --git a/Hledger/Data/Dates.hs b/Hledger/Data/Dates.hs --- a/Hledger/Data/Dates.hs +++ b/Hledger/Data/Dates.hs @@ -13,7 +13,7 @@ an open-ended span where one or both dates are unspecified. (A date span with both ends unspecified matches all dates.) -An 'Interval' is ledger's "reporting interval" - weekly, monthly, +An 'Interval' is ledger's \"reporting interval\" - weekly, monthly, quarterly, etc. -} @@ -65,7 +65,7 @@ : splitspan' start next (DateSpan (Just n) (Just e)) where s = start b n = next s - splitspan' _ _ _ = error "won't happen, avoids warnings" + splitspan' _ _ _ = error' "won't happen, avoids warnings" -- | Count the days in a DateSpan, or if it is open-ended return Nothing. daysInSpan :: DateSpan -> Maybe Integer @@ -86,10 +86,16 @@ b = if isJust b1 then b1 else b2 -- | Parse a period expression to an Interval and overall DateSpan using --- the provided reference date, or raise an error. -parsePeriodExpr :: Day -> String -> (Interval, DateSpan) -parsePeriodExpr refdate expr = (interval,span) - where (interval,span) = fromparse $ parsewith (periodexpr refdate) expr +-- the provided reference date, or return a parse error. +parsePeriodExpr :: Day -> String -> Either ParseError (Interval, DateSpan) +parsePeriodExpr refdate = parsewith (periodexpr refdate) + +-- | Show a DateSpan as a human-readable pseudo-period-expression string. +dateSpanAsText :: DateSpan -> String +dateSpanAsText (DateSpan Nothing Nothing) = "all" +dateSpanAsText (DateSpan Nothing (Just e)) = printf "to %s" (show e) +dateSpanAsText (DateSpan (Just b) Nothing) = printf "from %s" (show b) +dateSpanAsText (DateSpan (Just b) (Just e)) = printf "%s to %s" (show b) (show e) -- | Convert a single smart date string to a date span using the provided -- reference date, or raise an error. @@ -228,12 +234,12 @@ -- | 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 ++ "\"") +parsedatetime s = fromMaybe (error' $ "could not parse timestamp \"" ++ s ++ "\"") (parsedatetimeM s) -- | Parse a date string to a time type, or raise an error. parsedate :: String -> Day -parsedate s = fromMaybe (error $ "could not parse date \"" ++ s ++ "\"") +parsedate s = fromMaybe (error' $ "could not parse date \"" ++ s ++ "\"") (parsedateM s) -- | Parse a time string to a time type using the provided pattern, or @@ -259,6 +265,7 @@ -} smartdate :: GenParser Char st SmartDate smartdate = do + -- XXX maybe obscures date errors ? see ledgerdate (y,m,d) <- choice' [yyyymmdd, ymd, ym, md, y, d, month, mon, today, yesterday, tomorrow, lastthisnextthing] return (y,m,d) @@ -270,14 +277,15 @@ eof return d -datesepchar = oneOf "/-." +datesepchars = "/-." +datesepchar = oneOf datesepchars validYear, validMonth, validDay :: String -> Bool validYear s = length s >= 4 && isJust (readMay s :: Maybe Int) validMonth s = maybe False (\n -> n>=1 && n<=12) $ readMay s validDay s = maybe False (\n -> n>=1 && n<=31) $ readMay s --- failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: a +failIfInvalidYear, failIfInvalidMonth, failIfInvalidDay :: (Monad m) => String -> m () failIfInvalidYear s = unless (validYear s) $ fail $ "bad year number: " ++ s failIfInvalidMonth s = unless (validMonth s) $ fail $ "bad month number: " ++ s failIfInvalidDay s = unless (validDay s) $ fail $ "bad day number: " ++ s diff --git a/Hledger/Data/TimeLog.hs b/Hledger/Data/TimeLog.hs --- a/Hledger/Data/TimeLog.hs +++ b/Hledger/Data/TimeLog.hs @@ -65,7 +65,7 @@ entryFromTimeLogInOut i o | otime >= itime = t | otherwise = - error $ "clock-out time less than clock-in time in:\n" ++ showTransaction t + error' $ "clock-out time less than clock-in time in:\n" ++ showTransaction t where t = Transaction { tdate = idate, diff --git a/Hledger/Data/Types.hs b/Hledger/Data/Types.hs --- a/Hledger/Data/Types.hs +++ b/Hledger/Data/Types.hs @@ -9,7 +9,7 @@ > [Posting] -- multiple account postings (entries), which have account name and amount. > [HistoricalPrice] -- historical commodity prices > -> Ledger -- a ledger is derived from a journal, by applying a filter specification. It contains.. +> Ledger -- a ledger is derived from a journal, by applying a filter specification and doing some further processing. It contains.. > Journal -- the filtered journal, containing only the transactions and postings we are interested in > Tree AccountName -- account names referenced in the journal's transactions, as a tree > Map AccountName Account -- per-account postings and balances from the journal's transactions, as a map from account name to account info @@ -26,9 +26,7 @@ - hledger 0.5: LedgerTransactions contain Postings (which are flattened to Transactions) - - hledger 0.8: Transactions contain Postings (referencing Transactions, corecursively) - - - hledger 0.10: Postings should be called Entrys, but are left as-is for now + - hledger 0.8: Transactions contain Postings (referencing Transactions..) -} diff --git a/Hledger/Data/Utils.hs b/Hledger/Data/Utils.hs --- a/Hledger/Data/Utils.hs +++ b/Hledger/Data/Utils.hs @@ -25,6 +25,7 @@ ) where import Data.Char +import Codec.Binary.UTF8.String as UTF8 (decodeString, encodeString, isUTF8Encoded) import Control.Exception import Control.Monad import Data.List @@ -44,6 +45,7 @@ import Text.Printf import Text.RegexPR import Text.ParserCombinators.Parsec +import System.Info (os) -- strings @@ -146,6 +148,41 @@ fit w = take w . (++ repeat ' ') blankline = replicate w ' ' +-- encoded platform strings + +-- | A platform string is a string value from or for the operating system, +-- such as a file path or command-line argument (or environment variable's +-- name or value ?). On some platforms (such as unix) these are not real +-- unicode strings but have some encoding such as UTF-8. This alias does +-- no type enforcement but aids code clarity. +type PlatformString = String + +-- | Convert a possibly encoded platform string to a real unicode string. +-- We decode the UTF-8 encoding recommended for unix systems +-- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html) +-- and leave anything else unchanged. +fromPlatformString :: PlatformString -> String +fromPlatformString s = if UTF8.isUTF8Encoded s then UTF8.decodeString s else s + +-- | Convert a unicode string to a possibly encoded platform string. +-- On unix we encode with the recommended UTF-8 +-- (cf http://www.dwheeler.com/essays/fixing-unix-linux-filenames.html) +-- and elsewhere we leave it unchanged. +toPlatformString :: String -> PlatformString +toPlatformString = case os of + "unix" -> UTF8.encodeString + "linux" -> UTF8.encodeString + "darwin" -> UTF8.encodeString + _ -> id + +-- | A version of error that's better at displaying unicode. +error' :: String -> a +error' = error . toPlatformString + +-- | A version of userError that's better at displaying unicode. +userError' :: String -> IOError +userError' = userError . toPlatformString + -- math difforzero :: (Num a, Ord a) => a -> a -> a @@ -232,15 +269,20 @@ strace :: Show a => a -> a strace a = trace (show a) a --- | labelled trace - like strace, with a newline and a label prepended +-- | labelled trace - like strace, with a label prepended ltrace :: Show a => String -> a -> a ltrace l a = trace (l ++ ": " ++ show a) a +-- | monadic trace - like strace, but works as a standalone line in a monad +mtrace :: (Monad m, Show a) => a -> m a +mtrace a = strace a `seq` return a + -- | trace an expression using a custom show function tracewith f e = trace (f e) e -- parsing +choice' :: [GenParser tok st a] -> GenParser tok st a choice' = choice . map Text.ParserCombinators.Parsec.try parsewith :: Parser a -> String -> Either ParseError a @@ -252,7 +294,7 @@ fromparse :: Either ParseError a -> a fromparse = either parseerror id -parseerror e = error $ showParseError e +parseerror e = error' $ showParseError e showParseError e = "parse error at " ++ show e diff --git a/Hledger/Read.hs b/Hledger/Read.hs --- a/Hledger/Read.hs +++ b/Hledger/Read.hs @@ -29,12 +29,12 @@ import System.Directory (doesFileExist, getHomeDirectory) import System.Environment (getEnv) import System.FilePath (()) -import System.IO (IOMode(..), withFile, hGetContents, stderr) +import System.IO (IOMode(..), withFile, stderr) #if __GLASGOW_HASKELL__ <= 610 -import Prelude hiding (readFile, putStr, putStrLn, print, getContents) -import System.IO.UTF8 +import Prelude hiding (getContents) +import System.IO.UTF8 (getContents, hGetContents) #else -import System.IO (hPutStrLn) +import System.IO (hGetContents) #endif @@ -70,7 +70,7 @@ Nothing -> readers (errors, journals) <- partitionEithers `fmap` mapM tryReader readers' case journals of j:_ -> return $ Right j - _ -> let s = errMsg errors in hPutStrLn stderr s >> return (Left s) + _ -> return $ Left $ errMsg errors where tryReader r = (runErrorT . (rParser r) fp) s errMsg [] = unknownFormatMsg @@ -104,7 +104,7 @@ emptyJournal :: IO String emptyJournal = do d <- getCurrentDay - return $ printf "; journal created %s; see http://hledger.org/MANUAL.html#journal-file\n\n" (show d) + return $ printf "; journal created %s by hledger\n\n" (show d) -- | Read a Journal from this string, using the specified data format or -- trying all known formats, or give an error string. @@ -129,11 +129,11 @@ -- | Read the user's default journal file, or give an error. myJournal :: IO Journal -myJournal = myJournalPath >>= readJournalFile Nothing >>= either error return +myJournal = myJournalPath >>= readJournalFile Nothing >>= either error' return -- | Read the user's default timelog file, or give an error. myTimelog :: IO Journal -myTimelog = myTimelogPath >>= readJournalFile Nothing >>= either error return +myTimelog = myTimelogPath >>= readJournalFile Nothing >>= either error' return tests_Hledger_Read = TestList [ @@ -141,7 +141,7 @@ "journalFile" ~: do assertBool "journalFile should parse an empty file" (isRight $ parseWithCtx emptyCtx Journal.journalFile "") jE <- readJournal Nothing "" -- don't know how to get it from journalFile - either error (assertBool "journalFile parsing an empty file should give an empty journal" . null . jtxns) jE + either error' (assertBool "journalFile parsing an empty file should give an empty journal" . null . jtxns) jE ,Journal.tests_Journal ,Timelog.tests_Timelog diff --git a/Hledger/Read/Common.hs b/Hledger/Read/Common.hs --- a/Hledger/Read/Common.hs +++ b/Hledger/Read/Common.hs @@ -36,7 +36,7 @@ tl <- liftIO getCurrentLocalTime case runParser p emptyCtx f s of Right updates -> liftM (journalFinalise tc tl f s) $ updates `ap` return nulljournal - Left err -> throwError $ show err -- XXX raises an uncaught exception if we have a parsec user error, eg from many ? + Left err -> throwError $ show err -- | Some state kept while parsing a journal file. data JournalContext = Ctx { diff --git a/Hledger/Read/Journal.hs b/Hledger/Read/Journal.hs --- a/Hledger/Read/Journal.hs +++ b/Hledger/Read/Journal.hs @@ -117,11 +117,13 @@ ) where import Control.Monad.Error (ErrorT(..), throwError, catchError) +import Data.List.Split (wordsBy) import Text.ParserCombinators.Parsec hiding (parse) #if __GLASGOW_HASKELL__ <= 610 import Prelude hiding (readFile, putStr, putStrLn, print, getContents) import System.IO.UTF8 #endif +import System.FilePath import Hledger.Data.Utils import Hledger.Data.Types import Hledger.Data.Dates @@ -213,7 +215,7 @@ outerPos <- getPosition let inIncluded = show outerPos ++ " in included file " ++ show filename ++ ":\n" return $ do contents <- expandPath outerPos filename >>= readFileE outerPos - case runParser journalFile outerState filename contents of + case runParser journalFile outerState (combine ((takeDirectory . sourceName) outerPos) filename) contents of Right l -> l `catchError` (throwError . (inIncluded ++)) Left perr -> throwError $ inIncluded ++ show perr where readFileE outerPos filename = ErrorT $ liftM Right (readFile filename) `catch` leftError @@ -331,21 +333,27 @@ Left err -> fail err ledgerdate :: GenParser Char JournalContext Day -ledgerdate = choice' [ledgerfulldate, ledgerpartialdate] "full or partial date" - -ledgerfulldate :: GenParser Char JournalContext Day -ledgerfulldate = do - (y,m,d) <- ymd - return $ fromGregorian (read y) (read m) (read d) - --- | Match a partial M/D date in a ledger, and also require that a default --- year directive was previously encountered. -ledgerpartialdate :: GenParser Char JournalContext Day -ledgerpartialdate = do - (_,m,d) <- md - y <- getYear - when (isNothing y) $ fail "partial date found, but no default year specified" - return $ fromGregorian (fromJust y) (read m) (read d) +ledgerdate = do + -- hacky: try to ensure precise errors for invalid dates + -- XXX reported error position is not too good + -- pos <- getPosition + datestr <- many1 $ choice' [digit, datesepchar] + let dateparts = wordsBy (`elem` datesepchars) datestr + case dateparts of + [y,m,d] -> do + failIfInvalidYear y + failIfInvalidMonth m + failIfInvalidDay d + return $ fromGregorian (read y) (read m) (read d) + [m,d] -> do + y <- getYear + case y of Nothing -> fail "partial date found, but no default year specified" + Just y' -> do failIfInvalidYear $ show y' + failIfInvalidMonth m + failIfInvalidDay d + return $ fromGregorian y' (read m) (read d) + _ -> fail $ "bad date: " ++ datestr + "full or partial date" ledgerdatetime :: GenParser Char JournalContext LocalTime ledgerdatetime = do 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.11.1 +version: 0.12 category: Finance synopsis: Core types and utilities for working with hledger (or c++ ledger) data. description: @@ -14,7 +14,7 @@ bug-reports: http://code.google.com/p/hledger/issues stability: experimental tested-with: GHC==6.10 -cabal-version: >= 1.2 +cabal-version: >= 1.6 build-type: Simple -- data-dir: -- data-files: @@ -56,17 +56,14 @@ ,parsec ,regexpr >= 0.5.1 ,safe >= 0.2 + ,split == 0.1.* ,time ,utf8-string >= 0.3 ,HUnit --- source-repository head --- type: darcs --- location: http://joyful.com/repos/hledger --- disabled for now due to: --- The 'source-repository' section is new in Cabal-1.6. Unfortunately it messes --- up the parser in earlier Cabal versions so you need to specify 'cabal-version: --- >= 1.6'. +source-repository head + type: darcs + location: http://joyful.com/repos/hledger -- cf http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html