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