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
|
{-# 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 -> PrioEndo ModPrio LocalTime -> m ()
shiftBack by mod@(view (prioEndo._Endo) -> modE) = do
tell mod
prev <- ask
new <- asks modE
case new <= prev of
True -> scribe (prio Shift) . Just . Endo $ flexDT.seconds' %~ ((^+^) by)
False -> return ()
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 [ timeOfDay
, dateSpec
]
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 = shiftBack (1 % Day) . mod' Assign time
mod' priority setter val = mempty & prio priority .~ (Just . Endo $ set setter val)
dateSpec = label "Date" $ choice
[ (scribe (prio' Assign . date) =<< view date) <$ string' "today"
, (scribe (prio' Assign . date) =<< views date succ) <$ string' "tomorrow"
, do
string' "next"
spaces
choice
[ string' "day" $> do
scribe (prio' Assign . flexDT.date.days) =<< views (date.days) succ
scribe (prio' Default . time) midnight
, string' "week" $> do
scribe (prio' Assign . flexDT.date.days) =<< views (date.days) (+ 7)
scribe (prio' Assign . weekDate._3) 1
scribe (prio' Default . time) midnight
, string' "month" $> do
scribe (prio' Assign . flexDT.date.months) =<< views (date.months) succ
scribe (prio' Assign . date.days) 1
scribe (prio' Default . time) midnight
, 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
scribe (prio' Default . time) midnight
]
]
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)
|
