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/PrioMap.hs | 70 +++++++++++++++++++++++++++++++ lib/Postdelay/TimeSpec.hs | 92 +++++++++++++++++++++++++++++++---------- lib/Postdelay/TimeSpec/Utils.hs | 3 ++ 3 files changed, 144 insertions(+), 21 deletions(-) create mode 100644 lib/Postdelay/PrioMap.hs (limited to 'lib/Postdelay') 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) -- cgit v1.2.3