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

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

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}) = 

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
+ledgerday :: Parser Day
-ledgerdate = do 
+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
+  datetime <- ledgerdatetime
-  time <- many $ oneOf "0123456789:"
-  let datetime = date ++ " " ++ time
   many spacenonewline
   comment <- restofline
   return $ TimeLogEntry code datetime comment

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
+      matchdate e = (maybe True (edate e>=) begin) && (maybe True (edate e<) end)
-      d2 = parsedate end
-      matchdate e = (null begin || d >= d1) && (null end || d < d2)
-                    where d = parsedate $ edate e
 
 -- | Keep only entries with cleared status, if the flag is true, otherwise
 -- do no filtering.

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
+      indate   = datetimeToDate intime
-      outdate  = showdate outtime
+      outdate  = datetimeToDate outtime
-      showdate = formatTime defaultTimeLocale "%Y/%m/%d"
+      intime   = tldatetime i
-      intime   = parsedatetime $ tldatetime i
+      outtime  = tldatetime o
-      outtime  = parsedatetime $ tldatetime o
+      amount   = Mixed [hours $ elapsedSeconds outtime intime / 3600]
-      amount   = Mixed [hours $ realToFrac (diffUTCTime outtime intime) / 3600]
       txns     = [RawTransaction acctname amount "" RegularTransaction
                  --,RawTransaction "assets:time" (-amount) "" RegularTransaction
                  ]

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

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) 

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]]

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)

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,

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

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
+      b = parsemaybedate (beginDateFromOpts opts)
-      e = endDateFromOpts opts
+      e = parsemaybedate (endDateFromOpts opts)
       dpats = snd $ parseAccountDescriptionArgs args
       c = Cleared `elem` opts
       r = Real `elem` opts