src/DateMatcher.lhs

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