summaryrefslogtreecommitdiff
path: root/lib/Postdelay
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Postdelay')
-rw-r--r--lib/Postdelay/Scan.hs39
-rw-r--r--lib/Postdelay/TimeSpec.hs336
-rw-r--r--lib/Postdelay/TimeSpec/Units.hs111
-rw-r--r--lib/Postdelay/TimeSpec/Utils.hs35
-rw-r--r--lib/Postdelay/Utils.hs21
5 files changed, 183 insertions, 359 deletions
diff --git a/lib/Postdelay/Scan.hs b/lib/Postdelay/Scan.hs
index 2f0a78a..888a237 100644
--- a/lib/Postdelay/Scan.hs
+++ b/lib/Postdelay/Scan.hs
@@ -1,4 +1,4 @@
1{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns, TupleSections #-} 1{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, FlexibleContexts, RecordWildCards, ViewPatterns, TupleSections, RankNTypes #-}
2 2
3module Postdelay.Scan 3module Postdelay.Scan
4 ( scan 4 ( scan
@@ -7,20 +7,18 @@ module Postdelay.Scan
7 ) where 7 ) where
8 8
9import Postdelay.Types 9import Postdelay.Types
10import Postdelay.Utils
11import Postdelay.TimeSpec 10import Postdelay.TimeSpec
12 11
13import Control.Monad 12import Control.Monad
14import Control.Monad.IO.Class 13import Control.Monad.IO.Class
15import Control.Monad.Except 14import Control.Monad.Catch
16import Control.Monad.Reader 15import Control.Monad.Reader
17import Control.Monad.List 16import Control.Monad.List
18import Control.Exception.Base 17import Control.Exception.Base
18import Control.Lens
19 19
20import Text.Parsec.Char 20import qualified Text.Parsec as P
21import Text.Parsec.Prim 21import Text.Megaparsec
22import Text.Parsec.Combinator
23import Text.Parsec.Error (ParseError(..))
24import Text.ParserCombinators.Parsec.Rfc2822 22import Text.ParserCombinators.Parsec.Rfc2822
25import Codec.MIME.Decode (decodeWords) 23import Codec.MIME.Decode (decodeWords)
26 24
@@ -40,17 +38,20 @@ import System.Time (CalendarTime(..))
40 38
41import Debug.Trace 39import Debug.Trace
42 40
41instance Exception P.ParseError
43 42
44scan :: (MonadIO m, MonadError ParseError m) => String -> m (Maybe Delay)
45scan = fmap getOption . extractDelay <=< either throwError return . parse message ""
46 43
47extractDelay :: forall m. (MonadIO m, MonadError ParseError m) => Message -> m (Option Delay) 44scan :: (MonadIO m, MonadThrow m) => String -> m (Maybe Delay)
45scan = fmap getOption . extractDelay <=< either throwM return . P.parse message ""
46
47extractDelay :: forall m. (MonadIO m, MonadThrow m) => Message -> m (Option Delay)
48extractDelay (Message headers _) = do 48extractDelay (Message headers _) = do
49 zones <- zoneHeaders 49 tz <- foldr' (flip (<>)) (Left dateTz) <$> zoneHeaders
50 let (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders 50 let apply f = Until (baseTime & localT tz %~ appEndo f)
51 tz = foldr' (flip (<>)) (Left dateTz) zones 51 fmap apply . foldMap pure <$> mapM parseDelay delayHeaders
52 foldMap pure <$> mapM (flip runReaderT TimeCtx{..} . parseDelay) delayHeaders
53 where 52 where
53 (baseTime, dateTz) = maximumBy (comparing fst) dateHeaders
54
54 delayHeaders :: [Field] 55 delayHeaders :: [Field]
55 delayHeaders = do 56 delayHeaders = do
56 (OptionalField field content) <- headers 57 (OptionalField field content) <- headers
@@ -67,7 +68,11 @@ extractDelay (Message headers _) = do
67 zoneHeaders = runListT $ do 68 zoneHeaders = runListT $ do
68 (OptionalField field content) <- ListT $ return headers 69 (OptionalField field content) <- ListT $ return headers
69 guard $ CI.mk field == "X-Timezone" 70 guard $ CI.mk field == "X-Timezone"
70 Right r <- runParserT (spaces *> pTimeZone <* spaces <* eof) () field content 71 Right r <- runParserT (spaceConsumer *> lexeme pTimeZone <* eof) field content
71 return r 72 return r
72 parseDelay :: Field -> ReaderT TimeCtx m Delay 73 parseDelay :: Field -> m (Endo LocalTime)
73 parseDelay (OptionalField field content) = either throwError return =<< runParserT (Until <$> pTimeSpec) () field content 74 parseDelay (OptionalField field content) = either throwM return =<< runParserT (spaceConsumer *> lexeme pTimeSpec <* eof) field content
75
76localT :: Either TimeZone TZ -> Iso' UTCTime LocalTime
77localT (Left tz) = iso (utcToLocalTime tz) (localTimeToUTC tz)
78localT (Right tz) = iso (utcToLocalTimeTZ tz) (localTimeToUTCTZ tz)
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 ]
diff --git a/lib/Postdelay/TimeSpec/Units.hs b/lib/Postdelay/TimeSpec/Units.hs
new file mode 100644
index 0000000..330997a
--- /dev/null
+++ b/lib/Postdelay/TimeSpec/Units.hs
@@ -0,0 +1,111 @@
1{-# LANGUAGE TemplateHaskell, TypeFamilies, GADTs, RankNTypes, DataKinds, ViewPatterns, ScopedTypeVariables #-}
2
3module Postdelay.TimeSpec.Units
4 ( Time
5
6 , Second, Minute, Hour
7 , Day, Week, Month, Year
8
9 , timeLength
10
11 , module Data.Units.SI.Prefixes
12 ) where
13
14import Postdelay.TimeSpec.Utils
15
16import Control.Applicative
17
18import Data.Metrology
19import Data.Metrology.TH
20import Data.Metrology.SI.Mono ()
21
22import Data.Units.SI
23import Data.Units.SI.Prefixes
24import Data.Units.SI.Parser
25import qualified Data.Dimensions.SI as D
26
27import Data.Foldable
28import Data.Function
29import Data.VectorSpace
30
31import Data.Fixed (Fixed, HasResolution)
32import qualified Data.Fixed as Fixed
33
34
35import Text.Megaparsec
36
37
38declareDerivedUnit "Day" [t| Hour |] 24 Nothing
39declareDerivedUnit "Week" [t| Day |] 7 Nothing
40declareDerivedUnit "Month" [t| Day |] 30 Nothing
41declareDerivedUnit "Year" [t| Day |] 365.25 Nothing
42
43type Time = MkQu_DLN D.Time DefaultLCSU Fixed.Pico
44
45data Prefix where
46 Prefix :: forall p. (UnitPrefix p, Show p) => p -> Prefix
47
48instance HasResolution p => AdditiveGroup (Fixed p) where
49 zeroV = 0
50 (^+^) = (+)
51 negateV = negate
52 (^-^) = (-)
53
54instance HasResolution p => VectorSpace (Fixed p) where
55 type Scalar (Fixed p) = Fixed p
56 (*^) = (*)
57
58
59timeLength :: StringParser s m => m Time
60timeLength = (*^) <$> lexeme rational <*> timeUnit
61
62rational :: forall s m n. (StringParser s m, Fractional n, Num n) => m n
63rational = combine <$> some digitChar <*> option [] (char '.' *> many digitChar)
64 where
65 combine :: [Char] -> [Char] -> n
66 combine (map asN -> whole) (map asN -> fractional)
67 = foldl' (\i l -> i * 10 + l) 0 whole + (foldr' (\h t -> h + t / 10) 0 fractional) / 10
68 asN :: Char -> n
69 asN c = fromIntegral $ ((-) `on` fromEnum) c '0'
70
71timeUnit :: StringParser s m => m Time
72timeUnit = label "Unit of time" . choice $
73 [ 1 % Second <$ choice [ string' "seconds"
74 , string' "second"
75 , string' "secs"
76 , string' "sec"
77 ]
78 , 1 % Minute <$ choice [ string' "minutes"
79 , string' "minute"
80 , string' "mins"
81 , string' "min"
82 ]
83 , 1 % Hour <$ choice [ string' "hours"
84 , string' "hour"
85 ]
86 , 1 % Day <$ choice [ string' "days"
87 , string' "day"
88 ]
89 , 1 % Week <$ choice [ string' "weeks"
90 , string' "week"
91 ]
92 , 1 % Month <$ choice [ string' "months"
93 , string' "month"
94 ]
95 , 1 % Year <$ choice [ string' "years"
96 , string' "year"
97 ]
98 ] ++
99 [ (% Second) <$> option 1 siPrefix <* string "s"
100 , (% Hour) <$> option 1 siPrefix <* string "h"
101 , (% Day) <$> option 1 siPrefix <* string "d"
102 , (% Year) <$> option 1 siPrefix <* choice [ string "a", string "yr", string "yrs" ]
103 ]
104
105siPrefix :: (StringParser s m, Fractional n) => m n
106siPrefix = label "SI prefix" . choice $ map (\(Prefix p) -> multiplier p <$ string (show p))
107 [ Prefix Deca, Prefix Hecto, Prefix Kilo, Prefix Mega, Prefix Giga
108 , Prefix Tera, Prefix Peta, Prefix Exa, Prefix Zetta, Prefix Yotta
109 , Prefix Deci, Prefix Centi, Prefix Milli, Prefix Micro, Prefix Nano
110 , Prefix Pico, Prefix Femto, Prefix Atto, Prefix Zepto, Prefix Yocto
111 ]
diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs
new file mode 100644
index 0000000..e4ba732
--- /dev/null
+++ b/lib/Postdelay/TimeSpec/Utils.hs
@@ -0,0 +1,35 @@
1{-# LANGUAGE RankNTypes, ConstraintKinds, TypeFamilies, FlexibleContexts, ScopedTypeVariables, ViewPatterns #-}
2
3module Postdelay.TimeSpec.Utils where
4
5import Control.Applicative
6import Control.Monad
7import Control.Lens
8
9import Data.Time
10import Data.Time.Zones
11
12import Data.AdditiveGroup
13
14import Text.Megaparsec
15import Text.Megaparsec.Prim (MonadParsec)
16import qualified Text.Megaparsec.Lexer as L
17
18
19type StringParser s m = (MonadParsec Dec s m, Token s ~ Char)
20
21
22spaceConsumer :: StringParser s m => m ()
23spaceConsumer = L.space (void spaceChar) empty empty
24
25lexeme :: StringParser s m => m a -> m a
26lexeme = L.lexeme spaceConsumer
27
28signed, optSigned :: (StringParser s m, AdditiveGroup n) => m n -> m n
29signed = (<*>) (lexeme sign)
30optSigned = (<*>) (option id $ lexeme sign)
31
32sign :: (StringParser s m, AdditiveGroup n) => m (n -> n)
33sign = choice [ id <$ char '+'
34 , negateV <$ char '-'
35 ]
diff --git a/lib/Postdelay/Utils.hs b/lib/Postdelay/Utils.hs
deleted file mode 100644
index d716b4d..0000000
--- a/lib/Postdelay/Utils.hs
+++ /dev/null
@@ -1,21 +0,0 @@
1{-# LANGUAGE FlexibleContexts #-}
2
3module Postdelay.Utils
4 ( hoistParsecT
5 ) where
6
7import Control.Monad.Error.Class
8
9import Data.Functor
10import Data.Either
11
12import Data.Functor.Identity
13import Text.Parsec.Prim
14import Text.Parsec.Error
15
16hoistParsecT :: (Monad m, Stream s Identity t, Stream s m t) => ParsecT s u Identity a -> ParsecT s u m a
17hoistParsecT p = do
18 st <- getParserState
19 let res = runParser p' undefined "" undefined
20 p' = setParserState st >> ((,) <$> getState <*> p)
21 either (fail . show) (\(st', res) -> putState st' $> res) $ res
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-15 02:19:06 +0000