Prioritised endomorphisms

1 files changed, 71 insertions, 21 deletions

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)