{-# LANGUAGE ExistentialQuantification #-}
module Darcs.Util.DateMatcher
(
parseDateMatcher
, DateMatcher(..)
, getMatchers
, testDate
, testDateAt
) where
import Prelude ()
import Darcs.Prelude
import Control.Exception ( catchJust )
import Data.Maybe ( isJust )
import System.IO.Error ( isUserError, ioeGetErrorString )
import System.Time
import Text.ParserCombinators.Parsec ( eof, parse, ParseError )
import Darcs.Util.IsoDate
( parseDate, englishDateTime, englishInterval, englishLast
, iso8601Interval, resetCalendar, subtractFromMCal, getLocalTz
, MCalendarTime(..), toMCalendarTime, unsafeToCalendarTime
, unsetTime, readUTCDate
)
withinDay :: CalendarTime -> CalendarTime -> Bool
withinDay a b = within (Just $ toClockTime a)
(Just (addToClockTime day $ toClockTime a))
(toClockTime b)
where
day = TimeDiff 0 0 1 0 0 0 0
dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool
dateRange a b = cDateRange (fmap unsafeToCalendarTime a)
(fmap unsafeToCalendarTime b)
cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool
cDateRange a b c = within (fmap toClockTime a)
(fmap toClockTime b) (toClockTime c)
within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool
within (Just start) (Just end) time = start <= time && time < end
within Nothing (Just end) time = time < end
within (Just start) Nothing time = start <= time
within _ _ _ = undefined
samePartialDate :: MCalendarTime -> CalendarTime -> Bool
samePartialDate a b_ =
within (Just clockA)
(Just $ 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
(Either ParseError d)
(d -> CalendarTime -> Bool)
parseDateMatcher :: String -> IO (CalendarTime -> Bool)
parseDateMatcher d = testDateMatcher `catchUserError` handleError
where
catchUserError = catchJust $ \e ->
if isUserError e then Just (ioeGetErrorString e) else Nothing
handleError e = if e == "Time.toClockTime: invalid input"
then error "Can't handle dates that far back!"
else error e
testDateMatcher = do
matcher <- tryMatchers `fmap` getMatchers d
matcher `fmap` now >>= (`seq` return matcher)
getMatchers :: String -> IO [DateMatcher]
getMatchers d = do
rightNow <- now
let midnightToday = unsetTime rightNow
mRightNow = toMCalendarTime rightNow
matchIsoInterval (Left dur) =
let durAgo = dur `subtractFromMCal` mRightNow in
dateRange (Just durAgo) (Just mRightNow)
matchIsoInterval (Right (a,b)) = dateRange (Just a) (Just b)
tzNow <- getLocalTz
return
[ DM "from English date"
(parseDateWith $ englishLast midnightToday)
(\(a,_) -> cDateRange (Just a) Nothing)
, DM "specific English date"
(parseDateWith $ englishDateTime midnightToday)
withinDay
, DM "English interval"
(parseDateWith $ englishInterval rightNow)
(uncurry cDateRange)
, DM "ISO 8601 interval"
(parseDateWith $ iso8601Interval tzNow)
matchIsoInterval
, DM "CVS, ISO 8601, old style, or RFC2822 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
testDate :: String -> IO ()
testDate d = do cnow <- now
testDateAtCal cnow d
testDateAt :: String -> String -> IO ()
testDateAt iso = testDateAtCal (readUTCDate iso)
testDateAtCal :: CalendarTime -> String -> IO ()
testDateAtCal c d =
do ms <- getMatchers d
putStr . unlines . map (showMatcher c) $ ms
showMatcher :: CalendarTime -> DateMatcher -> String
showMatcher cnow (DM n p m) =
"==== " ++ n ++ " ====\n" ++
(case p of
Left err -> shows err ""
Right x -> show x ++ "\n" ++ show (m x cnow))