shiftBack

1 files changed, 18 insertions, 11 deletions

diff --git a/lib/Postdelay/TimeSpec.hs b/lib/Postdelay/TimeSpec.hs
index 8244885..384de4b 100644
--- a/lib/Postdelay/TimeSpec.hs
+++ b/lib/Postdelay/TimeSpec.hs
@@ -36,6 +36,13 @@ 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" $
@@ -44,23 +51,23 @@ timeSpec = label "Relative time specification" $
                   , offsets False
                   ]
   where
-    specBase = foldMap toEndo <$> mkGramSepBy spaces [ absDate
-                                                     , timeOfDay
-                                                     ]
+    specBase = toEndo <$> mkGramSepBy spaces [ timeOfDay
+                                             , dateSpec
+                                             ]
     
-    toEndo :: RWS LocalTime () LocalTime a -> Endo LocalTime
-    toEndo act = Endo $ \t -> fst $ execRWS act t t
+    toEndo :: [RWS LocalTime () LocalTime a] -> Endo LocalTime
+    toEndo acts = Endo $ \t -> fst $ execRWS (sequence acts) t t
 
-timeOfDay, absDate :: StringParser s m => m (RWS LocalTime () LocalTime ())
-timeOfDay = label "Time of day" $ assign time <$> choice
+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"
             ]
-absDate = label "Date" . (fmap . (=<<) . assign $ date) $ choice
-          [ view date <$ string' "today"
-          , views date succ <$ string' "tomorrow"
-          ]
+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?