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
|
{-# 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))
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 = foldMap toEndo <$> mkGramSepBy spaces [ absDate
, timeOfDay
]
toEndo :: RWS LocalTime () LocalTime a -> Endo LocalTime
toEndo act = Endo $ \t -> fst $ execRWS act t t
timeOfDay, absDate :: StringParser s m => m (RWS LocalTime () LocalTime ())
timeOfDay = label "Time of day" $ assign time <$> choice
[ TimeOfDay 0 0 0 <$ string' "midnight"
, TimeOfDay 12 0 0 <$ string' "noon"
, TimeOfDay 16 0 0 <$ string' "teatime"
]
absDate = label "Date" . (fmap . (=<<) . assign $ 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) <$> twoDigit
minute = (% Minute) <$> twoDigit
twoDigit = (\n1 n2 -> fromDigit n1 * 10 + fromDigit n2) <$> digitChar <*> digitChar
namedTimezone :: (StringParser s m, MonadIO m) => m TZ
namedTimezone = do
n <- ident
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) <?> "Named timezone identifier"
|
