1 -- Copyright (C) 2004 David Roundy 2 -- 3 -- This program is free software; you can redistribute it and/or modify 4 -- it under the terms of the GNU General Public License as published by 5 -- the Free Software Foundation; either version 2, or (at your option) 6 -- any later version. 7 -- 8 -- This program is distributed in the hope that it will be useful, 9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of 10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 11 -- GNU General Public License for more details. 12 -- 13 -- You should have received a copy of the GNU General Public License 14 -- along with this program; see the file COPYING. If not, write to 15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 16 -- Boston, MA 02110-1301, USA. 17 18 19 {-# OPTIONS_GHC -fglasgow-exts #-} 20 {-# LANGUAGE ExistentialQuantification #-} 21 22 module DateMatcher ( parseDateMatcher 23 -- for debugging only 24 , DateMatcher(..), getMatchers ) where 25 26 import Control.Exception ( catchJust, userErrors ) 27 import Data.Maybe ( isJust ) 28 import System.Time 29 import IsoDate ( parseDate, englishDateTime, englishInterval, englishLast, iso8601_interval, 30 resetCalendar, subtractFromMCal, getLocalTz, 31 MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime, 32 unsetTime, 33 ) 34 import Text.ParserCombinators.Parsec ( eof, parse, ParseError ) 35 36 -- | 'withinDay' @x y@ is true if @x <= y < (x + one_day)@ 37 -- Note that this converts the two dates to @ClockTime@ to avoid 38 -- any timezone-related errors 39 withinDay :: CalendarTime -> CalendarTime -> Bool 40 withinDay a b = within (Just $ toClockTime a) 41 (Just (addToClockTime day $ toClockTime a)) 42 (toClockTime b) 43 where day = TimeDiff 0 0 1 0 0 0 0 44 45 -- | 'dateRange' @x1 x2 y@ is true if @x1 <= y < x2@ 46 -- Since @x1@ and @x2@ can be underspecified, we simply assume the 47 -- first date that they could stand for. 48 dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool 49 dateRange a b c = cDateRange (fmap unsafeToCalendarTime a) 50 (fmap unsafeToCalendarTime b) c 51 52 -- | 'cDateRange' @x1 x2 y@ is true if @x1 <= y < x2@ 53 cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool 54 cDateRange a b c = within (fmap toClockTime a) 55 (fmap toClockTime b) (toClockTime c) 56 57 -- | 'within' @x1 x2 y@ is true if @x1 <= y < x2@ 58 within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool 59 within (Just start) (Just end) time = start <= time && time < end 60 within Nothing (Just end) time = time < end 61 within (Just start) Nothing time = start <= time 62 within _ _ _ = undefined 63 64 -- | 'samePartialDate' @range exact@ is true if @exact@ falls 65 -- within the a range of dates represented by @range@. 66 -- The purpose of this function is to support matching on partially 67 -- specified dates. That is, if you only specify the date 2007, 68 -- this function should match any dates within that year. On the 69 -- other hand, if you specify 2007-01, this function will match any 70 -- dates within that month. This function only matches up to the 71 -- second. 72 samePartialDate :: MCalendarTime -> CalendarTime -> Bool 73 samePartialDate a b_ = 74 within (Just clockA) 75 (Just $ addToClockTime interval clockA) 76 (toClockTime calB) 77 where interval 78 | isJust (mctSec a) = second 79 | isJust (mctMin a) = minute 80 | isJust (mctHour a) = hour 81 | isJust (mctYDay a) = day 82 | mctWeek a = maybe week (const day) (mctWDay a) 83 | isJust (mctDay a) = day 84 | isJust (mctMonth a) = month 85 | otherwise = year 86 year = TimeDiff 1 0 0 0 0 0 0 87 month = TimeDiff 0 1 0 0 0 0 0 88 week = TimeDiff 0 0 7 0 0 0 0 89 day = TimeDiff 0 0 1 0 0 0 0 90 hour = TimeDiff 0 0 0 1 0 0 0 91 minute = TimeDiff 0 0 0 0 1 0 0 92 second = TimeDiff 0 0 0 0 0 1 0 93 -- 94 clockA = toClockTime $ unsafeToCalendarTime a 95 calB = resetCalendar b_ 96 97 -- | A 'DateMatcher' combines a potential parse for a date string 98 -- with a "matcher" function that operates on a given date. 99 -- We use an existential type on the matcher to allow 100 -- the date string to either be interpreted as a point in time 101 -- or as an interval. 102 data DateMatcher = forall d . (Show d) => 103 DM String -- name 104 (Either ParseError d) -- parser 105 (d -> CalendarTime -> Bool) -- matcher 106 107 -- | 'parseDateMatcher' @s@ return the first matcher in 108 -- 'getMatchers' that can parse 's' 109 parseDateMatcher :: String -> IO (CalendarTime -> Bool) 110 parseDateMatcher d = 111 do matcher <- tryMatchers `fmap` getMatchers d 112 -- Hack: test the matcher against the current date and discard the results. 113 -- We just want to make sure it won't throw any exceptions when we use it for real. 114 matcher `fmap` now >>= (`seq` return matcher) 115 `catchUserError` 116 -- If the user enters a date > maxint seconds ago, the toClockTime 117 -- function cannot work. 118 \e -> if e == "Time.toClockTime: invalid input" 119 then error "Can't handle dates that far back!" 120 else error e 121 where 122 catchUserError = catchJust userErrors 123 124 -- | 'getMatchers' @d@ returns the list of matchers that will be 125 -- applied on @d@. If you wish to extend the date parsing code, 126 -- this will likely be the function that you modify to do so. 127 getMatchers :: String -> IO [DateMatcher] 128 getMatchers d = 129 do rightNow <- now 130 let midnightToday = unsetTime rightNow 131 mRightNow = toMCalendarTime rightNow 132 matchIsoInterval (Left dur) = dateRange (Just $ dur `subtractFromMCal` mRightNow) (Just mRightNow) 133 matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b) 134 tzNow <- getLocalTz 135 return -- note that the order of these is quite important as some matchers 136 -- can match the same date. 137 [ DM "from English date" 138 (parseDateWith $ englishLast midnightToday) 139 (\(a,_) -> cDateRange (Just a) Nothing) 140 , DM "specific English date" 141 (parseDateWith $ englishDateTime midnightToday) 142 withinDay 143 , DM "English interval" 144 (parseDateWith $ englishInterval rightNow) 145 (uncurry cDateRange) 146 , DM "ISO 8601 interval" 147 (parseDateWith $ iso8601_interval tzNow) 148 matchIsoInterval 149 , DM "CVS, ISO 8601, or old style date" 150 (parseDate tzNow d) 151 samePartialDate ] 152 where 153 tillEof p = do { x <- p; eof; return x } 154 parseDateWith p = parse (tillEof p) "" d 155 156 -- | 'tryMatchers' @ms@ returns the first successful match in @ms@ 157 -- It is an error if there are no matches 158 tryMatchers :: [DateMatcher] -> (CalendarTime -> Bool) 159 tryMatchers (DM _ parsed matcher : ms) = 160 case parsed of 161 Left _ -> tryMatchers ms 162 Right d -> matcher d 163 tryMatchers [] = error "Can't support fancy dates." 164 165 -- darcs-doc: self-explanatory 166 now :: IO CalendarTime 167 now = getClockTime >>= toCalendarTime 168