summaryrefslogtreecommitdiff
path: root/lib/Postdelay/TimeSpec.hs
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Postdelay/TimeSpec.hs')
-rw-r--r--lib/Postdelay/TimeSpec.hs326
1 files changed, 322 insertions, 4 deletions
diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs
index b080dcc..af8d801 100644
--- a/lib/Postdelay/TimeSpec.hs
+++ b/lib/Postdelay/TimeSpec.hs
@@ -1,14 +1,332 @@
1{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ViewPatterns, ConstraintKinds, TupleSections, RecordWildCards #-}
2
1module Postdelay.TimeSpec 3module Postdelay.TimeSpec
2 ( pTimeSpec 4 ( pTimeSpec
5 , TimeCtx(..)
3 ) where 6 ) where
4 7
8import Control.Monad
5import Control.Monad.IO.Class 9import Control.Monad.IO.Class
6import Data.Time 10import Control.Monad.Reader.Class
11import Control.Monad.Error.Class
7 12
8import Text.Parsec.Char 13import Text.Parsec.Char hiding (digit)
14import qualified Text.Parsec.Char as Parsec (digit)
9import Text.Parsec.Prim 15import Text.Parsec.Prim
10import Text.Parsec.Combinator 16import Text.Parsec.Combinator
11import Text.Parsec.Error (ParseError(..)) 17import Text.Parsec.Error (ParseError(..))
18import Text.Read (readMaybe)
19
20import Data.CaseInsensitive (CI)
21import qualified Data.CaseInsensitive as CI
22
23import Data.Time
24import Data.Time.Calendar.WeekDate
25import Data.Time.Zones
26import Data.Function
27import Data.Maybe
28import Data.Foldable
29import Data.Ord
30import Data.List
31import Data.Tuple
32import Data.Bool
33
34import Control.Exception (IOException)
35
36import Debug.Trace
37
38
39type MonadTP m = (MonadIO m, MonadReader TimeCtx m)
40
41data TimeCtx = TimeCtx
42 { baseTime :: UTCTime
43 , tz :: Either TimeZone TZ
44 }
45
46
47spaced :: Stream s m Char => ParsecT s u m a -> ParsecT s u m a
48spaced p = spaces *> p <* spaces
49
50string' :: Stream s m Char => String -> ParsecT s u m String
51string' = mapM $ satisfy . ((==) `on` CI.mk)
52
53choice' :: (Stream s m t, Foldable f) => f (ParsecT s u m a) -> ParsecT s u m a
54choice' (toList -> f)
55 | [p] <- f = p
56 | (p:ps) <- f = try p <|> choice' ps
57 | otherwise = mzero
58
59strChoice' :: Stream s m Char => [String] -> ParsecT s u m String
60strChoice' = choice' . map string' . sortBy (comparing $ Down . length)
61
62natural :: (Stream s m Char, Num a) => ParsecT s u m a
63natural = foldl' (\init last -> init * 10 + last) 0 <$> many1 digit
64
65decimal :: (Stream s m Char, Num a, Fractional a) => ParsecT s u m a
66decimal = do
67 w <- foldl' (\init last -> init * 10 + last) 0 <$> many1 digit
68 f <- option 0 $ do
69 char '.'
70 foldr' (\head tail -> head + tail / 10) 0 <$> many1 digit
71 return $ w + f / 10
72
73digit :: (Stream s m Char, Num a) => ParsecT s u m a
74digit = fromIntegral . (\c -> fromEnum c - fromEnum '0') <$> Parsec.digit
75
76ensure :: MonadPlus m => (a -> Bool) -> a -> m a
77ensure p x = bool (const mzero) return (p x) $ x
78
79
80pTimeSpec :: MonadTP m => ParsecT String () m UTCTime
81pTimeSpec = choice' [ flip addUTCTime <$> spaced pSpecBase <*> spaced pSpecOffset <?> "Absolute time + offset"
82 , flip addUTCTime <$> asks baseTime <*> spaced pSpecOffset <?> "Time offset"
83 , spaced pSpecBase <?> "Absolute time"
84 ]
85 <* eof <?> "Time specification"
86
87pSpecBase :: forall m. MonadTP m => ParsecT String () m UTCTime
88pSpecBase = choice'
89 [ utcTime <$> spaced pDate <*> spaced pTime
90 , flip utcTime <$> spaced pTime <*> spaced pDate
91 , do
92 proto@(UTCTime{..}) <- utcTime <$> (utctDay <$> asks baseTime) <*> spaced pTime
93 now <- asks baseTime
94 return $ if proto < now
95 then UTCTime (succ utctDay) utctDayTime
96 else proto
97 , utcTime <$> spaced pDate <*> ((dayFractionToTimeOfDay 0, ) <$> asks tz)
98 , spaced (string' "now") *> asks baseTime
99 ] <?> "Base specification"
100 where
101 utcTime :: Day -> (TimeOfDay, Either TimeZone TZ) -> UTCTime
102 utcTime d (t, Right tz) = localTimeToUTCTZ tz (LocalTime d t)
103 utcTime d (t, Left tz) = localTimeToUTC tz (LocalTime d t)
104
105pSpecOffset :: MonadTP m => ParsecT String () m NominalDiffTime
106pSpecOffset = (+) <$> pSpecOffset' <*> option 0 (try (many $ space <|> char ',' <|> char ';') >> pSpecOffset)
107 where
108 pSpecOffset' = option id (spaced pSign) <*> ((*) <$> spaced pNumber <*> spaced pSpecOffsetConst) <?> "Time offset"
109 pNumber = fromInteger <$> natural <?> "Offset multiplier"
110
111pSign :: MonadTP m => ParsecT String () m (NominalDiffTime -> NominalDiffTime)
112pSign = choice [ id <$ char '+'
113 , negate <$ char '-'
114 ] <?> "Offset sign"
115
116pSpecOffsetConst :: MonadTP m => ParsecT String () m NominalDiffTime
117pSpecOffsetConst = choice' [ 1e-12 <$ strChoice' [ "ps"
118 , "picosecond"
119 , "picoseconds"
120 ]
121 , 1e-9 <$ strChoice' [ "ns"
122 , "nanosecond"
123 , "nanoseconds"
124 ]
125 , 1e-6 <$ strChoice' [ "us", "µs"
126 , "microsecond"
127 , "microseconds"
128 ]
129 , 1e-3 <$ strChoice' [ "ms"
130 , "millisecond"
131 , "milliseconds"
132 ]
133 , 1e-2 <$ strChoice' [ "ds"
134 , "decisecond"
135 , "deciseconds"
136 ]
137 , 1e-1 <$ strChoice' [ "cs"
138 , "centisecond"
139 , "centiseconds"
140 ]
141 , 1 <$ strChoice' [ "s"
142 , "second"
143 , "seconds"
144 ]
145 , 60 <$ strChoice' [ "min"
146 , "minute"
147 , "minutes"
148 ]
149 , 3600 <$ strChoice' [ "h"
150 , "hour"
151 , "hours"
152 ]
153 , 24 * 3600 <$ strChoice' [ "d"
154 , "day"
155 , "days"
156 ]
157 , 7 * 24 * 3600 <$ strChoice' [ "week"
158 , "weeks"
159 ]
160 , 30 * 24 * 3600 <$ strChoice' [ "month"
161 , "months"
162 ]
163 , 365 * 24 * 3600 <$ strChoice' [ "year"
164 , "years"
165 ]
166 ] <?> "Offset unit"
167
168pDate :: MonadTP m => ParsecT String () m Day
169pDate = choice' [ do
170 (m, d) <- choice' [ do
171 m <- spaced pMonthName
172 d <- spaced natural
173 optional . spaced $ char ','
174 return (m, d)
175 , fmap swap . (,) <$> spaced natural <*> spaced pMonthName
176 ]
177 y <- spaced natural
178 fromGregorian' y m d
179 , do
180 now <- asks baseTime
181 (m, d) <- choice' [ (,) <$> spaced pMonthName <*> spaced natural
182 , fmap swap . (,) <$> spaced natural <*> spaced pMonthName
183 ]
184 let
185 (y, _, _) = toGregorian $ utctDay now
186 proto <- fromGregorian' y m d
187 if proto < utctDay now
188 then fromGregorian' (y + 1) m d
189 else return proto
190 , do
191 now <- asks baseTime
192 optional $ spaces *> pNext <* many1 space
193 d <- spaced pWeekdayName
194 let
195 (y, w, _) = toWeekDate $ utctDay now
196 proto <- fromWeekDate' y w d
197 if proto < utctDay now
198 then maybe (fromWeekDate' (y + 1) 1 d) return $ fromWeekDateValid y (w + 1) d
199 else return proto
200 , do
201 spaced $ string' "today"
202 utctDay <$> asks baseTime
203 , do
204 spaced $ string' "tomorrow"
205 succ . utctDay <$> asks baseTime
206 , do
207 y <- natural
208 char '-'
209 m <- natural
210 char '-'
211 d <- natural
212 fromGregorian' y m d
213 , do
214 d <- natural
215 char '.'
216 m <- natural
217 char '.'
218 y <- natural
219 fromGregorian' y m d
220 , do
221 m <- natural
222 char '/'
223 d <- natural
224 char '/'
225 y <- natural
226 fromGregorian' y m d
227 , do
228 ds <- many1 digit
229 when (length ds < 5) $ fail "Insufficient digits to interpret as concatenated date"
230 let
231 d2 : d1 : m2 : m1 : ys = reverse ds
232 d = 10 * d1 + d2
233 m = 10 * m1 + m2
234 y = foldl' (\init last -> init * 10 + last) 0 . map fromIntegral $ reverse ys
235 fromGregorian' y m d
236 , do
237 pNext
238 many1 space
239 fmap utctDay . addUTCTime <$> pSpecOffsetConst <*> asks baseTime
240 ] <?> "Day specification"
241 where
242 fromGregorian' y m d = maybe (fail "Invalid gregorian date") return $ fromGregorianValid y m d
243 fromWeekDate' y w d = maybe (fail "Invalid iso8601 date") return $ fromWeekDateValid y w d
244 pNext = string' "next"
245
246pMonthName :: MonadTP m => ParsecT String () m Int
247pMonthName = choice' (zipWith (<$) [1..] [ strChoice' [ "January", "Jan" ]
248 , strChoice' [ "Febuary", "Feb" ]
249 , strChoice' [ "March", "Mar" ]
250 , strChoice' [ "April", "Apr" ]
251 , strChoice' [ "May" ]
252 , strChoice' [ "June", "Jun" ]
253 , strChoice' [ "July", "Jul" ]
254 , strChoice' [ "August", "Aug" ]
255 , strChoice' [ "September", "Sep" ]
256 , strChoice' [ "October", "Oct" ]
257 , strChoice' [ "November", "Nov" ]
258 , strChoice' [ "December", "Dec" ]
259 ]) <?> "Month name"
260
261pWeekdayName :: MonadTP m => ParsecT String () m Int
262pWeekdayName = choice' (zipWith (<$) [1..] [ strChoice' [ "Monday", "Mon" ]
263 , strChoice' [ "Tuesday", "Tue" ]
264 , strChoice' [ "Wednesday", "Wed" ]
265 , strChoice' [ "Thursday", "Thu" ]
266 , strChoice' [ "Friday", "Fri" ]
267 , strChoice' [ "Saturday", "Sat" ]
268 , strChoice' [ "Sunday", "Sun" ]
269 ])
270
271pTime :: MonadTP m => ParsecT String () m (TimeOfDay, Either TimeZone TZ)
272pTime = choice' [ (,) <$> spaced pTimeBase <*> spaced pTimeZone
273 , (,) <$> spaced pTimeBase <*> asks tz
274 ] <?> "Time of day and timezone specification"
275
276data AMPM = AM | PM
277 deriving (Eq, Ord, Enum)
278
279pTimeBase :: MonadTP m => ParsecT String () m TimeOfDay
280pTimeBase = choice' [ do
281 h <- pHour12
282 m <- option 0 $ char ':' >> pMinute
283 s <- option 0 $ char ':' >> pSecond
284 amPM <- spaced pAMPM
285 let h' = h + fromEnum amPM * 12
286 return $ TimeOfDay h' m s
287 , do
288 h <- pHour
289 m <- option 0 $ char ':' >> pMinute
290 s <- option 0 $ char ':' >> pSecond
291 return $ TimeOfDay h m s
292 , do
293 h <- ensure (<= 24) =<< (\d u -> 10 * d + u) <$> digit <*> digit
294 m <- option 0 $ ensure (< 60) =<< (\d u -> 10 * d + u) <$> digit <*> digit
295 s <- option 0 $ pSecond
296 return $ TimeOfDay h m s
297 , TimeOfDay 0 0 0 <$ string' "midnight"
298 , TimeOfDay 12 0 0 <$ string' "noon"
299 , TimeOfDay 16 0 0 <$ string' "teatime"
300 ] <?> "Time of day specification"
301 where
302 pAMPM = choice [ AM <$ string' "AM"
303 , PM <$ string' "PM"
304 ]
305 pHour12 = (`rem` 12) <$> (ensure (<= 12) =<< natural)
306
307 pHour = (`rem` 24) <$> (ensure (<= 24) =<< natural)
308 pMinute = ensure (< 60) =<< natural
309 pSecond = decimal
12 310
13pTimeSpec :: MonadIO m => ParsecT String () m UTCTime 311pTimeZone :: MonadTP m => ParsecT String () m (Either TimeZone TZ)
14pTimeSpec = undefined 312pTimeZone = choice' [ do
313 sgn <- choice [ id <$ char '+'
314 , negate <$ char '-'
315 ]
316 hs <- (\d u -> 10 * d + u) <$> digit <*> digit
317 ms <- option 0 $ (\d u -> 10 * d + u) <$> digit <*> digit
318 return . Left . minutesToTimeZone $ hs * 60 + ms
319 , do
320 n <- many1 $ letter <|> char '/'
321 tz <- liftIO $ do
322 let
323 fbHandler :: IO a -> (IOException -> IO a)
324 fbHandler fb _ = fb
325 foldl (\fb a -> a `catchError` fbHandler fb) (return Nothing)
326 [ Just <$> loadSystemTZ n
327 , Just <$> loadTZFromDB n
328 ]
329 case tz of
330 Nothing -> fail $ "Could not resolve timezone: " ++ n
331 (Just tz) -> return $ Right tz
332 ]
generated by cgit v1.2.3 (git 2.25.1) at 2025-10-25 00:03:35 +0000