From 7362fbd730503109b871dfc25805709ca31aabea Mon Sep 17 00:00:00 2001
From: Simon Michael <simon@joyful.com>
Date: Sat, 22 Nov 2008 12:18:19 +0000
Subject: [PATCH] begin smart date parsing

---
 Ledger/Dates.hs | 37 ++++++++++++++++++++++---------
 Ledger/Parse.hs | 58 +++++++++++++++++++++++++++++++++++++++++++++++++
 Ledger/Utils.hs |  4 ++++
 NOTES           |  3 ++-
 Tests.hs        |  5 +++++
 5 files changed, 96 insertions(+), 11 deletions(-)

diff --git a/Ledger/Dates.hs b/Ledger/Dates.hs
index 85b14eee7..2e1a2a882 100644
--- a/Ledger/Dates.hs
+++ b/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
\ No newline at end of file
diff --git a/Ledger/Parse.hs b/Ledger/Parse.hs
index fb9a29ced..ec54f64a9 100644
--- a/Ledger/Parse.hs
+++ b/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
diff --git a/Ledger/Utils.hs b/Ledger/Utils.hs
index dc534e3f9..15b45eb16 100644
--- a/Ledger/Utils.hs
+++ b/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)
diff --git a/NOTES b/NOTES
index 9b85176b2..88e4c67f9 100644
--- a/NOTES
+++ b/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
diff --git a/Tests.hs b/Tests.hs
index a3f98bbe9..f900bd289 100644
--- a/Tests.hs
+++ b/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