Prioritised endomorphisms

3 files changed, 144 insertions, 21 deletions

diff --git a/lib/Postdelay/PrioMap.hs b/lib/Postdelay/PrioMap.hs
new file mode 100644
index 0000000..2b75984
--- /dev/null
+++ b/lib/Postdelay/PrioMap.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE TemplateHaskell, ViewPatterns, RankNTypes, GeneralizedNewtypeDeriving, DeriveTraversable, ScopedTypeVariables, FlexibleInstances, MultiParamTypeClasses #-}
+
+module Postdelay.PrioMap
+  ( PrioMap, prioMap, prioMap', _Endo
+  , prio, prios
+  , squash
+
+  , PrioEndo, prioEndo, prioEndo'
+  ) where
+
+import Data.IntMap.Strict (IntMap)
+import qualified Data.IntMap.Strict as IntMap
+
+import Control.Lens
+
+import Data.Foldable
+import Data.Semigroup
+  
+
+makePrisms ''Endo
+  
+newtype PrioMap p a = PrioMap (IntMap a)
+  deriving (Functor, Foldable, Traversable)
+makePrisms ''PrioMap
+
+instance Semigroup a => Semigroup (PrioMap p a) where
+  (PrioMap a) <> (PrioMap b) = PrioMap $ IntMap.unionWith (<>) a b
+
+instance Semigroup a => Monoid (PrioMap p a) where
+  mempty = PrioMap mempty
+  mappend = (<>)
+
+instance Enum p => FunctorWithIndex p (PrioMap p) where
+  imap f (PrioMap intMap) = PrioMap $ imap (f . toEnum) intMap
+
+instance Enum p => FoldableWithIndex p (PrioMap p) where
+  ifoldMap f (PrioMap intMap) = ifoldMap (f . toEnum) intMap
+
+instance Enum p => TraversableWithIndex p (PrioMap p) where
+  itraverse f (PrioMap intMap) = PrioMap <$> itraverse (f . toEnum) intMap
+
+
+prioMap :: (Enum p, Monoid a) => Iso' (PrioMap p a) a
+-- ^ `prioMap` squashes priority information into `0`
+prioMap = prioMap' $ toEnum 0
+
+prioMap' :: (Enum p, Monoid a) => p -> Iso' (PrioMap p a) a
+-- ^ `prioMap' p` squashes priority information into `p`
+prioMap' (fromEnum -> p) = _PrioMap . iso fold (IntMap.singleton p)
+
+prio :: Enum p => p -> Lens' (PrioMap p a) (Maybe a)
+prio (fromEnum -> p) = _PrioMap . at p
+
+squash :: Semigroup a => PrioMap p (PrioMap p a) -> PrioMap p a
+squash = unwrapMonoid . foldMap WrapMonoid
+
+prios :: forall f p arr a. (Bounded p, Enum p, Semigroup a, Applicative f, Indexable p arr) => arr (Maybe a) (f (Maybe a)) -> (PrioMap p a -> f (PrioMap p a))
+prios (indexed -> alter) pMap = foldr cons_f (pure $ PrioMap IntMap.empty) [minBound .. maxBound]
+  where
+    cons_f :: p -> f (PrioMap p a) -> f (PrioMap p a)
+    cons_f p x = (<>) <$> (maybe mempty (PrioMap . IntMap.singleton (fromEnum p)) <$> alter p (pMap ^. prio p)) <*> x
+
+
+type PrioEndo p a = PrioMap p (Endo a)
+
+prioEndo :: Enum p => Iso' (PrioEndo p a) (Endo a)
+prioEndo = prioMap
+
+prioEndo' :: Enum p => p -> Iso' (PrioEndo p a) (Endo a)
+prioEndo' = prioMap'
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)
diff --git a/lib/Postdelay/TimeSpec/Utils.hs b/lib/Postdelay/TimeSpec/Utils.hs
index 628a1d9..0bce51a 100644
--- a/lib/Postdelay/TimeSpec/Utils.hs
+++ b/lib/Postdelay/TimeSpec/Utils.hs
@@ -35,6 +35,8 @@ import Text.Megaparsec
 import Text.Megaparsec.Prim (MonadParsec)
 import qualified Text.Megaparsec.Lexer as L
 
+import Debug.Trace
+
 
 type StringParser s m = (MonadParsec Dec s m, Token s ~ Char)
 
@@ -86,6 +88,7 @@ boundedNatural padded (I.intersection (0 <=..< PosInf) -> bounds) = do
           | otherwise = int
 
     digits :: n -> Int
+    digits 0 = 1
     digits n = succ . fromJust $ findIndex (\(min, max) -> min <= n && n < max) [ (10^i, 10^(succ i)) | i <- ([0..] :: [Int]) ]
 
 boundedRational :: forall s m n. (Show n, RealFrac n, StringParser s m)