%  Copyright (C) 2004 David Roundy
%
%  This program is free software; you can redistribute it and/or modify
%  it under the terms of the GNU General Public License as published by
%  the Free Software Foundation; either version 2, or (at your option)
%  any later version.
%
%  This program is distributed in the hope that it will be useful,
%  but WITHOUT ANY WARRANTY; without even the implied warranty of
%  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
%  GNU General Public License for more details.
%
%  You should have received a copy of the GNU General Public License
%  along with this program; see the file COPYING.  If not, write to
%  the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
%  Boston, MA 02110-1301, USA.


\begin{code}
module DateMatcher ( parseDateMatcher ) where

import Control.Exception ( catchJust, userErrors )
import Data.Maybe ( isJust )
import System.Time
import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast, iso8601_interval,
                 resetCalendar, subtractFromMCal, getLocalTz,
                 MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime,
                 unsetTime,
               )
import Control.Monad ( liftM )
import Text.ParserCombinators.Parsec ( eof, parse )

-- note that we avoid comparing the fields ctYear, etc directly
-- because we want to avoid timezone-related issues (our
-- two dates may not be in the same zone), so we want to normalise
-- for that
withinDay :: CalendarTime -> CalendarTime -> Bool
withinDay a b = within (toClockTime a)
                       (addToClockTime day $ toClockTime a)
                       (toClockTime b)
 where day = TimeDiff 0 0 1 0 0 0 0

dateRange :: MCalendarTime -> MCalendarTime -> CalendarTime -> Bool
dateRange a b c = cDateRange (unsafeToCalendarTime a) (unsafeToCalendarTime b) c

cDateRange :: CalendarTime -> CalendarTime -> CalendarTime -> Bool
cDateRange a b c = within (toClockTime a) (toClockTime b) (toClockTime c)

within :: ClockTime -> ClockTime -> ClockTime -> Bool
within a b c = a <= c && b > c

-- either the same exact date, or within a range
-- we make the simplifying assumption that, for example, if the
-- month is unset, so is the day of month
samePartialDate :: MCalendarTime -> CalendarTime -> Bool
samePartialDate a b_ =
 within clockA
        (addToClockTime interval clockA)
        (toClockTime calB)
 where interval
         | isJust (mctYDay a)  = day
         | mctWeek a = maybe week (const day) (mctWDay a)
         | isJust (mctDay a)   = day
         | isJust (mctMonth a) = month
         | otherwise           = year
       year  = TimeDiff 1 0 0 0 0 0 0
       month = TimeDiff 0 1 0 0 0 0 0
       week  = TimeDiff 0 0 7 0 0 0 0
       day   = TimeDiff 0 0 1 0 0 0 0
       --
       clockA = toClockTime $ unsafeToCalendarTime a
       calB   = resetCalendar b_

parseDateMatcher :: String -> IO (CalendarTime -> Bool)
parseDateMatcher d = 
 do rightNow <- now
    let midnightToday = unsetTime rightNow
        mRightNow = toMCalendarTime rightNow
    tzNow <- getLocalTz
    let -- note that the order of these is quite important as some matchers
        -- can match the same date.
        thingsToTry =
          [ tryOr (englishLast midnightToday) (\(a,_) -> cDateRange a rightNow)
          , tryOr (englishDateTime midnightToday) withinDay
          , tryOr (englishInterval rightNow)  (uncurry cDateRange)
          , tryOr (iso8601_interval tzNow)  matchIsoInterval
          , tryDateOr ]
        tryOr p m next = either (const next) m $
                            parse (tillEof p) "" d
        tryDateOr next = either (const next) (samePartialDate) $
                            parseDate tzNow d
        matchIsoInterval (Left dur) = dateRange (dur `subtractFromMCal` mRightNow) mRightNow
        matchIsoInterval (Right (a,b)) = dateRange a b
    let matcher = foldr ($) (error "Can't support fancy dates.") thingsToTry
    -- Hack: test the matcher against the current date and discard the results.
    -- We just want to make sure it won't throw any exceptions when we use it for real.
    matcher `liftM` now >>= (`seq` return matcher)
 `catchUserError`
    -- If the user enters a date > maxint seconds ago, the toClockTime
    -- function cannot work.
    \e -> if e == "Time.toClockTime: invalid input"
          then error "Can't handle dates that far back!"
          else error e
 where
   catchUserError = catchJust userErrors
   tillEof p = do { x <- p; eof; return x }

now :: IO CalendarTime
now = getClockTime >>= toCalendarTime
\end{code}

