From 479d66dd0b3c2b6919e626b1c3c3fea9b0c9df8a Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Fri, 17 Feb 2017 22:04:43 +0100 Subject: Prioritised endomorphisms --- lib/Postdelay/TimeSpec.hs | 92 ++++++++++++++++++++++++++++++++++++----------- 1 file changed, 71 insertions(+), 21 deletions(-) (limited to 'lib/Postdelay/TimeSpec.hs') diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs index 4a32317..9361057 100644 --- a/lib/Postdelay/TimeSpec.hs +++ b/lib/Postdelay/TimeSpec.hs @@ -9,6 +9,7 @@ module Postdelay.TimeSpec import Postdelay.TimeSpec.Utils import Postdelay.TimeSpec.Units +import Postdelay.PrioMap import Text.Megaparsec @@ -19,47 +20,67 @@ 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 +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)) -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 +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 () + +mod' :: ModPrio -> ASetter' LocalTime a -> a -> PrioEndo ModPrio LocalTime +mod' priority setter val = mempty & prio priority .~ (Just . Endo $ set setter val) + +scribeMod :: MonadWriter (PrioEndo ModPrio LocalTime) m => ModPrio -> ASetter' LocalTime a -> a -> m () +scribeMod priority setter val = tell $ mod' priority setter val 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 - ] +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 () LocalTime a] -> Endo LocalTime - toEndo (sequence -> act) = Endo $ \t -> fst $ execRWS act t t + 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 () LocalTime ()) -timeOfDay = label "Time of day" $ shiftBack (1 % Day) . assign time <$> choice +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" @@ -75,22 +96,51 @@ timeOfDay = label "Time of day" $ shiftBack (1 % Day) . assign time <$> choice 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 -dateSpec = label "Date" $ (date <~) <$> choice - [ view date <$ string' "today" - , views date succ <$ string' "tomorrow" +dateSpec = label "Date" $ choice + [ (scribeMod Assign date =<< view date) <$ string' "today" + , (scribeMod Assign date =<< views date succ) <$ string' "tomorrow" + , do + string' "next" + spaces + choice + [ string' "day" $> do + scribeMod Assign (flexDT.date.days) =<< views (date.days) succ + scribeMod Default time midnight + , string' "week" $> do + scribeMod Assign (flexDT.date.days) =<< views (date.days) (+ 7) + scribeMod Assign (weekDate._3) 1 + scribeMod Default time midnight + , string' "month" $> do + scribeMod Assign (flexDT.date.months) =<< views (date.months) succ + scribeMod Assign (date.days) 1 + scribeMod Default time midnight + , string' "year" $> do + scribeMod Assign (flexDT.date.years) =<< views (date.years) succ + scribeMod Assign (date.months) 1 + scribeMod Assign (date.days) 1 + scribeMod Default time midnight + ] ] 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) + -> 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) -- cgit v1.2.3