module Darcs.Util.DateMatcher
(
parseDateMatcher
, DateMatcher(..)
, getMatchers
, testDate
, testDateAt
) where
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 :: CalendarTime -> CalendarTime -> Bool
withinDay CalendarTime
a CalendarTime
b = Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool
within (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CalendarTime -> ClockTime
toClockTime CalendarTime
a)
(forall a. a -> Maybe a
Just (TimeDiff -> ClockTime -> ClockTime
addToClockTime TimeDiff
day forall a b. (a -> b) -> a -> b
$ CalendarTime -> ClockTime
toClockTime CalendarTime
a))
(CalendarTime -> ClockTime
toClockTime CalendarTime
b)
where
day :: TimeDiff
day = Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff
TimeDiff Int
0 Int
0 Int
1 Int
0 Int
0 Int
0 Integer
0
dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool
dateRange :: Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool
dateRange Maybe MCalendarTime
a Maybe MCalendarTime
b = Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool
cDateRange (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MCalendarTime -> CalendarTime
unsafeToCalendarTime Maybe MCalendarTime
a)
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap MCalendarTime -> CalendarTime
unsafeToCalendarTime Maybe MCalendarTime
b)
cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool
cDateRange :: Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool
cDateRange Maybe CalendarTime
a Maybe CalendarTime
b CalendarTime
c = Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool
within (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CalendarTime -> ClockTime
toClockTime Maybe CalendarTime
a)
(forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CalendarTime -> ClockTime
toClockTime Maybe CalendarTime
b) (CalendarTime -> ClockTime
toClockTime CalendarTime
c)
within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool
within :: Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool
within (Just ClockTime
start) (Just ClockTime
end) ClockTime
time = ClockTime
start forall a. Ord a => a -> a -> Bool
<= ClockTime
time Bool -> Bool -> Bool
&& ClockTime
time forall a. Ord a => a -> a -> Bool
< ClockTime
end
within Maybe ClockTime
Nothing (Just ClockTime
end) ClockTime
time = ClockTime
time forall a. Ord a => a -> a -> Bool
< ClockTime
end
within (Just ClockTime
start) Maybe ClockTime
Nothing ClockTime
time = ClockTime
start forall a. Ord a => a -> a -> Bool
<= ClockTime
time
within Maybe ClockTime
_ Maybe ClockTime
_ ClockTime
_ = forall a. HasCallStack => a
undefined
samePartialDate :: MCalendarTime -> CalendarTime -> Bool
samePartialDate :: MCalendarTime -> CalendarTime -> Bool
samePartialDate MCalendarTime
a CalendarTime
b_ =
Maybe ClockTime -> Maybe ClockTime -> ClockTime -> Bool
within (forall a. a -> Maybe a
Just ClockTime
clockA)
(forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ TimeDiff -> ClockTime -> ClockTime
addToClockTime TimeDiff
interval ClockTime
clockA)
(CalendarTime -> ClockTime
toClockTime CalendarTime
calB)
where
interval :: TimeDiff
interval
| forall a. Maybe a -> Bool
isJust (MCalendarTime -> Maybe Int
mctSec MCalendarTime
a) = TimeDiff
second
| forall a. Maybe a -> Bool
isJust (MCalendarTime -> Maybe Int
mctMin MCalendarTime
a) = TimeDiff
minute
| forall a. Maybe a -> Bool
isJust (MCalendarTime -> Maybe Int
mctHour MCalendarTime
a) = TimeDiff
hour
| forall a. Maybe a -> Bool
isJust (MCalendarTime -> Maybe Int
mctYDay MCalendarTime
a) = TimeDiff
day
| MCalendarTime -> Bool
mctWeek MCalendarTime
a = forall b a. b -> (a -> b) -> Maybe a -> b
maybe TimeDiff
week (forall a b. a -> b -> a
const TimeDiff
day) (MCalendarTime -> Maybe Day
mctWDay MCalendarTime
a)
| forall a. Maybe a -> Bool
isJust (MCalendarTime -> Maybe Int
mctDay MCalendarTime
a) = TimeDiff
day
| forall a. Maybe a -> Bool
isJust (MCalendarTime -> Maybe Month
mctMonth MCalendarTime
a) = TimeDiff
month
| Bool
otherwise = TimeDiff
year
year :: TimeDiff
year = Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff
TimeDiff Int
1 Int
0 Int
0 Int
0 Int
0 Int
0 Integer
0
month :: TimeDiff
month = Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff
TimeDiff Int
0 Int
1 Int
0 Int
0 Int
0 Int
0 Integer
0
week :: TimeDiff
week = Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff
TimeDiff Int
0 Int
0 Int
7 Int
0 Int
0 Int
0 Integer
0
day :: TimeDiff
day = Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff
TimeDiff Int
0 Int
0 Int
1 Int
0 Int
0 Int
0 Integer
0
hour :: TimeDiff
hour = Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff
TimeDiff Int
0 Int
0 Int
0 Int
1 Int
0 Int
0 Integer
0
minute :: TimeDiff
minute = Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff
TimeDiff Int
0 Int
0 Int
0 Int
0 Int
1 Int
0 Integer
0
second :: TimeDiff
second = Int -> Int -> Int -> Int -> Int -> Int -> Integer -> TimeDiff
TimeDiff Int
0 Int
0 Int
0 Int
0 Int
0 Int
1 Integer
0
clockA :: ClockTime
clockA = CalendarTime -> ClockTime
toClockTime forall a b. (a -> b) -> a -> b
$ MCalendarTime -> CalendarTime
unsafeToCalendarTime MCalendarTime
a
calB :: CalendarTime
calB = CalendarTime -> CalendarTime
resetCalendar CalendarTime
b_
data DateMatcher = forall d . (Show d) => DM
String
(Either ParseError d)
(d -> CalendarTime -> Bool)
parseDateMatcher :: String -> IO (CalendarTime -> Bool)
parseDateMatcher :: String -> IO (CalendarTime -> Bool)
parseDateMatcher String
d = IO (CalendarTime -> Bool)
testDateMatcher forall {a}. IO a -> (String -> IO a) -> IO a
`catchUserError` forall {a}. String -> a
handleError
where
catchUserError :: IO a -> (String -> IO a) -> IO a
catchUserError = forall e b a.
Exception e =>
(e -> Maybe b) -> IO a -> (b -> IO a) -> IO a
catchJust forall a b. (a -> b) -> a -> b
$ \IOError
e ->
if IOError -> Bool
isUserError IOError
e then forall a. a -> Maybe a
Just (IOError -> String
ioeGetErrorString IOError
e) else forall a. Maybe a
Nothing
handleError :: String -> a
handleError String
e = if String
e forall a. Eq a => a -> a -> Bool
== String
"Time.toClockTime: invalid input"
then forall a. HasCallStack => String -> a
error String
"Can't handle dates that far back!"
else forall a. HasCallStack => String -> a
error String
e
testDateMatcher :: IO (CalendarTime -> Bool)
testDateMatcher = do
CalendarTime -> Bool
matcher <- [DateMatcher] -> CalendarTime -> Bool
tryMatchers forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO [DateMatcher]
getMatchers String
d
CalendarTime -> Bool
matcher forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO CalendarTime
now forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (seq :: forall a b. a -> b -> b
`seq` forall (m :: * -> *) a. Monad m => a -> m a
return CalendarTime -> Bool
matcher)
getMatchers :: String -> IO [DateMatcher]
getMatchers :: String -> IO [DateMatcher]
getMatchers String
d = do
CalendarTime
rightNow <- IO CalendarTime
now
let midnightToday :: CalendarTime
midnightToday = CalendarTime -> CalendarTime
unsetTime CalendarTime
rightNow
mRightNow :: MCalendarTime
mRightNow = CalendarTime -> MCalendarTime
toMCalendarTime CalendarTime
rightNow
matchIsoInterval :: Either TimeDiff (MCalendarTime, MCalendarTime)
-> CalendarTime -> Bool
matchIsoInterval (Left TimeDiff
dur) =
let durAgo :: MCalendarTime
durAgo = TimeDiff
dur TimeDiff -> MCalendarTime -> MCalendarTime
`subtractFromMCal` MCalendarTime
mRightNow in
Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool
dateRange (forall a. a -> Maybe a
Just MCalendarTime
durAgo) (forall a. a -> Maybe a
Just MCalendarTime
mRightNow)
matchIsoInterval (Right (MCalendarTime
a,MCalendarTime
b)) = Maybe MCalendarTime -> Maybe MCalendarTime -> CalendarTime -> Bool
dateRange (forall a. a -> Maybe a
Just MCalendarTime
a) (forall a. a -> Maybe a
Just MCalendarTime
b)
Int
tzNow <- IO Int
getLocalTz
forall (m :: * -> *) a. Monad m => a -> m a
return
[ forall d.
Show d =>
String
-> Either ParseError d
-> (d -> CalendarTime -> Bool)
-> DateMatcher
DM String
"from English date"
(forall {a}. ParsecT String () Identity a -> Either ParseError a
parseDateWith forall a b. (a -> b) -> a -> b
$ forall a. CalendarTime -> CharParser a (CalendarTime, CalendarTime)
englishLast CalendarTime
midnightToday)
(\(CalendarTime
a,CalendarTime
_) -> Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool
cDateRange (forall a. a -> Maybe a
Just CalendarTime
a) forall a. Maybe a
Nothing)
, forall d.
Show d =>
String
-> Either ParseError d
-> (d -> CalendarTime -> Bool)
-> DateMatcher
DM String
"specific English date"
(forall {a}. ParsecT String () Identity a -> Either ParseError a
parseDateWith forall a b. (a -> b) -> a -> b
$ forall a. CalendarTime -> CharParser a CalendarTime
englishDateTime CalendarTime
midnightToday)
CalendarTime -> CalendarTime -> Bool
withinDay
, forall d.
Show d =>
String
-> Either ParseError d
-> (d -> CalendarTime -> Bool)
-> DateMatcher
DM String
"English interval"
(forall {a}. ParsecT String () Identity a -> Either ParseError a
parseDateWith forall a b. (a -> b) -> a -> b
$ forall a. CalendarTime -> CharParser a TimeInterval
englishInterval CalendarTime
rightNow)
(forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Maybe CalendarTime -> Maybe CalendarTime -> CalendarTime -> Bool
cDateRange)
, forall d.
Show d =>
String
-> Either ParseError d
-> (d -> CalendarTime -> Bool)
-> DateMatcher
DM String
"ISO 8601 interval"
(forall {a}. ParsecT String () Identity a -> Either ParseError a
parseDateWith forall a b. (a -> b) -> a -> b
$ forall a.
Int
-> CharParser a (Either TimeDiff (MCalendarTime, MCalendarTime))
iso8601Interval Int
tzNow)
Either TimeDiff (MCalendarTime, MCalendarTime)
-> CalendarTime -> Bool
matchIsoInterval
, forall d.
Show d =>
String
-> Either ParseError d
-> (d -> CalendarTime -> Bool)
-> DateMatcher
DM String
"CVS, ISO 8601, old style, or RFC2822 date"
(Int -> String -> Either ParseError MCalendarTime
parseDate Int
tzNow String
d)
MCalendarTime -> CalendarTime -> Bool
samePartialDate
]
where
tillEof :: ParsecT s u m b -> ParsecT s u m b
tillEof ParsecT s u m b
p = do { b
x <- ParsecT s u m b
p; forall s (m :: * -> *) t u.
(Stream s m t, Show t) =>
ParsecT s u m ()
eof; forall (m :: * -> *) a. Monad m => a -> m a
return b
x }
parseDateWith :: ParsecT String () Identity a -> Either ParseError a
parseDateWith ParsecT String () Identity a
p = forall s t a.
Stream s Identity t =>
Parsec s () a -> String -> s -> Either ParseError a
parse (forall {s} {m :: * -> *} {t} {u} {b}.
(Stream s m t, Show t) =>
ParsecT s u m b -> ParsecT s u m b
tillEof ParsecT String () Identity a
p) String
"" String
d
tryMatchers :: [DateMatcher] -> CalendarTime -> Bool
tryMatchers :: [DateMatcher] -> CalendarTime -> Bool
tryMatchers (DM String
_ Either ParseError d
parsed d -> CalendarTime -> Bool
matcher : [DateMatcher]
ms) =
case Either ParseError d
parsed of
Left ParseError
_ -> [DateMatcher] -> CalendarTime -> Bool
tryMatchers [DateMatcher]
ms
Right d
d -> d -> CalendarTime -> Bool
matcher d
d
tryMatchers [] = forall a. HasCallStack => String -> a
error String
"Can't support fancy dates."
now :: IO CalendarTime
now :: IO CalendarTime
now = IO ClockTime
getClockTime forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ClockTime -> IO CalendarTime
toCalendarTime
testDate :: String -> IO ()
testDate :: String -> IO ()
testDate String
d = do CalendarTime
cnow <- IO CalendarTime
now
CalendarTime -> String -> IO ()
testDateAtCal CalendarTime
cnow String
d
testDateAt :: String -> String -> IO ()
testDateAt :: String -> String -> IO ()
testDateAt String
iso = CalendarTime -> String -> IO ()
testDateAtCal (String -> CalendarTime
readUTCDate String
iso)
testDateAtCal :: CalendarTime -> String -> IO ()
testDateAtCal :: CalendarTime -> String -> IO ()
testDateAtCal CalendarTime
c String
d =
do [DateMatcher]
ms <- String -> IO [DateMatcher]
getMatchers String
d
String -> IO ()
putStr forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (CalendarTime -> DateMatcher -> String
showMatcher CalendarTime
c) forall a b. (a -> b) -> a -> b
$ [DateMatcher]
ms
showMatcher :: CalendarTime -> DateMatcher -> String
showMatcher :: CalendarTime -> DateMatcher -> String
showMatcher CalendarTime
cnow (DM String
n Either ParseError d
p d -> CalendarTime -> Bool
m) =
String
"==== " forall a. [a] -> [a] -> [a]
++ String
n forall a. [a] -> [a] -> [a]
++ String
" ====\n" forall a. [a] -> [a] -> [a]
++
(case Either ParseError d
p of
Left ParseError
err -> forall a. Show a => a -> ShowS
shows ParseError
err String
""
Right d
x -> forall a. Show a => a -> String
show d
x forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (d -> CalendarTime -> Bool
m d
x CalendarTime
cnow))