From 884ebf2979b8a5225a5fff2ebdce01e5386f842e Mon Sep 17 00:00:00 2001 From: Simon Michael Date: Thu, 27 Nov 2008 00:35:00 +0000 Subject: [PATCH] gather date stuff together, FuzzyDate -> SmartDate --- Ledger.hs | 2 + Ledger/Dates.hs | 215 ++++++++++++++++++++++++++++++++++-------- Ledger/Entry.hs | 1 + Ledger/Parse.hs | 119 +---------------------- Ledger/TimeLog.hs | 1 + Ledger/Transaction.hs | 1 + Ledger/Types.hs | 9 +- Ledger/Utils.hs | 22 +++-- Options.hs | 44 ++------- Tests.hs | 5 +- 10 files changed, 218 insertions(+), 201 deletions(-) diff --git a/Ledger.hs b/Ledger.hs index 151579b13..38b269420 100644 --- a/Ledger.hs +++ b/Ledger.hs @@ -10,6 +10,7 @@ module Ledger ( module Ledger.AccountName, module Ledger.Amount, module Ledger.Commodity, + module Ledger.Dates, module Ledger.Entry, module Ledger.Ledger, module Ledger.Parse, @@ -25,6 +26,7 @@ import Ledger.Account import Ledger.AccountName import Ledger.Amount import Ledger.Commodity +import Ledger.Dates import Ledger.Entry import Ledger.Ledger import Ledger.Parse diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs index 33b8814c7..04269f59b 100644 --- a/Ledger/Dates.hs +++ b/Ledger/Dates.hs @@ -1,21 +1,16 @@ {-| -Types for Dates and DateTimes, implemented in terms of UTCTime +'Date' and 'DateTime' are a helper layer on top of the standard UTCTime, +Day etc. + +A 'SmartDate' is a date which may be partially-specified or relative. +Eg 2008/12/31, but also 2008/12, 12/31, tomorrow, last week, next year. +We represent these as a triple of strings like ("2008","12",""), +("","","tomorrow"), ("","last","week"). -} module Ledger.Dates ---( --- Date, --- DateTime, --- mkDate, --- mkDateTime, --- parsedatetime, --- parsedate, --- datetimeToDate, --- elapsedSeconds, --- today --- ) where import Data.Time.Clock @@ -25,12 +20,12 @@ import Data.Time.LocalTime import System.Locale (defaultTimeLocale) import Text.Printf import Data.Maybe +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Char +import Text.ParserCombinators.Parsec.Combinator +import Ledger.Types +import Ledger.Utils -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 @@ -38,12 +33,6 @@ instance Show Date where instance Show DateTime where show (DateTime t) = formatTime defaultTimeLocale "%Y/%m/%d %H:%M:%S" t --- | A fuzzy date is either a partially-specified or a relative date. --- We represent it as a triple of strings such as --- ("2008","01","01") or ("2008","","") or ("","","tomorrow") or --- ("","last|this|next","day|week|month|quarter|year"). -type FuzzyDate = (String,String,String) - mkDate :: Day -> Date mkDate day = Date (localTimeToUTC utc (LocalTime day midnight)) @@ -58,23 +47,6 @@ today = do now :: IO DateTime now = fmap DateTime getCurrentTime --- | 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) @@ -92,3 +64,166 @@ dateDay date = d where (_,_,d) = dateComponents date -- dateMonth :: Date -> Day dateMonth date = m where (_,m,_) = dateComponents date + +-- | Convert a fuzzy date string to an explicit yyyy/mm/dd string using +-- the provided date as reference point. +fixSmartDateStr :: Date -> String -> String +fixSmartDateStr t s = printf "%04d/%02d/%02d" y m d + where + pdate = fromparse $ parsewith smartdate $ map toLower s + (y,m,d) = dateComponents $ fixSmartDate t pdate + +-- | Convert a SmartDate to an absolute date using the provided date as +-- reference point. +fixSmartDate :: Date -> SmartDate -> Date +fixSmartDate refdate sdate = mkDate $ fromGregorian y m d + where + (y,m,d) = fix sdate + fix :: SmartDate -> (Integer,Int,Int) + fix ("","","today") = (ry, rm, rd) + fix ("","this","day") = (ry, rm, rd) + fix ("","","yesterday") = dateComponents $ lastday refdate + fix ("","last","day") = dateComponents $ lastday refdate + fix ("","","tomorrow") = dateComponents $ nextday refdate + fix ("","next","day") = dateComponents $ nextday refdate + fix ("","last","week") = dateComponents $ lastweek refdate + fix ("","this","week") = dateComponents $ thisweek refdate + fix ("","next","week") = dateComponents $ nextweek refdate + fix ("","",d) = (ry, rm, read d) + fix ("",m,d) = (ry, read m, read d) + fix (y,m,d) = (read y, read m, read d) + (ry,rm,rd) = dateComponents refdate + +lastday, nextday :: Date -> Date +lastday = mkDate . (addDays (-1)) . utctDay . dateToUTC +nextday = mkDate . (addDays 1) . utctDay . dateToUTC +lastweek = mkDate . (addDays (-7)) . utctDay . dateToUTC +thisweek = mkDate . (addDays 0) . utctDay . dateToUTC +nextweek = mkDate . (addDays 7) . utctDay . dateToUTC + +---------------------------------------------------------------------- +-- parsing + +-- | 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 + +{-| +Parse a date in any of the formats allowed in ledger's period expressions, +and maybe some others: + +> 2004 +> 2004/10 +> 2004/10/1 +> 10/1 +> 21 +> october, oct +> yesterday, today, tomorrow +> (not yet) this/next/last week/day/month/quarter/year + +Returns a SmartDate, to be converted to a full date later (see fixSmartDate). +Assumes any text in the parse stream has been lowercased. +-} +smartdate :: Parser SmartDate +smartdate = do + let dateparsers = [ymd, ym, md, y, d, month, mon, today', yesterday, tomorrow + -- lastthisnextthing + ] + (y,m,d) <- choice $ map try dateparsers + return $ (y,m,d) + +datesepchar = oneOf "/-." + +ymd :: Parser SmartDate +ymd = do + y <- many1 digit + datesepchar + m <- many1 digit + guard (read m <= 12) + datesepchar + d <- many1 digit + guard (read d <= 31) + return (y,m,d) + +ym :: Parser SmartDate +ym = do + y <- many1 digit + guard (read y > 12) + datesepchar + m <- many1 digit + guard (read m <= 12) + return (y,m,"1") + +y :: Parser SmartDate +y = do + y <- many1 digit + guard (read y >= 1000) + return (y,"1","1") + +d :: Parser SmartDate +d = do + d <- many1 digit + guard (read d <= 31) + return ("","",d) + +md :: Parser SmartDate +md = do + m <- many1 digit + guard (read m <= 12) + datesepchar + d <- many1 digit + guard (read d <= 31) + return ("",m,d) + +months = ["january","february","march","april","may","june", + "july","august","september","october","november","december"] + +mons = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] + +month :: Parser SmartDate +month = do + m <- choice $ map string months + let i = maybe 0 (+1) $ (map toLower m) `elemIndex` months + return ("",show i,"1") + +mon :: Parser SmartDate +mon = do + m <- choice $ map string mons + let i = maybe 0 (+1) $ (map toLower m) `elemIndex` mons + return ("",show i,"1") + +today',yesterday,tomorrow :: Parser SmartDate +today' = string "today" >> return ("","","today") +yesterday = string "yesterday" >> return ("","","yesterday") +tomorrow = string "tomorrow" >> return ("","","tomorrow") + +lastthisnextthing :: Parser SmartDate +lastthisnextthing = do + r <- choice [ + string "last" + ,string "this" + ,string "next" + ] + many1 spacenonewline + p <- choice [ + string "day" + ,string "week" + ,string "month" + ,string "quarter" + ,string "year" + ] + return ("",r,p) + diff --git a/Ledger/Entry.hs b/Ledger/Entry.hs index 13e8b33f5..1f0832221 100644 --- a/Ledger/Entry.hs +++ b/Ledger/Entry.hs @@ -9,6 +9,7 @@ module Ledger.Entry where import Ledger.Utils import Ledger.Types +import Ledger.Dates import Ledger.RawTransaction import Ledger.Amount diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs index 776f9dd2a..bcb7d4b1d 100644 --- a/Ledger/Parse.hs +++ b/Ledger/Parse.hs @@ -15,6 +15,7 @@ import System.IO import qualified Data.Map as Map import Ledger.Utils import Ledger.Types +import Ledger.Dates import Ledger.Amount import Ledger.Entry import Ledger.Commodity @@ -412,18 +413,6 @@ numberpartsstartingwithpoint = do return ("",frac) -spacenonewline :: Parser Char -spacenonewline = satisfy (\c -> c `elem` " \v\f\t") - -restofline :: Parser String -restofline = anyChar `manyTill` newline - -whiteSpace1 :: Parser () -whiteSpace1 = do space; whiteSpace - -nonspace = satisfy (not . isSpace) - - {-| Parse a timelog file. Here is the timelog grammar, from timeclock.el 2.6: @ @@ -483,111 +472,6 @@ ledgerfromtimelog = do -- misc parsing -{-| -Parse a date in any of the formats allowed in ledger's period expressions, -and maybe some others: - -> 2004 -> 2004/10 -> 2004/10/1 -> 10/1 -> 21 -> october, oct -> yesterday, today, tomorrow -> (not yet) this/next/last week/day/month/quarter/year - -Returns a FuzzyDate, to be converted to a full date later, in the IO -layer. Note: assumes any text in the parse stream has been lowercased. --} -smartdate :: Parser FuzzyDate -smartdate = do - let dateparsers = [ymd, ym, md, y, d, month, mon, today', yesterday, tomorrow] - (y,m,d) <- choice $ map try dateparsers - return $ (y,m,d) - -datesepchar = oneOf "/-." - -ymd :: Parser FuzzyDate -ymd = do - y <- many1 digit - datesepchar - m <- many1 digit - guard (read m <= 12) - datesepchar - d <- many1 digit - guard (read d <= 31) - return (y,m,d) - -ym :: Parser FuzzyDate -ym = do - y <- many1 digit - guard (read y > 12) - datesepchar - m <- many1 digit - guard (read m <= 12) - return (y,m,"1") - -y :: Parser FuzzyDate -y = do - y <- many1 digit - guard (read y >= 1000) - return (y,"1","1") - -d :: Parser FuzzyDate -d = do - d <- many1 digit - guard (read d <= 31) - return ("","",d) - -md :: Parser FuzzyDate -md = do - m <- many1 digit - guard (read m <= 12) - datesepchar - d <- many1 digit - guard (read d <= 31) - return ("",m,d) - -months = ["january","february","march","april","may","june", - "july","august","september","october","november","december"] - -mons = ["jan","feb","mar","apr","may","jun","jul","aug","sep","oct","nov","dec"] - -month :: Parser FuzzyDate -month = do - m <- choice $ map string months - let i = maybe 0 (+1) $ (map toLower m) `elemIndex` months - return ("",show i,"1") - -mon :: Parser FuzzyDate -mon = do - m <- choice $ map string mons - let i = maybe 0 (+1) $ (map toLower m) `elemIndex` mons - return ("",show i,"1") - -today',yesterday,tomorrow :: Parser FuzzyDate -today' = string "today" >> return ("","","today") -yesterday = string "yesterday" >> return ("","","yesterday") -tomorrow = string "tomorrow" >> return ("","","tomorrow") - -lastthisnextthing :: Parser FuzzyDate -lastthisnextthing = do - r <- choice [ - string "last" - ,string "this" - ,string "next" - ] - many1 spacenonewline - p <- choice [ - string "day" - ,string "week" - ,string "month" - ,string "quarter" - ,string "year" - ] - return ("",r,p) - - -- | Parse a --display expression which is a simple date predicate, like -- "d>[DATE]" or "d<=[DATE]", and return a transaction-matching predicate. datedisplayexpr :: Parser (Transaction -> Bool) @@ -609,3 +493,4 @@ datedisplayexpr = do return matcher compareop = choice $ map (try . string) ["<=",">=","==","<","=",">"] + diff --git a/Ledger/TimeLog.hs b/Ledger/TimeLog.hs index 69a878b42..e6cdfb8b1 100644 --- a/Ledger/TimeLog.hs +++ b/Ledger/TimeLog.hs @@ -10,6 +10,7 @@ module Ledger.TimeLog where import Ledger.Utils import Ledger.Types +import Ledger.Dates import Ledger.Commodity import Ledger.Amount diff --git a/Ledger/Transaction.hs b/Ledger/Transaction.hs index d1bc92251..e479f37ad 100644 --- a/Ledger/Transaction.hs +++ b/Ledger/Transaction.hs @@ -9,6 +9,7 @@ module Ledger.Transaction where import Ledger.Utils import Ledger.Types +import Ledger.Dates import Ledger.Entry import Ledger.RawTransaction import Ledger.Amount diff --git a/Ledger/Types.hs b/Ledger/Types.hs index 1dc65c906..fe4aa15a4 100644 --- a/Ledger/Types.hs +++ b/Ledger/Types.hs @@ -1,7 +1,8 @@ {-| -All the main data types, defined here to avoid import cycles. -See the corresponding modules for documentation. +This is the next layer up from Ledger.Utils. All main data types are +defined here to avoid import cycles; see the corresponding modules for +documentation. -} @@ -11,6 +12,10 @@ import Ledger.Utils import qualified Data.Map as Map +newtype Date = Date UTCTime deriving (Ord, Eq) +newtype DateTime = DateTime UTCTime deriving (Ord, Eq) +type SmartDate = (String,String,String) + type AccountName = String data Side = L | R deriving (Eq,Show,Ord) diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs index 8f700ad9d..47b07e599 100644 --- a/Ledger/Utils.hs +++ b/Ledger/Utils.hs @@ -1,6 +1,7 @@ {-| -Provide a number of standard modules and utilities. +Provide a number of standard modules and utilities needed everywhere (or +somewhere low in the module tree). The "hledger prelude". -} @@ -20,7 +21,6 @@ module Text.Printf, module Text.Regex, module Text.RegexPR, module Test.HUnit, -module Ledger.Dates, ) where import Char @@ -34,12 +34,10 @@ import Data.Time.Clock import Data.Time.Calendar import Debug.Trace import Test.HUnit --- import Test.QuickCheck hiding (test, Testable) import Text.Printf import Text.Regex import Text.RegexPR -import Text.ParserCombinators.Parsec (parse) -import Ledger.Dates +import Text.ParserCombinators.Parsec -- strings @@ -203,8 +201,20 @@ p = putStr assertequal e a = assertEqual "" e a assertnotequal e a = assertBool "expected inequality, got equality" (e /= a) --- parsewith :: Parser a +-- parsing + +parsewith :: Parser a -> String -> Either ParseError a parsewith p ts = parse p "" ts + +fromparse :: Either ParseError a -> a fromparse = either (\_ -> error "parse error") id +nonspace :: Parser Char +nonspace = satisfy (not . isSpace) + +spacenonewline :: Parser Char +spacenonewline = satisfy (\c -> c `elem` " \v\f\t") + +restofline :: Parser String +restofline = anyChar `manyTill` newline diff --git a/Options.hs b/Options.hs index 8f080beb7..31bab4f21 100644 --- a/Options.hs +++ b/Options.hs @@ -5,8 +5,9 @@ import System.Console.GetOpt import System.Directory import Text.Printf import Ledger.Parse -import Ledger.Dates import Ledger.Utils +import Ledger.Types +import Ledger.Dates defaultfile = "~/.ledger" @@ -84,51 +85,24 @@ parseArguments = do args <- getArgs let order = if "--options-anywhere" `elem` args then Permute else RequireOrder case (getOpt order options args) of - (opts,cmd:args,[]) -> do {opts' <- fixDates opts; return (opts',cmd,args)} - (opts,[],[]) -> do {opts' <- fixDates opts; return (opts',[],[])} + (opts,cmd:args,[]) -> do {opts' <- fixOptDates opts; return (opts',cmd,args)} + (opts,[],[]) -> do {opts' <- fixOptDates opts; return (opts',[],[])} (opts,_,errs) -> ioError (userError (concat errs ++ usage)) -- | Convert any fuzzy dates within these option values to explicit ones, -- based on today's date. -fixDates :: [Opt] -> IO [Opt] -fixDates opts = do +fixOptDates :: [Opt] -> IO [Opt] +fixOptDates opts = do t <- today return $ map (fixopt t) opts where - fixopt t (Begin s) = Begin $ fixdatestr t s - fixopt t (End s) = End $ fixdatestr t s + fixopt t (Begin s) = Begin $ fixSmartDateStr t s + fixopt t (End s) = End $ fixSmartDateStr t s fixopt t (Display s) = -- hacky Display $ gsubRegexPRBy "\\[.+?\\]" fixbracketeddatestr s - where fixbracketeddatestr s = "[" ++ (fixdatestr t $ init $ tail s) ++ "]" + where fixbracketeddatestr s = "[" ++ (fixSmartDateStr t $ init $ tail s) ++ "]" fixopt _ o = o --- | Convert a fuzzy date string to an explicit yyyy/mm/dd string using --- the provided date as reference point. -fixdatestr :: Date -> String -> String -fixdatestr t s = printf "%04d/%02d/%02d" y m d - where - pdate = fromparse $ parsewith smartdate $ map toLower s - (y,m,d) = dateComponents $ fixFuzzyDate t pdate - --- | Convert a FuzzyDate to an absolute date using the provided date as --- reference point. -fixFuzzyDate :: Date -> FuzzyDate -> Date -fixFuzzyDate refdate pdate = mkDate $ fromGregorian y m d - where - (y,m,d) = fix pdate - fix :: FuzzyDate -> (Integer,Int,Int) - fix ("","","today") = (ry, rm, rd) - fix ("","","yesterday") = dateComponents $ lastday refdate - fix ("","","tomorrow") = dateComponents $ nextday refdate - fix ("","",d) = (ry, rm, read d) - fix ("",m,d) = (ry, read m, read d) - fix (y,m,d) = (read y, read m, read d) - (ry,rm,rd) = dateComponents refdate - -lastday, nextday :: Date -> Date -lastday = mkDate . (addDays (-1)) . utctDay . dateToUTC -nextday = mkDate . (addDays 1) . utctDay . dateToUTC - -- | Get the ledger file path from options, an environment variable, or a default ledgerFilePathFromOpts :: [Opt] -> IO String ledgerFilePathFromOpts opts = do diff --git a/Tests.hs b/Tests.hs index 2ea1bace8..8287ee2bc 100644 --- a/Tests.hs +++ b/Tests.hs @@ -100,7 +100,7 @@ misc_tests = TestList [ "smartparsedate" ~: do t <- today let (ty,tm,td) = dateComponents t - let str `gives` datestr = assertequal datestr (fixdatestr t str) + let str `gives` datestr = assertequal datestr (fixSmartDateStr t str) "1999-12-02" `gives` "1999/12/02" "1999.12.02" `gives` "1999/12/02" "1999/3/2" `gives` "1999/03/02" @@ -112,10 +112,13 @@ misc_tests = TestList [ "January" `gives` (printf "%04d/01/01" ty) "feb" `gives` (printf "%04d/02/01" ty) "today" `gives` (printf "%04d/%02d/%02d" ty tm td) +-- "this day" `gives` (printf "%04d/%02d/%02d" ty tm td) let (y,m,d) = toGregorian $ addDays (-1) $ fromGregorian ty tm td "yesterday" `gives` (printf "%04d/%02d/%02d" y m d) +-- "last day" `gives` (printf "%04d/%02d/%02d" y m d) let (y,m,d) = toGregorian $ addDays 1 $ fromGregorian ty tm td "tomorrow" `gives` (printf "%04d/%02d/%02d" y m d) +-- "next day" `gives` (printf "%04d/%02d/%02d" y m d) ] balancereportacctnames_tests = TestList