1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
% 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}
|
