%  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 System.Time
import IsoDate ( parseDate, englishDateTime, englishInterval, iso8601_interval,
                 subtractFromCal )
import Monad ( liftM )
import Text.ParserCombinators.Parsec ( eof, parse )

sameDate :: CalendarTime -> CalendarTime -> Bool
sameDate a b = ctDay a == ctDay b &&
               ctMonth a == ctMonth b &&
               ctYear a == ctYear b

dateRange :: CalendarTime -> CalendarTime -> CalendarTime -> Bool
dateRange a b c = a <= c && b >= c

parseDateMatcher :: String -> IO (CalendarTime -> Bool)
parseDateMatcher d = 
 do rightNow <- now
    let parseToEof p = parse $ do { x <- p; eof; return x }
        --
        tryEnglishDateOr next =
          case parseToEof (englishDateTime rightNow) "" d of
               Right ed -> dateRange ed rightNow
               _ -> next
        --
        tryEnglishIntervalOr next =
          case parseToEof (englishInterval rightNow) "" d of
               Right (a,b) -> dateRange a b 
               _ -> next
        --
        tryISOIntervalOr next =
          case parseToEof (iso8601_interval 0) "" d of
               Right (Left dur)    -> dateRange (dur `subtractFromCal` rightNow) rightNow
               Right (Right (a,b)) -> dateRange a b
               _ -> next
        --
        tryDateOr next =
          case parseDate d of
               Right ct -> sameDate ct
               _ -> next
    let matcher = tryEnglishDateOr $ tryEnglishIntervalOr
                $ tryISOIntervalOr $ tryDateOr
                $ error "Can't support fancy dates."
    -- 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


now :: IO CalendarTime
now = toUTCTime `liftM` getClockTime
\end{code}