From 514f015849c69a5c9e98dac7ae88ee38a7de52ad Mon Sep 17 00:00:00 2001 From: tim Date: Tue, 11 Nov 2008 12:34:05 +0000 Subject: [PATCH] Implemented types for dates and datetimes This patch replaces the strings used in the Entry, TimeLogEntry, and Transaction records with real types. Rather than use the inbuild system date and time types directly, two custom types have been implemented that wrap UTCTime: Date and DateTime. A minimal API for these has been added. --- Ledger/Dates.hs | 66 +++++++++++++++++++++++++++++++++++++++++++ Ledger/Entry.hs | 4 +-- Ledger/Parse.hs | 25 ++++++++++++---- Ledger/RawLedger.hs | 9 ++---- Ledger/TimeLog.hs | 13 ++++----- Ledger/Transaction.hs | 4 +-- Ledger/Types.hs | 4 --- Ledger/Utils.hs | 27 ++---------------- RegisterCommand.hs | 2 +- Tests.hs | 18 ++++++------ Utils.hs | 4 +-- hledger.hs | 7 +++-- 12 files changed, 117 insertions(+), 66 deletions(-) create mode 100644 Ledger/Dates.hs diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs new file mode 100644 index 000000000..85b14eee7 --- /dev/null +++ b/Ledger/Dates.hs @@ -0,0 +1,66 @@ +{-| + +Types for Dates and DateTimes, implemented in terms of UTCTime + +-} + +module Ledger.Dates( + Date, + DateTime, + mkDate, + mkDateTime, + parsedatetime, + parsedate, + datetimeToDate, + elapsedSeconds + ) where + +import Data.Time.Clock +import Data.Time.Format +import Data.Time.Calendar +import Data.Time.LocalTime +import System.Locale (defaultTimeLocale) +import Text.Printf +import Data.Maybe + +newtype Date = Date UTCTime + deriving (Ord, Eq) + +newtype DateTime = DateTime UTCTime + deriving (Ord, Eq) + +instance Show Date where + show (Date t) = formatTime defaultTimeLocale "%Y/%m/%d" t + +instance Show DateTime where + show (DateTime t) = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" t + +mkDate :: Day -> Date +mkDate day = Date (localTimeToUTC utc (LocalTime day midnight)) + +mkDateTime :: Day -> TimeOfDay -> DateTime +mkDateTime day tod = DateTime (localTimeToUTC utc (LocalTime day tod)) + +-- | Parse a date-time string to a time type, or raise an error. +parsedatetime :: String -> DateTime +parsedatetime s = DateTime $ + parsetimewith "%Y/%m/%d %H:%M:%S" s $ + error $ printf "could not parse timestamp \"%s\"" s + +-- | Parse a date string to a time type, or raise an error. +parsedate :: String -> Date +parsedate s = Date $ + parsetimewith "%Y/%m/%d" s $ + error $ printf "could not parse date \"%s\"" s + +-- | 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 + +datetimeToDate :: DateTime -> Date +datetimeToDate (DateTime (UTCTime{utctDay=day})) = Date (UTCTime day 0) + +elapsedSeconds :: Fractional a => DateTime -> DateTime -> a +elapsedSeconds (DateTime dt1) (DateTime dt2) = realToFrac $ diffUTCTime dt1 dt2 + diff --git a/Ledger/Entry.hs b/Ledger/Entry.hs index 39324d9a6..eda52d45a 100644 --- a/Ledger/Entry.hs +++ b/Ledger/Entry.hs @@ -22,7 +22,7 @@ instance Show PeriodicEntry where show e = "~ " ++ (periodexpr e) ++ "\n" ++ unlines (map show (p_transactions e)) nullentry = Entry { - edate="", + edate=parsedate "1900/1/1", estatus=False, ecode="", edescription="", @@ -67,7 +67,7 @@ showEntry e = showaccountname s = printf "%-34s" s showcomment s = if (length s) > 0 then " ; "++s else "" -showDate = printf "%-10s" +showDate d = printf "%-10s" (show d) isEntryBalanced :: Entry -> Bool isEntryBalanced (Entry {etransactions=ts}) = diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs index 946438e50..75f030967 100644 --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -19,6 +19,8 @@ import Ledger.Amount import Ledger.Entry import Ledger.Commodity import Ledger.TimeLog +import Data.Time.LocalTime +import Data.Time.Calendar -- utils @@ -233,15 +235,28 @@ ledgerentry = do transactions <- ledgertransactions return $ balanceEntry $ Entry date status code description comment transactions (unlines preceding) -ledgerdate :: Parser String -ledgerdate = do +ledgerday :: Parser Day +ledgerday = do y <- many1 digit char '/' m <- many1 digit char '/' d <- many1 digit many1 spacenonewline - return $ printf "%04s/%02s/%02s" y m d + return (fromGregorian (read y) (read m) (read d)) + +ledgerdate :: Parser Date +ledgerdate = fmap mkDate ledgerday + +ledgerdatetime :: Parser DateTime +ledgerdatetime = do + day <- ledgerday + h <- many1 digit + char ':' + m <- many1 digit + many1 spacenonewline + return (mkDateTime day (TimeOfDay (read h) (read m) 0)) + ledgerstatus :: Parser Bool ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False @@ -452,9 +467,7 @@ timelogentry = do many (commentline <|> blankline) code <- oneOf "bhioO" many1 spacenonewline - date <- ledgerdate - time <- many $ oneOf "0123456789:" - let datetime = date ++ " " ++ time + datetime <- ledgerdatetime many spacenonewline comment <- restofline return $ TimeLogEntry code datetime comment diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs index d6730d132..72845b473 100644 --- a/Ledger/RawLedger.hs +++ b/Ledger/RawLedger.hs @@ -43,7 +43,7 @@ rawLedgerAccountNameTree l = accountNameTreeFrom $ rawLedgerAccountNames l -- | Remove ledger entries we are not interested in. -- Keep only those which fall between the begin and end dates, and match -- the description pattern, and are cleared or real if those options are active. -filterRawLedger :: Date -> Date -> [String] -> Bool -> Bool -> RawLedger -> RawLedger +filterRawLedger :: Maybe Date -> Maybe Date -> [String] -> Bool -> Bool -> RawLedger -> RawLedger filterRawLedger begin end pats clearedonly realonly = filterRawLedgerTransactionsByRealness realonly . filterRawLedgerEntriesByClearedStatus clearedonly . @@ -59,14 +59,11 @@ filterRawLedgerEntriesByDescription pats (RawLedger ms ps es f) = -- | Keep only entries which fall between begin and end dates. -- We include entries on the begin date and exclude entries on the end -- date, like ledger. An empty date string means no restriction. -filterRawLedgerEntriesByDate :: Date -> Date -> RawLedger -> RawLedger +filterRawLedgerEntriesByDate :: Maybe Date -> Maybe Date -> RawLedger -> RawLedger filterRawLedgerEntriesByDate begin end (RawLedger ms ps es f) = RawLedger ms ps (filter matchdate es) f where - d1 = parsedate begin :: UTCTime - d2 = parsedate end - matchdate e = (null begin || d >= d1) && (null end || d < d2) - where d = parsedate $ edate e + matchdate e = (maybe True (edate e>=) begin) && (maybe True (edate e<) end) -- | Keep only entries with cleared status, if the flag is true, otherwise -- do no filtering. diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs index 96f0c1a2b..69a878b42 100644 --- a/Ledger/TimeLog.hs +++ b/Ledger/TimeLog.hs @@ -15,7 +15,7 @@ import Ledger.Amount instance Show TimeLogEntry where - show t = printf "%s %s %s" (show $ tlcode t) (tldatetime t) (tlcomment t) + show t = printf "%s %s %s" (show $ tlcode t) (show $ tldatetime t) (tlcomment t) instance Show TimeLog where show tl = printf "TimeLog with %d entries" $ length $ timelog_entries tl @@ -52,12 +52,11 @@ entryFromTimeLogInOut i o = } where acctname = tlcomment i - indate = showdate intime - outdate = showdate outtime - showdate = formatTime defaultTimeLocale "%Y/%m/%d" - intime = parsedatetime $ tldatetime i - outtime = parsedatetime $ tldatetime o - amount = Mixed [hours $ realToFrac (diffUTCTime outtime intime) / 3600] + indate = datetimeToDate intime + outdate = datetimeToDate outtime + intime = tldatetime i + outtime = tldatetime o + amount = Mixed [hours $ elapsedSeconds outtime intime / 3600] txns = [RawTransaction acctname amount "" RegularTransaction --,RawTransaction "assets:time" (-amount) "" RegularTransaction ] diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs index ab595c680..4c41df58e 100644 --- a/Ledger/Transaction.hs +++ b/Ledger/Transaction.hs @@ -17,7 +17,7 @@ import Ledger.Amount instance Show Transaction where show=showTransaction showTransaction :: Transaction -> String -showTransaction (Transaction eno d desc a amt ttype) = unwords [d,desc,a,show amt,show ttype] +showTransaction (Transaction eno d desc a amt ttype) = unwords [show d,desc,a,show amt,show ttype] -- | Convert a 'Entry' to two or more 'Transaction's. An id number -- is attached to the transactions to preserve their grouping - it should @@ -32,4 +32,4 @@ accountNamesFromTransactions ts = nub $ map account ts sumTransactions :: [Transaction] -> MixedAmount sumTransactions = sum . map amount -nulltxn = Transaction 0 "" "" "" nullamt RegularTransaction +nulltxn = Transaction 0 (parsedate "1900/1/1") "" "" nullamt RegularTransaction diff --git a/Ledger/Types.hs b/Ledger/Types.hs index 6f8597802..de5f938c7 100644 --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -11,10 +11,6 @@ import Ledger.Utils import qualified Data.Map as Map -type Date = String - -type DateTime = String - type AccountName = String data Side = L | R deriving (Eq,Show) diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs index 97babfddb..dc534e3f9 100644 --- a/Ledger/Utils.hs +++ b/Ledger/Utils.hs @@ -11,15 +11,13 @@ module Data.List, --module Data.Map, module Data.Maybe, module Data.Ord, -module Data.Time.Clock, -module Data.Time.Format, module Data.Tree, module Debug.Trace, module Ledger.Utils, -module System.Locale, module Text.Printf, module Text.Regex, module Test.HUnit, +module Ledger.Dates, ) where import Char @@ -28,16 +26,14 @@ import Data.List --import qualified Data.Map as Map import Data.Maybe import Data.Ord -import Data.Time.Clock (UTCTime, diffUTCTime) -import Data.Time.Format (ParseTime, parseTime, formatTime) import Data.Tree import Debug.Trace -import System.Locale (defaultTimeLocale) import Test.HUnit import Test.QuickCheck hiding (test, Testable) import Text.Printf import Text.Regex import Text.ParserCombinators.Parsec (parse) +import Ledger.Dates elideLeft width s = @@ -59,25 +55,6 @@ containsRegex r s = case matchRegex r s of Just _ -> True otherwise -> False --- time - --- | Parse a date-time string to a time type, or raise an error. -parsedatetime :: ParseTime t => String -> t -parsedatetime s = - parsetimewith "%Y/%m/%d %H:%M:%S" s $ - error $ printf "could not parse timestamp \"%s\"" s - --- | Parse a date string to a time type, or raise an error. -parsedate :: ParseTime t => String -> t -parsedate s = - parsetimewith "%Y/%m/%d" s $ - error $ printf "could not parse date \"%s\"" s - --- | 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 - -- lists splitAtElement :: Eq a => a -> [a] -> [[a]] diff --git a/RegisterCommand.hs b/RegisterCommand.hs index 516ef4d6d..ee92ca7d7 100644 --- a/RegisterCommand.hs +++ b/RegisterCommand.hs @@ -46,7 +46,7 @@ showRegisterReport opts args l = showtxns ts nulltxn nullamt showtxn omitdesc t b = entrydesc ++ txn ++ bal ++ "\n" where entrydesc = if omitdesc then replicate 32 ' ' else printf "%s %s " date desc - date = showDate $ da + date = show $ da desc = printf "%-20s" $ elideRight 20 de :: String txn = showRawTransaction $ RawTransaction a amt "" tt bal = printf " %12s" (showMixedAmountOrZero b) diff --git a/Tests.hs b/Tests.hs index 4895d3058..7d791c181 100644 --- a/Tests.hs +++ b/Tests.hs @@ -274,7 +274,7 @@ entry1_str = "\ \\n" --" entry1 = - (Entry "2007/01/28" False "" "coopportunity" "" + (Entry (parsedate "2007/01/28") False "" "coopportunity" "" [RawTransaction "expenses:food:groceries" (Mixed [dollars 47.18]) "" RegularTransaction, RawTransaction "assets:checking" (Mixed [dollars (-47.18)]) "" RegularTransaction] "") @@ -412,7 +412,7 @@ rawledger7 = RawLedger [] [ Entry { - edate="2007/01/01", + edate= parsedate "2007/01/01", estatus=False, ecode="*", edescription="opening balance", @@ -435,7 +435,7 @@ rawledger7 = RawLedger } , Entry { - edate="2007/02/01", + edate= parsedate "2007/02/01", estatus=False, ecode="*", edescription="ayres suites", @@ -458,7 +458,7 @@ rawledger7 = RawLedger } , Entry { - edate="2007/01/02", + edate=parsedate "2007/01/02", estatus=False, ecode="*", edescription="auto transfer to savings", @@ -481,7 +481,7 @@ rawledger7 = RawLedger } , Entry { - edate="2007/01/03", + edate=parsedate "2007/01/03", estatus=False, ecode="*", edescription="poquito mas", @@ -504,7 +504,7 @@ rawledger7 = RawLedger } , Entry { - edate="2007/01/03", + edate=parsedate "2007/01/03", estatus=False, ecode="*", edescription="verizon", @@ -527,7 +527,7 @@ rawledger7 = RawLedger } , Entry { - edate="2007/01/03", + edate=parsedate "2007/01/03", estatus=False, ecode="*", edescription="discover", @@ -554,10 +554,10 @@ rawledger7 = RawLedger ledger7 = cacheLedger rawledger7 timelogentry1_str = "i 2007/03/11 16:19:00 hledger\n" -timelogentry1 = TimeLogEntry 'i' "2007/03/11 16:19:00" "hledger" +timelogentry1 = TimeLogEntry 'i' (parsedatetime "2007/03/11 16:19:00") "hledger" timelogentry2_str = "o 2007/03/11 16:30:00\n" -timelogentry2 = TimeLogEntry 'o' "2007/03/11 16:30:00" "" +timelogentry2 = TimeLogEntry 'o' (parsedatetime "2007/03/11 16:30:00") "" timelog1_str = concat [ timelogentry1_str, diff --git a/Utils.hs b/Utils.hs index 517b45541..dd1de7fe2 100644 --- a/Utils.hs +++ b/Utils.hs @@ -21,7 +21,7 @@ rawledgerfromfile f = do ledgerfromfile :: FilePath -> IO Ledger ledgerfromfile f = do l <- rawledgerfromfile f - return $ cacheLedger $ filterRawLedger "" "" [] False False l + return $ cacheLedger $ filterRawLedger Nothing Nothing [] False False l -- | get a RawLedger from the file your LEDGER environment variable -- variable points to or (WARNING) an empty one if there was a problem. @@ -35,7 +35,7 @@ myrawledger = do myledger :: IO Ledger myledger = do l <- myrawledger - return $ cacheLedger $ filterRawLedger "" "" [] False False l + return $ cacheLedger $ filterRawLedger Nothing Nothing [] False False l -- | get a named account from your ledger file myaccount :: AccountName -> IO Account diff --git a/hledger.hs b/hledger.hs index 916403103..128befbe4 100644 --- a/hledger.hs +++ b/hledger.hs @@ -64,6 +64,9 @@ main = do | cmd `isPrefixOf` "test" = runtests args >> return () | otherwise = putStr usage +parsemaybedate "" = Nothing +parsemaybedate s = Just (parsedate s) + -- | parse the user's specified ledger file and do some action with it -- (or report a parse error). This function makes the whole thing go. parseLedgerAndDo :: [Opt] -> [String] -> ([Opt] -> [String] -> Ledger -> IO ()) -> IO () @@ -71,8 +74,8 @@ parseLedgerAndDo opts args cmd = ledgerFilePathFromOpts opts >>= parseLedgerFile >>= either printParseError runcmd where runcmd = cmd opts args . cacheLedger . setAmountDisplayPrefs . filterRawLedger b e dpats c r - b = beginDateFromOpts opts - e = endDateFromOpts opts + b = parsemaybedate (beginDateFromOpts opts) + e = parsemaybedate (endDateFromOpts opts) dpats = snd $ parseAccountDescriptionArgs args c = Cleared `elem` opts r = Real `elem` opts