gather date stuff together, FuzzyDate -> SmartDate

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

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)
+

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
 

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) ["<=",">=","==","<","=",">"]
+

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
 

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

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) 

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
 

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

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