begin smart date parsing

Ledger/Dates.hs

@@ -4,16 +4,19 @@ Types for Dates and DateTimes, implemented in terms of UTCTime
 
 -}
 
-module Ledger.Dates(
-    Date,                    
-    DateTime,
-    mkDate,
-    mkDateTime,
-    parsedatetime,
-    parsedate,
-    datetimeToDate,
-    elapsedSeconds
-    ) where
+module Ledger.Dates
+--(
+--     Date,                    
+--     DateTime,
+--     mkDate,
+--     mkDateTime,
+--     parsedatetime,
+--     parsedate,
+--     datetimeToDate,
+--     elapsedSeconds,
+--     today
+--    ) 
+where
 
 import Data.Time.Clock
 import Data.Time.Format
@@ -64,3 +67,17 @@ datetimeToDate (DateTime (UTCTime{utctDay=day})) = Date (UTCTime day 0)
 elapsedSeconds :: Fractional a => DateTime -> DateTime -> a
 elapsedSeconds (DateTime dt1) (DateTime dt2) = realToFrac $ diffUTCTime dt1 dt2
 
+today :: IO Date
+today = getCurrentTime >>= return . Date
+
+dateToUTC :: Date -> UTCTime
+dateToUTC (Date u) = u
+
+dateComponents :: Date -> (Integer,Int,Int)
+dateComponents = toGregorian . utctDay . dateToUTC
+
+-- dateDay :: Date -> Day
+dateDay date = d where (_,_,d) = dateComponents date
+
+-- dateMonth :: Date -> Day
+dateMonth date = m where (_,m,_) = dateComponents date

Ledger/Parse.hs

@@ -479,3 +479,61 @@ ledgerfromtimelog = do
   tl <- timelog
   return $ ledgerFromTimeLog tl
 
+
+-- misc parsing
+{-| 
+Parse a date in any of the formats allowed in ledger's period expressions:
+
+> 2004
+> 2004/10
+> 2004/10/1
+> 10/1
+> october
+> oct
+> this week  # or day, month, quarter, year
+> next week
+> last week
+-}
+smartdate :: Parser (String,String,String)
+smartdate = do
+  (y,m,d) <- (
+             try ymd 
+             <|> try ym 
+             <|> try y
+--              <|> try md
+--              <|> try month
+--              <|> try mon
+--              <|> try thiswhatever
+--              <|> try nextwhatever
+--              <|> try lastwhatever
+            )
+  return $ (y,m,d)
+
+datesep = oneOf "/-."
+
+ymd :: Parser (String,String,String)
+ymd = do
+  y <- many digit
+  datesep
+  m <- many digit
+  datesep
+  d <- many digit
+  return (y,m,d)
+
+ym :: Parser (String,String,String)
+ym = do
+  y <- many digit
+  datesep
+  m <- many digit
+  return (y,m,"1")
+
+y :: Parser (String,String,String)
+y = do
+  y <- many digit
+  return (y,"1","1")
+
+-- | Parse a flexible date string, with awareness of the current time,
+-- | and return a Date or raise an error.
+smartparsedate :: String -> Date
+smartparsedate s = parsedate $ printf "%04s/%02s/%02s" y m d
+    where (y,m,d) = fromparse $ parsewith smartdate s

Ledger/Utils.hs

@@ -12,6 +12,8 @@ module Data.List,
 module Data.Maybe,
 module Data.Ord,
 module Data.Tree,
+module Data.Time.Clock,
+module Data.Time.Calendar,
 module Debug.Trace,
 module Ledger.Utils,
 module Text.Printf,
@@ -27,6 +29,8 @@ import Data.List
 import Data.Maybe
 import Data.Ord
 import Data.Tree
+import Data.Time.Clock
+import Data.Time.Calendar
 import Debug.Trace
 import Test.HUnit
 import Test.QuickCheck hiding (test, Testable)

NOTES

@@ -13,8 +13,9 @@ implementations were its consequences." --Niklaus Wirth
 *** display mixed amounts vertically, not horizontally
 ** features
 *** flexible date expressions, for easier time reports
+**** use Dates for -b/-e
 *** commodity @ rate, for tracking client hours in main ledger
-*** actual/effective entry & txn dates, for ...
+*** actual/effective entry & txn dates, for ?
 *** --display, for reconciling recent transactions with real balance
 *** more ledger features from README
 *** new features

Tests.hs

@@ -92,6 +92,11 @@ misc_tests = TestList [
   ,
   "timeLog" ~: do
     assertparseequal timelog1 (parsewith timelog timelog1_str)
+  ,                  
+  "smartparsedate"     ~: do
+    assertequal (1999,12,13) (dateComponents $ smartparsedate "1999/12/13")
+    assertequal (2008,2,1)   (dateComponents $ smartparsedate "2008-2")
+    assertequal (2008,1,1)   (dateComponents $ smartparsedate "2008")
   ]
 
 balancereportacctnames_tests = TestList