From ae5a9439d0eae8394f731a932e948305a0a63c42 Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Sun, 25 Jan 2009 07:06:59 +0000 Subject: [PATCH] count time elapsed in open timelog entries, ignore time zone Any open sessions in a timelog will be considered clocked out as of the current time, and included in calculations. Also, contrary to the earlier patch we now ignore timezone everywhere and deal only with local times. This might need revisiting eg to track time while crossing timezones. --- Ledger/Dates.hs | 7 ++----- Ledger/Parse.hs | 40 ++++++++++++++++++---------------------- Ledger/RawLedger.hs | 11 ++++++----- Ledger/TimeLog.hs | 38 ++++++++++++++++++-------------------- Ledger/Types.hs | 2 +- Utils.hs | 14 +++++++++----- hledger.hs | 8 ++++---- 7 files changed, 58 insertions(+), 62 deletions(-) diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs index e5674a979..6d7910c4b 100644 --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -47,9 +47,6 @@ getCurrentDay = do elapsedSeconds :: Fractional a => UTCTime -> UTCTime -> a elapsedSeconds t1 t2 = realToFrac $ diffUTCTime t1 t2 -dayToUTC :: Day -> UTCTime -dayToUTC d = localTimeToUTC utc (LocalTime d midnight) - -- | Split a DateSpan into one or more consecutive spans at the specified interval. splitSpan :: Interval -> DateSpan -> [DateSpan] splitSpan i (DateSpan Nothing Nothing) = [DateSpan Nothing Nothing] @@ -192,14 +189,14 @@ firstJust ms = case dropWhile (==Nothing) ms of [] -> Nothing (md:_) -> md -parsedatetimeM :: String -> Maybe UTCTime +parsedatetimeM :: String -> Maybe LocalTime parsedatetimeM s = firstJust [ parseTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" s, parseTime defaultTimeLocale "%Y-%m-%d %H:%M:%S" s ] -- | Parse a date-time string to a time type, or raise an error. -parsedatetime :: String -> UTCTime +parsedatetime :: String -> LocalTime parsedatetime s = fromMaybe (error $ "could not parse timestamp \"" ++ s ++ "\"") (parsedatetimeM s) diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs index 71729e977..56942b4ba 100644 --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -33,14 +33,13 @@ import System.FilePath(takeDirectory,combine) -- | Some context kept during parsing. data LedgerFileCtx = Ctx { - ctxTimeZone :: !TimeZone -- ^ the user's timezone - , ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y + ctxYear :: !(Maybe Integer) -- ^ the default year most recently specified with Y , ctxCommod :: !(Maybe String) -- ^ I don't know , ctxAccount :: ![String] -- ^ the current stack of "container" accounts specified by !account } deriving (Read, Show) emptyCtx :: LedgerFileCtx -emptyCtx = Ctx { ctxTimeZone=utc, ctxYear=Nothing, ctxCommod=Nothing, ctxAccount=[] } +emptyCtx = Ctx { ctxYear = Nothing, ctxCommod = Nothing, ctxAccount = [] } -- containing accounts "nest" hierarchically @@ -64,25 +63,23 @@ setYear y = updateState (\ctx -> ctx{ctxYear=Just y}) getYear :: GenParser tok LedgerFileCtx (Maybe Integer) getYear = liftM ctxYear getState -setTimeZone :: TimeZone -> GenParser tok LedgerFileCtx () -setTimeZone tz = updateState (\ctx -> ctx{ctxTimeZone=tz}) - -getCtxTimeZone :: GenParser tok LedgerFileCtx TimeZone -getCtxTimeZone = liftM ctxTimeZone getState - --- let's get to it - -parseLedgerFile :: FilePath -> ErrorT String IO RawLedger -parseLedgerFile "-" = liftIO (hGetContents stdin) >>= parseLedger "-" -parseLedgerFile f = liftIO (readFile f) >>= parseLedger f - printParseError :: (Show a) => a -> IO () printParseError e = do putStr "ledger parse error at "; print e -parseLedger :: FilePath -> String -> ErrorT String IO RawLedger -parseLedger inname intxt = case runParser ledgerFile emptyCtx inname intxt of - Right m -> liftM rawLedgerConvertTimeLog $ m `ap` (return rawLedgerEmpty) - Left err -> throwError $ show err +-- let's get to it + +parseLedgerFile :: LocalTime -> FilePath -> ErrorT String IO RawLedger +parseLedgerFile t "-" = liftIO (hGetContents stdin) >>= parseLedger t "-" +parseLedgerFile t f = liftIO (readFile f) >>= parseLedger t f + +-- | Parses the contents of a ledger file, or gives an error. Requires +-- the current (local) time to calculate any unfinished timelog sessions, +-- we pass it in for repeatability. +parseLedger :: LocalTime -> FilePath -> String -> ErrorT String IO RawLedger +parseLedger reftime inname intxt = do + case runParser ledgerFile emptyCtx inname intxt of + Right m -> liftM (rawLedgerConvertTimeLog reftime) $ m `ap` (return rawLedgerEmpty) + Left err -> throwError $ show err -- As all ledger line types can be distinguished by the first -- character, excepting transactions versus empty (blank or @@ -337,7 +334,7 @@ ledgerpartialdate = do when (y==Nothing) $ error "partial date found, but no default year specified" return $ fromGregorian (fromJust y) (read m) (read d) -ledgerdatetime :: GenParser Char LedgerFileCtx UTCTime +ledgerdatetime :: GenParser Char LedgerFileCtx LocalTime ledgerdatetime = do day <- ledgerdate h <- many1 digit @@ -348,8 +345,7 @@ ledgerdatetime = do many1 digit many spacenonewline let tod = TimeOfDay (read h) (read m) (maybe 0 (fromIntegral.read) s) - tz <- getCtxTimeZone - return $ localTimeToUTC tz (LocalTime day tod) + return $ LocalTime day tod ledgerstatus :: GenParser Char st Bool ledgerstatus = try (do { char '*'; many1 spacenonewline; return True } ) <|> return False diff --git a/Ledger/RawLedger.hs b/Ledger/RawLedger.hs index 9da8610c8..1883b2297 100644 --- a/Ledger/RawLedger.hs +++ b/Ledger/RawLedger.hs @@ -147,9 +147,10 @@ rawLedgerCommodities = map commodity . concatMap amounts . rawLedgerAmounts rawLedgerPrecisions :: RawLedger -> [Int] rawLedgerPrecisions = map precision . rawLedgerCommodities -rawLedgerConvertTimeLog :: RawLedger -> RawLedger -rawLedgerConvertTimeLog l0 = l0 { entries = convertedTimeLog ++ entries l0 - , open_timelog_entries = [] - } - where convertedTimeLog = entriesFromTimeLogEntries $ open_timelog_entries l0 +-- | Close any open timelog sessions using the provided current time. +rawLedgerConvertTimeLog :: LocalTime -> RawLedger -> RawLedger +rawLedgerConvertTimeLog t l0 = l0 { entries = convertedTimeLog ++ entries l0 + , open_timelog_entries = [] + } + where convertedTimeLog = entriesFromTimeLogEntries t $ open_timelog_entries l0 diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs index 94e787749..48b23d91e 100644 --- a/Ledger/TimeLog.hs +++ b/Ledger/TimeLog.hs @@ -21,43 +21,41 @@ instance Show TimeLogEntry where instance Show TimeLog where show tl = printf "TimeLog with %d entries" $ length $ timelog_entries tl --- | Convert time log entries to ledger entries. -entriesFromTimeLogEntries :: [TimeLogEntry] -> [Entry] -entriesFromTimeLogEntries [] = [] -entriesFromTimeLogEntries [i] = entriesFromTimeLogEntries [i, clockoutFor i] -entriesFromTimeLogEntries (i:o:rest) = [entryFromTimeLogInOut i o] ++ entriesFromTimeLogEntries rest - --- | When there is a trailing clockin entry, provide the missing clockout. --- An entry for now is what we want but this requires IO so for now use --- the clockin time, ie don't count the current clocked-in period. -clockoutFor :: TimeLogEntry -> TimeLogEntry -clockoutFor (TimeLogEntry _ t _) = TimeLogEntry 'o' t "" +-- | Convert time log entries to ledger entries. When there is no clockout, +-- add one with the provided current time. +entriesFromTimeLogEntries :: LocalTime -> [TimeLogEntry] -> [Entry] +entriesFromTimeLogEntries _ [] = [] +entriesFromTimeLogEntries t [i] = [entryFromTimeLogInOut i (TimeLogEntry 'o' t "")] +entriesFromTimeLogEntries t (i:o:rest) = [entryFromTimeLogInOut i o] ++ entriesFromTimeLogEntries t rest -- | Convert a timelog clockin and clockout entry to an equivalent ledger -- entry, representing the time expenditure. Note this entry is not balanced, -- since we omit the \"assets:time\" transaction for simpler output. entryFromTimeLogInOut :: TimeLogEntry -> TimeLogEntry -> Entry entryFromTimeLogInOut i o - | outtime >= intime = e + | otime >= itime = e | otherwise = error $ "clock-out time less than clock-in time in:\n" ++ showEntry e where e = Entry { - edate = outdate, -- like ledger + edate = odate, -- like ledger estatus = True, ecode = "", - edescription = showtime intime ++ " - " ++ showtime outtime, + edescription = showtime itod ++ "-" ++ showtime otod, ecomment = "", etransactions = txns, epreceding_comment_lines="" } - showtime = show . timeToTimeOfDay . utctDayTime + showtime = take 5 . show acctname = tlcomment i - indate = utctDay intime - outdate = utctDay outtime - intime = tldatetime i - outtime = tldatetime o - amount = Mixed [hours $ elapsedSeconds outtime intime / 3600] + itime = tldatetime i + otime = tldatetime o + itod = localTimeOfDay itime + otod = localTimeOfDay otime + idate = localDay itime + odate = localDay otime + hrs = elapsedSeconds (toutc otime) (toutc itime) / 3600 where toutc = localTimeToUTC utc + amount = Mixed [hours hrs] txns = [RawTransaction acctname amount "" RegularTransaction --,RawTransaction "assets:time" (-amount) "" RegularTransaction ] diff --git a/Ledger/Types.hs b/Ledger/Types.hs index f0a326070..e82d56e2e 100644 --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -91,7 +91,7 @@ data RawLedger = RawLedger { data TimeLogEntry = TimeLogEntry { tlcode :: Char, - tldatetime :: UTCTime, + tldatetime :: LocalTime, tlcomment :: String } deriving (Eq,Ord) diff --git a/Utils.hs b/Utils.hs index 011c182bd..45df7c092 100644 --- a/Utils.hs +++ b/Utils.hs @@ -17,22 +17,26 @@ import Ledger -- | Convert a RawLedger to a canonicalised, cached and filtered Ledger -- based on the command-line options/arguments and the current date/time. -prepareLedger :: [Opt] -> [String] -> UTCTime -> String -> RawLedger -> Ledger +prepareLedger :: [Opt] -> [String] -> LocalTime -> String -> RawLedger -> Ledger prepareLedger opts args reftime rawtext rl = l{rawledgertext=rawtext} where l = cacheLedger apats $ filterRawLedger span dpats c r $ canonicaliseAmounts cb rl (apats,dpats) = parseAccountDescriptionArgs [] args - span = dateSpanFromOpts (utctDay reftime) opts + span = dateSpanFromOpts (localDay reftime) opts c = Cleared `elem` opts r = Real `elem` opts cb = CostBasis `elem` opts -- | Get a RawLedger from the given string, or raise an error. +-- This uses the current local time as the reference time (for closing +-- open timelog entries). rawledgerfromstring :: String -> IO RawLedger -rawledgerfromstring = liftM (either error id) . runErrorT . parseLedger "(string)" +rawledgerfromstring s = do + t <- getCurrentLocalTime + liftM (either error id) $ runErrorT $ parseLedger t "(string)" s -- | Get a Ledger from the given string and options, or raise an error. -ledgerfromstringwithopts :: [Opt] -> [String] -> UTCTime -> String -> IO Ledger +ledgerfromstringwithopts :: [Opt] -> [String] -> LocalTime -> String -> IO Ledger ledgerfromstringwithopts opts args reftime s = liftM (prepareLedger opts args reftime s) $ rawledgerfromstring s @@ -41,7 +45,7 @@ ledgerfromfilewithopts :: [Opt] -> [String] -> FilePath -> IO Ledger ledgerfromfilewithopts opts args f = do s <- readFile f rl <- rawledgerfromstring s - reftime <- getCurrentTime + reftime <- getCurrentLocalTime return $ prepareLedger opts args reftime s rl -- | Get a Ledger from your default ledger file, or raise an error. diff --git a/hledger.hs b/hledger.hs index d6a51fb9d..60fcae7d4 100644 --- a/hledger.hs +++ b/hledger.hs @@ -50,6 +50,7 @@ import Version (versionmsg) import Ledger import Utils import Options +import Tests import BalanceCommand import PrintCommand import RegisterCommand @@ -62,7 +63,6 @@ import qualified ANSICommand #ifdef HAPPS import qualified WebCommand #endif -import Tests main :: IO () @@ -97,6 +97,6 @@ parseLedgerAndDo opts args cmd = do -- and, doesn't work with stdin. kludge it, stdin won't work with ui command let f' = if f == "-" then "/dev/null" else f rawtext <- readFile f' - reftime <- getCurrentTime - let runcmd = cmd opts args . prepareLedger opts args reftime rawtext - return f >>= runErrorT . parseLedgerFile >>= either (hPutStrLn stderr) runcmd + t <- getCurrentLocalTime + let runcmd = cmd opts args . prepareLedger opts args t rawtext + return f >>= runErrorT . parseLedgerFile t >>= either (hPutStrLn stderr) runcmd