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
|
{-# 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 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.Bool
import Data.Semigroup hiding (option)
import Data.Monoid (Endo(..))
import Data.Foldable
import Data.VectorSpace
import Data.Time
import Data.Time.Lens
import Data.Time.Zones
seconds' :: Timeable t => Lens' t Time
seconds' = seconds . iso (% Second) (# Second)
utcOffset :: Iso' TimeZone Time
utcOffset = iso ((% Minute) . fromIntegral . timeZoneMinutes) (minutesToTimeZone . round . (# Minute))
shiftBack :: MonadState LocalTime m => Time -> m a -> m a
shiftBack by mod = join $ shiftBack' <$> get <*> mod <*> get
where
shiftBack' prev ret new
| new < prev = ret <$ (flexDT.seconds' %= (^+^) by)
| otherwise = pure ret
timeSpec :: forall s m. StringParser s m => m (Endo LocalTime)
timeSpec = label "Relative time specification" $
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 () LocalTime a] -> Endo LocalTime
toEndo (sequence -> act) = Endo $ \t -> fst $ execRWS act t t
timeOfDay, dateSpec :: StringParser s m => m (RWS LocalTime () LocalTime ())
timeOfDay = label "Time of day" $ shiftBack (1 % Day) . assign time <$> 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
]
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
dateSpec = label "Date" $ (date <~) <$> choice
[ view date <$ string' "today"
, views date succ <$ string' "tomorrow"
]
offsets :: forall s m. StringParser s m
=> Bool -- ^ Require sign on first offset?
-> m (Endo LocalTime)
offsets reqSgn = fmap fold $ (:) <$> offset reqSgn <*> many (offset False)
where
asOffset :: Time -> Endo LocalTime
asOffset by = Endo $ flexDT.seconds' %~ (^+^ by)
offset :: Bool -> m (Endo LocalTime)
offset sgnReq@(bool optSigned signed -> sgn)
= asOffset <$> lexeme (sgn timeLength) <?> if sgnReq then "Signed time offset" else "Time offset"
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)
|
