1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
|
{-# LANGUAGE FlexibleContexts, ScopedTypeVariables, ViewPatterns, ConstraintKinds, TupleSections, RecordWildCards, TypeFamilies #-}
module Postdelay.TimeSpec
( timeSpec
, timeZone
, spaceConsumer, lexeme
) where
import Postdelay.TimeSpec.Utils
import Postdelay.TimeSpec.Units
import Postdelay.PrioMap
import Text.Megaparsec
import Control.Monad.IO.Class
import Control.Applicative
import Control.Lens hiding ((#))
import Control.Exception (IOException)
import Control.Monad.Catch hiding (try)
import Control.Monad.RWS hiding ((<>))
import Data.Functor
import Data.Bool
import Data.Semigroup hiding (option)
import Data.Monoid (Endo(..))
import Data.Foldable
import Data.VectorSpace
import Data.Maybe
import Data.Time as Time hiding (months)
import Data.Time.Calendar.WeekDate
import Data.Time.Lens
import Data.Time.Zones
data ModPrio = Offset | Assign | Shift | Default
deriving (Eq, Ord, Enum, Bounded, Show)
seconds' :: Timeable t => Lens' t Time
seconds' = seconds . iso (% Second) (# Second)
utcOffset :: Iso' TimeZone Time
utcOffset = iso ((% Minute) . fromIntegral . timeZoneMinutes) (minutesToTimeZone . round . (# Minute))
weekDate :: Dateable t => Lens' t (Integer, Int, Int)
weekDate = date . iso toWeekDate (\(y, w, d) -> fromWeekDate y w d)
shiftBack :: (MonadReader LocalTime m, MonadWriter (PrioEndo ModPrio LocalTime) m)
=> Time -> m a -> m a
shiftBack by mod = do
(result, modE) <- listen mod
prev <- ask
new <- asks $ view (prioEndo._Endo) modE
when (new <= prev) $
scribe (prio Shift) . Just . Endo $ flexDT.seconds' %~ ((^+^) by)
return result
timeSpec :: forall s m. StringParser s m => m (Endo LocalTime)
timeSpec = label "Relative time specification" $ view prioEndo <$> choice
[ flip (<>) <$> lexeme specBase <*> option mempty (offsets True)
, lexeme (string' "now") *> offsets True
, offsets False
]
where
specBase = toEndo <$> mkGramSepBy spaces [ dateSpec
, timeOfDay
]
toEndo :: [RWS LocalTime (PrioEndo ModPrio LocalTime) () ()] -> PrioEndo ModPrio LocalTime
toEndo (sequence -> act) = mempty & prios .@~ (\i -> Just . Endo $ \t -> maybe t (($ t) . appEndo) . view (prio i) . snd $ execRWS act t ())
timeOfDay, dateSpec :: StringParser s m => m (RWS LocalTime (PrioEndo ModPrio LocalTime) () ())
timeOfDay = label "Time of day" $ withShift <$> choice
[ TimeOfDay 0 0 0 <$ string' "midnight"
, TimeOfDay 12 0 0 <$ string' "noon"
, TimeOfDay 16 0 0 <$ string' "teatime"
, try $ do
h <- hour24 True
m <- minute True
s <- option 0 $ second True
return $ TimeOfDay h m s
, try $ do
h <- hour12 False
m <- option 0 $ char ':' *> minute False
s <- option 0 $ char ':' *> second False
spaceConsumer
amPm <- (0 <$ string' "am") <|> (12 <$ string' "pm")
return $ TimeOfDay (h + amPm) m s
, try $ do
h <- hour24 False
m <- option 0 $ char ':' *> minute False
s <- option 0 $ char ':' *> second False
return $ TimeOfDay h m s
]
where
hour12 pad = label "Modulus 12 hour" . fmap (flip mod 12) . boundedNatural pad $ 1 <=..<= 12
hour24 pad = label "Modulus 24 hour" . boundedNatural pad $ 0 <=..< 24
minute pad = label "Minute" . boundedNatural pad $ 0 <=..< 60
second pad = label "Second" . boundedRational pad $ 0 <=..< 61
withShift :: TimeOfDay -> RWS LocalTime (PrioEndo ModPrio LocalTime) () ()
withShift tod = shiftBack (1 % Day) $ scribe (prio' Assign . time) tod
dateSpec = label "Date" $ (>> scribe (prio' Default . time) midnight) <$> choice
[ (scribe (prio' Assign . date) =<< view date) <$ string' "today"
, (scribe (prio' Assign . date) =<< views date succ) <$ string' "tomorrow"
, try $ do
string' "next"
spaces
choice
[ string' "day" $> do
scribe (prio' Assign . flexDT.date.days) =<< views (date.days) succ
, string' "week" $> do
scribe (prio' Assign . flexDT.date.days) =<< views (date.days) (+ 7)
scribe (prio' Assign . weekDate._3) 1
, string' "month" $> do
scribe (prio' Assign . flexDT.date.months) =<< views (date.months) succ
scribe (prio' Assign . date.days) 1
, string' "year" $> do
scribe (prio' Assign . flexDT.date.years) =<< views (date.years) succ
scribe (prio' Assign . date.months) 1
scribe (prio' Assign . date.days) 1
]
, try $ do
let daySuffix = optional $ choice [ string ".", string' "st", string' "nd", string' "rd", string' "th" ]
(m, d) <- choice [ try $ (,) <$> monthName <* spaces <*> dayNumber False <* daySuffix
, try $ flip (,) <$> dayNumber False <* daySuffix <* spaces <*> monthName
]
y <- optional . try $ do
spaces
optional . lexeme $ char ','
yearNumber <* lookAhead (spaces <|> eof)
return $ scribeDate y m d
, try $ do
m <- monthNumber False
char '/'
d <- dayNumber False
y <- optional . try $ char '/' *> yearNumber <* lookAhead (spaces <|> eof)
return $ scribeDate y m d
, try $ do
d <- dayNumber False
char '.'
m <- monthNumber False
y <- optional . try $ char '.' *> yearNumber <* lookAhead (spaces <|> eof)
return $ scribeDate y m d
, try $ do
(Just -> y) <- yearNumber
char '-'
m <- monthNumber True
char '-'
d <- dayNumber True
return $ scribeDate y m d
, try $ do
ds <- lookAhead $ length <$ (optional $ ($ ()) <$> sign) <*> some digitChar <* lookAhead (spaces <|> eof)
let yDs = ds - 2 {- month-} - 2 {- day -}
when (yDs <= 0) $
fail "Too few digits to interpret as concatenated date"
(Just -> y) <- optSigned . boundedNatural True $ 10^(pred yDs) <=..< 10^yDs
m <- monthNumber True
d <- dayNumber True
return $ scribeDate y m d
, monthName <$$> \m -> shiftBack (1 % Year) $ do
scribe (prio' Assign . flexDT.date.months) m
scribe (prio' Assign . flexDT.date.days) 1
, weekdayName <$$> \w -> shiftBack (1 % Week) $ do
scribe (prio' Assign . weekDate._3) w
]
where
withYear y
| Just y' <- y = (>>) $ scribe (prio' Assign . date.years) y'
| otherwise = shiftBack (1 % Year)
scribeDate y m d = withYear y $ do
scribe (prio' Assign . date.months) m
scribe (prio' Assign . flexDT.date.days) d
(<$$>) = flip (<$>)
monthName = choice $ zipWith (<$) [1..] [ string' "january" <|> string' "jan"
, string' "febuary" <|> string' "feb"
, string' "march" <|> string' "mar"
, string' "april" <|> string' "apr"
, string' "may"
, string' "june" <|> string' "jun"
, string' "july" <|> string' "jul"
, string' "august" <|> string' "aug"
, string' "september" <|> string' "sep"
, string' "october" <|> string' "oct"
, string' "november" <|> string' "nov"
, string' "december" <|> string' "dec"
]
weekdayName = choice $ zipWith (<$) [1..] [ string' "monday" <|> string' "mon"
, string' "tuesday" <|> string' "tue"
, string' "wednesday" <|> string' "wed"
, string' "thursday" <|> string' "thu"
, string' "friday" <|> string' "fri"
, string' "saturday" <|> string' "sat"
, string' "sunday" <|> string' "sun"
]
dayNumber p = boundedNatural p (1 <=..<= 31)
monthNumber p = boundedNatural p (1 <=..<= 12)
yearNumber = optSigned $ boundedNatural False (0 <=..< PosInf)
offsets :: forall s m. StringParser s m
=> Bool -- ^ Require sign on first offset?
-> m (PrioEndo ModPrio LocalTime)
offsets reqSgn = fmap (foldMap . review $ prioEndo' Offset) $ (:) <$> offset reqSgn <*> many (offset False)
where
asOffset :: Time -> Endo LocalTime
asOffset by = Endo $ flexDT.seconds' %~ (^+^ by)
offset :: Bool -> m (Endo LocalTime)
offset (bool (optSigned, "Time offset") (signed, "Signed time offset") -> (sgn, desc))
= asOffset <$> lexeme (sgn timeLength) <?> desc
timeZone :: (StringParser s m, MonadIO m) => m (Either TimeZone TZ)
timeZone = label "Timezone" $ (Left <$> numericTimezone) <|> (Right <$> namedTimezone)
numericTimezone :: StringParser s m => m TimeZone
numericTimezone = review utcOffset <$> (sign <*> ((^+^) <$> hour <*> minute)) <?> "Numeric timezone"
where
hour = (% Hour) <$> boundedNatural True (0 <=..<= 24)
minute = (% Minute) <$> boundedNatural True (0 <=..< 60)
namedTimezone :: (StringParser s m, MonadIO m) => m TZ
namedTimezone = do
n <- ident <?> "Named timezone identifier"
tz <- liftIO $ do
let
fbHandler :: IO a -> (IOException -> IO a)
fbHandler fb _ = fb
foldl (\fb a -> a `catch` fbHandler fb) (return Nothing)
[ Just <$> loadSystemTZ n
, Just <$> loadTZFromDB n
]
case tz of
Nothing -> fail $ "Could not resolve timezone: " ++ show n
(Just tz) -> return tz
where
asciiAlphaNum = oneOf $ ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z']
ident = (++) <$> some asciiAlphaNum <*> option [] ((:) <$> oneOf "_-/.+" <*> ident)
|
