% 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}
{-# OPTIONS_GHC -fglasgow-exts #-}
module DateMatcher ( parseDateMatcher
-- for debugging only
, DateMatcher(..), getMatchers ) 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, ParseError )
-- 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 (mctSec a) = second
| isJust (mctMin a) = minute
| isJust (mctHour a) = hour
| 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
hour = TimeDiff 0 0 0 1 0 0 0
minute = TimeDiff 0 0 0 0 1 0 0
second = TimeDiff 0 0 0 0 0 1 0
--
clockA = toClockTime $ unsafeToCalendarTime a
calB = resetCalendar b_
data DateMatcher = forall d . (Show d) =>
DM String -- name
(Either ParseError d) -- parser
(d -> CalendarTime -> Bool) -- matcher
parseDateMatcher :: String -> IO (CalendarTime -> Bool)
parseDateMatcher d =
do matcher <- tryMatchers `fmap` getMatchers d
-- 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
getMatchers :: String -> IO [DateMatcher]
getMatchers d =
do rightNow <- now
let midnightToday = unsetTime rightNow
mRightNow = toMCalendarTime rightNow
matchIsoInterval (Left dur) = dateRange (dur `subtractFromMCal` mRightNow) mRightNow
matchIsoInterval (Right (a,b)) = dateRange a b
tzNow <- getLocalTz
return -- note that the order of these is quite important as some matchers
-- can match the same date.
[ DM "from English date"
(parseDateWith $ englishLast midnightToday)
(\(a,_) -> cDateRange a rightNow)
, DM "specific English date"
(parseDateWith $ englishDateTime midnightToday)
withinDay
, DM "English interval"
(parseDateWith $ englishInterval rightNow)
(uncurry cDateRange)
, DM "ISO 8601 interval"
(parseDateWith $ iso8601_interval tzNow)
matchIsoInterval
, DM "CVS, ISO 8601, or old style date"
(parseDate tzNow d)
samePartialDate ]
where
tillEof p = do { x <- p; eof; return x }
parseDateWith p = parse (tillEof p) "" d
tryMatchers :: [DateMatcher] -> (CalendarTime -> Bool)
tryMatchers (DM _ parsed matcher : ms) =
case parsed of
Left _ -> tryMatchers ms
Right d -> matcher d
tryMatchers [] = error "Can't support fancy dates."
now :: IO CalendarTime
now = getClockTime >>= toCalendarTime
\end{code}