From 0769cc7c46f4aeb3dd1416a62c0d68648ae5f782 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 20 Feb 2017 20:53:15 +0100 Subject: Minor cleanup --- lib/Postdelay/PrioMap.hs | 5 ++++- lib/Postdelay/TimeSpec.hs | 36 +++++++++++++++--------------------- 2 files changed, 19 insertions(+), 22 deletions(-) diff --git a/lib/Postdelay/PrioMap.hs b/lib/Postdelay/PrioMap.hs index 2b75984..97705ba 100644 --- a/lib/Postdelay/PrioMap.hs +++ b/lib/Postdelay/PrioMap.hs @@ -2,7 +2,7 @@ module Postdelay.PrioMap ( PrioMap, prioMap, prioMap', _Endo - , prio, prios + , prio, prio', prios , squash , PrioEndo, prioEndo, prioEndo' @@ -68,3 +68,6 @@ prioEndo = prioMap prioEndo' :: Enum p => p -> Iso' (PrioEndo p a) (Endo a) prioEndo' = prioMap' + +prio' :: Enum p => p -> Setter' (PrioEndo p a) a +prio' p = sets $ \(Endo -> mod) -> mappend $ review (prioMap' p) mod diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs index 454f704..c2ddc3f 100644 --- a/lib/Postdelay/TimeSpec.hs +++ b/lib/Postdelay/TimeSpec.hs @@ -58,13 +58,6 @@ shiftBack by mod@(view (prioEndo._Endo) -> modE) = do 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" $ view prioEndo <$> choice [ flip (<>) <$> lexeme specBase <*> option mempty (offsets True) @@ -110,30 +103,31 @@ timeOfDay = label "Time of day" $ withShift <$> choice 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 - [ (scribeMod Assign date =<< view date) <$ string' "today" - , (scribeMod Assign date =<< views date succ) <$ string' "tomorrow" + [ (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 - scribeMod Assign (flexDT.date.days) =<< views (date.days) succ - scribeMod Default time midnight + scribe (prio' Assign . flexDT.date.days) =<< views (date.days) succ + scribe (prio' Default . time) midnight , string' "week" $> do - scribeMod Assign (flexDT.date.days) =<< views (date.days) (+ 7) - scribeMod Assign (weekDate._3) 1 - scribeMod Default time midnight + scribe (prio' Assign . flexDT.date.days) =<< views (date.days) (+ 7) + scribe (prio' Assign . weekDate._3) 1 + scribe (prio' Default . time) midnight , string' "month" $> do - scribeMod Assign (flexDT.date.months) =<< views (date.months) succ - scribeMod Assign (date.days) 1 - scribeMod Default time midnight + scribe (prio' Assign . flexDT.date.months) =<< views (date.months) succ + scribe (prio' Assign . date.days) 1 + scribe (prio' 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 + 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 ] ] -- cgit v1.2.3