packages feed

antikythera (empty) → 0.1.0.0

raw patch · 9 files changed

+1052/−0 lines, 9 filesdep +antikytheradep +basedep +hspec

Dependencies added: antikythera, base, hspec, hspec-core, time, unbounded-delays

Files

+ LICENSE view
@@ -0,0 +1,15 @@+ISC License++Copyright (c) 2025 Gautier DI FOLCO++Permission to use, copy, modify, and/or distribute this software for any+purpose with or without fee is hereby granted, provided that the above+copyright notice and this permission notice appear in all copies.++THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES WITH+REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY+AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT,+INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM+LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR+OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR+PERFORMANCE OF THIS SOFTWARE.
+ antikythera.cabal view
@@ -0,0 +1,92 @@+cabal-version:       3.0+name:                antikythera+version:             0.1.0.0+author:              Gautier DI FOLCO+maintainer:          gautier.difolco@gmail.com+category:            Scheduling+build-type:          Simple+license:             ISC+license-file:        LICENSE+synopsis:            Simple job/task/event scheduler/cronjob+description:         In-memory cronjob simple and flexible builder.+Homepage:            https://github.com/blackheaven/antikythera+tested-with:         GHC==9.6.6, GHC==9.8.4, GHC==9.10.1, GHC==9.12.1++library+  default-language:   Haskell2010+  build-depends:+      base == 4.*+    , time >= 1.9 && < 2+    , unbounded-delays == 0.1.*+  hs-source-dirs: src+  exposed-modules:+    Control.Antikythera.Periodicity+    Control.Antikythera.Scheduling+    Control.Antikythera.Unit.Time+    Control.Antikythera.Unit.Unit+    Control.Antikythera.Unit+    Control.Antikythera+  other-modules:+    Paths_antikythera+  autogen-modules:+    Paths_antikythera+  default-extensions:+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveGeneric+    DerivingStrategies+    DerivingVia+    DuplicateRecordFields+    FlexibleContexts+    GADTs+    GeneralizedNewtypeDeriving+    KindSignatures+    LambdaCase+    OverloadedStrings+    OverloadedRecordDot+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    TypeApplications+    TypeFamilies+    TypeOperators+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints++test-suite antikythera-test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  main-is: Spec.hs+  other-modules:+    Paths_antikythera+  autogen-modules:+    Paths_antikythera+  default-extensions:+    DataKinds+    DefaultSignatures+    DeriveAnyClass+    DeriveGeneric+    DerivingStrategies+    DerivingVia+    DuplicateRecordFields+    FlexibleContexts+    GADTs+    GeneralizedNewtypeDeriving+    KindSignatures+    LambdaCase+    OverloadedStrings+    OverloadedRecordDot+    RankNTypes+    RecordWildCards+    ScopedTypeVariables+    TypeApplications+    TypeFamilies+    TypeOperators+  ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints+  build-depends:+      base+    , antikythera+    , hspec+    , hspec-core+    , time+  default-language: Haskell2010
+ src/Control/Antikythera.hs view
@@ -0,0 +1,20 @@+-- |+-- Module        : Control.Antikythera+-- Copyright     : Gautier DI FOLCO+-- License       : ISC+--+-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability     : Stable+-- Portability   : Portable+--+-- Standalone module including everything needed to build a scheduler+--+-- > import Control.Antikythera+-- >+-- > runPeriodicityZonedTime (inclusiveRange (Min 8) (Max 23) hour .&& every 30 minute) $+-- >   putStrLn "Don't forget to hydrate"+module Control.Antikythera (module X) where++import Control.Antikythera.Periodicity as X+import Control.Antikythera.Scheduling as X+import Control.Antikythera.Unit as X
+ src/Control/Antikythera/Periodicity.hs view
@@ -0,0 +1,276 @@+-- |+-- Module        : Control.Antikythera.Periodicity+-- Copyright     : Gautier DI FOLCO+-- License       : ISC+--+-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability     : Stable+-- Portability   : Portable+--+-- Defining a 'Periodicity', how often/when an event occurs+module Control.Antikythera.Periodicity+  ( Periodicity (..),+    nextPeriods,++    -- * Base helpers+    never,+    always,++    -- * Combinators+    (.&&),+    (.||),+    allOf,+    anyOf,+    allOf',+    anyOf',++    -- * 'Unit'-based builders+    at,+    ats,+    every,+    inclusiveRange,++    -- * Absolute builders+    sinceInclusive,+    untilInclusive,++    -- * Reexports+    Max (..),+    Min (..),+  )+where++import Control.Antikythera.Unit.Unit+import Control.Arrow ((&&&))+import Control.Monad (mfilter)+import Data.List (unfoldr)+import qualified Data.List.NonEmpty as NE+import Data.Semigroup++-- | Event recurring period+--+-- Are we at @17:*@?+--+-- > (at 17 hour).includes now+--+-- Next @*:05@+--+-- > (at 5 minute).nextPeriod now+data Periodicity a = Periodicity+  { includes :: a -> Bool,+    nextPeriod :: a -> Maybe a+  }++-- | Get a poentially infinite list of upcoming event+--+-- __Warning:__ may loop infinitelly+nextPeriods :: Periodicity a -> a -> [a]+nextPeriods p = unfoldr (fmap (id &&& id) . p.nextPeriod)++-- * Base helpers++-- | Never happen+never :: Periodicity a+never =+  Periodicity+    { includes = const False,+      nextPeriod = const Nothing+    }++-- | Always happen+--+-- Going from minute to minute:+--+-- > always (addUTCTime $ secondsToNominalDiffTime 60)+always ::+  -- | Increment to next value+  (a -> a) ->+  Periodicity a+always f =+  Periodicity+    { includes = const True,+      nextPeriod = Just . f+    }++-- * Combinators++-- | Intersection of two periods+--+-- Everyday at @15:15@+--+-- > at 15 hour .&& at 15 minute+--+-- __Warning:__ may loop infinitelly when impossible constraints, e.g.+--+-- > at 15 minutes .&& at 15 minute+(.&&) :: (Ord a) => Periodicity a -> Periodicity a -> Periodicity a+x .&& y =+  Periodicity+    { includes = \c -> x.includes c && y.includes c,+      nextPeriod =+        let go c =+              case (x.nextPeriod c, y.nextPeriod c) of+                (Just n, Just m) ->+                  let c' = min m n+                   in if x.includes c' && y.includes c'+                        then Just c'+                        else go c'+                _ -> Nothing+         in go+    }++infixr 3 .&&++-- | Union of two periods+--+-- Everyday at @15:*@ or every hour at @*:15@+--+-- > at 15 hour .|| at 15 minute+(.||) :: (Ord a) => Periodicity a -> Periodicity a -> Periodicity a+x .|| y =+  Periodicity+    { includes = \c -> x.includes c || y.includes c,+      nextPeriod = \c ->+        case (x.nextPeriod c, y.nextPeriod c) of+          (Just n, Just m) -> Just $ min n m+          (Just n, _) -> Just n+          (_, o) -> o+    }++infixr 2 .||++-- | Intersections of all periods+--+-- Same as+--+-- > allOf = foldl1 (.&&)+--+-- __Warning:__ may loop infinitelly when impossible constraints, see '(.&&)'+allOf :: (Ord a) => NE.NonEmpty (Periodicity a) -> Periodicity a+allOf = foldl1 (.&&)++-- | Unions of all periods+--+-- Same as+--+-- > anyOf = foldl1 (.||)+anyOf :: (Ord a) => NE.NonEmpty (Periodicity a) -> Periodicity a+anyOf = foldl1 (.||)++-- | Intersections of all periods+--+-- Same as+--+-- > allOf' = foldl (.&&) . always+--+-- __Warning:__ may loop infinitelly when impossible constraints, see '(.&&)'+allOf' :: (Foldable f, Ord a) => (a -> a) -> f (Periodicity a) -> Periodicity a+allOf' = foldl (.&&) . always++-- | Unions of all periods+--+-- Same as+--+-- > anyOf' = foldl (.||) never+anyOf' :: (Foldable f, Ord a) => f (Periodicity a) -> Periodicity a+anyOf' = foldl (.||) never++-- * 'Unit'-based builders++-- | Happens when the 'Unit' has a value+--+-- Every hour at @*:05@+--+-- > at 5 minute+at :: (Eq i) => i -> Unit i a -> Periodicity a+at n u =+  Periodicity+    { includes = (== n) . u.extract,+      nextPeriod = u.nextUnitWith n+    }++-- | Happens when the 'Unit' has one of the values+--+-- Every hour at @*:05@ and @*:35@+--+-- > ats [5, 35] minute+--+-- Equivalent to+--+-- > at 5 minute .|| at 35 minute+ats :: (Ord i) => NE.NonEmpty i -> Unit i a -> Periodicity a+ats ns u =+  Periodicity+    { includes = (`elem` ns') . u.extract,+      nextPeriod = \x -> u.nextUnitWith (nextCandidate $ u.extract x) x+    }+  where+    ns' = NE.sort ns+    nextCandidate x =+      case NE.dropWhile (<= x) ns' of+        (c : _) -> c+        _ -> NE.head ns'++-- | Happens when the 'Unit' has a value with a modulo+--+-- Every hour at @*:00@, @*:15@, @*:30@, and @*:45@+--+-- > every 15 minute+every :: (Integral i) => i -> Unit i a -> Periodicity a+every n u =+  Periodicity+    { includes = ((== 0) . flip mod n) . u.extract,+      nextPeriod = \x -> u.nextUnitWith (nextCandidate $ u.extract x) x+    }+  where+    nextCandidate x = n * succ (x `div` n)++-- | Happens when the 'Unit' has a value in an inclusive range+--+-- Every hour at @*:05@, @*:06@, @*:07@, @*:08@, @*:09@, @*:10@+--+-- > inclusiveRange (Min 5) (Max 10) minute+inclusiveRange :: (Enum i, Ord i) => Min i -> Max i -> Unit i a -> Periodicity a+inclusiveRange (Min lowerBound) (Max upperBound) u =+  Periodicity+    { includes = (\n -> n >= lowerBound && n <= upperBound) . u.extract,+      nextPeriod = \x -> u.nextUnitWith (nextCandidate $ u.extract x) x+    }+  where+    nextCandidate x =+      if x < upperBound+        then succ x+        else lowerBound++-- * Absolute builders++-- | An event only hapenning /since/+sinceInclusive ::+  (Ord a) =>+  -- | Increment to next value+  (a -> a) ->+  a ->+  Periodicity a+sinceInclusive f startingAt =+  Periodicity+    { includes = (>= startingAt),+      nextPeriod =+        \x ->+          Just $+            if x < startingAt+              then startingAt+              else f x+    }++-- | An event only hapenning /until/+untilInclusive ::+  (Ord a) =>+  -- | Increment to next value+  (a -> a) ->+  a ->+  Periodicity a+untilInclusive f endingAt =+  Periodicity+    { includes = (<= endingAt),+      nextPeriod = mfilter (<= endingAt) . Just . f+    }
+ src/Control/Antikythera/Scheduling.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE NumericUnderscores #-}++-- |+-- Module        : Control.Antikythera+-- Copyright     : Gautier DI FOLCO+-- License       : ISC+--+-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability     : Stable+-- Portability   : Portable+--+-- Run an action given a 'Periodicity'+--+-- > import Control.Antikythera+-- >+-- > runPeriodicityZonedTime (inclusiveRange (Min 8) (Max 23) hour .&& every 30 minute) $+-- >   putStrLn "Don't forget to hydrate"+module Control.Antikythera.Scheduling+  ( -- * 'Periodicity' runners+    runPeriodicityUTCTime,+    runPeriodicityZonedTime,+    runPeriodicityZonedTime',+    runPeriodicity,+    runPeriodicityWithHooks,++    -- * Position in time+    PositionInTime (..),+    utcTime,+    zonedTime,+    zonedTime',+  )+where++import Control.Antikythera.Periodicity+import Control.Antikythera.Unit.Time+import Control.Concurrent.Thread.Delay (delay)+import Control.Monad (forM_)+import Data.Time++-- * 'Periodicity' runners++-- | Run an action given a 'Periodicity' using system's 'UTCTime'+--+-- Note: the action is run in the loop, consider using a dedicated thread as any exception would break it+runPeriodicityUTCTime :: Periodicity UTCTime -> IO () -> IO ()+runPeriodicityUTCTime = runPeriodicity utcTime++-- | Run an action given a 'Periodicity' using system's 'ZonedTime' (wrapped to accomodate combination operators)+--+-- Note: the action is run in the loop, consider using a dedicated thread as any exception would break it+runPeriodicityZonedTime :: Periodicity ZonedTimeWrapped -> IO () -> IO ()+runPeriodicityZonedTime = runPeriodicity zonedTime++-- | Run an action given a 'Periodicity' using system's 'ZonedTime'+--+-- Note: the action is run in the loop, consider using a dedicated thread as any exception would break it+runPeriodicityZonedTime' :: Periodicity ZonedTime -> IO () -> IO ()+runPeriodicityZonedTime' = runPeriodicity zonedTime'++-- | Run an action given a 'Periodicity'+--+-- Note: the action is run in the loop, consider using a dedicated thread as any exception would break it+runPeriodicity ::+  -- | Fetch the time and compute the delay time+  PositionInTime t ->+  Periodicity t ->+  IO () ->+  IO ()+runPeriodicity =+  runPeriodicityWithHooks+    (const $ return ())+    (return ())+    (const $ return ())++-- | Run an action given a 'Periodicity' with hooks+--+-- Note: the action is run in the loop, consider using a dedicated thread as any exception would break it+runPeriodicityWithHooks ::+  -- | Hooks planned+  (t -> IO ()) ->+  -- | Hooks at time (before running the action)+  IO () ->+  -- | Hooks done+  (a -> IO ()) ->+  -- | Fetch the time and compute the delay time+  PositionInTime t ->+  Periodicity t ->+  IO a ->+  IO ()+runPeriodicityWithHooks hookPlanned hookBefore hookAfter pit p f = do+  now <- pit.getTime+  forM_ (p.nextPeriod now) $ \next -> do+    hookPlanned next+    delay $ pit.delayMicroSeconds now next+    hookBefore+    f >>= hookAfter+    runPeriodicityWithHooks hookPlanned hookBefore hookAfter pit p f++-- * Position in time++-- | Fetch the time and compute the delay time+data PositionInTime t = PositionInTime+  { getTime :: IO t,+    -- | now -> nextPeriod -> µs+    delayMicroSeconds :: t -> t -> Integer+  }++-- | System's 'UTCTime'+utcTime :: PositionInTime UTCTime+utcTime =+  PositionInTime+    { getTime = getCurrentTime,+      delayMicroSeconds = \now next ->+        ceiling $ 1_000_000 * nominalDiffTimeToSeconds (diffUTCTime next now)+    }++-- | System's 'ZonedTime' (wrapped to accomodate combination operators)+zonedTime :: PositionInTime ZonedTimeWrapped+zonedTime =+  PositionInTime+    { getTime = ZonedTimeWrapped <$> getZonedTime,+      delayMicroSeconds = \(ZonedTimeWrapped now) (ZonedTimeWrapped next) ->+        ceiling $ 1_000_000 * nominalDiffTimeToSeconds (diffUTCTime (zonedTimeToUTC next) (zonedTimeToUTC now))+    }++-- | System's 'ZonedTime'+zonedTime' :: PositionInTime ZonedTime+zonedTime' =+  PositionInTime+    { getTime = getZonedTime,+      delayMicroSeconds = \now next ->+        ceiling $ 1_000_000 * nominalDiffTimeToSeconds (diffUTCTime (zonedTimeToUTC next) (zonedTimeToUTC now))+    }
+ src/Control/Antikythera/Unit.hs view
@@ -0,0 +1,14 @@+-- |+-- Module        : Control.Antikythera.Unit+-- Copyright     : Gautier DI FOLCO+-- License       : ISC+--+-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability     : Stable+-- Portability   : Portable+--+-- Everything needed to use 'Unit', for 'Periodicy' definition+module Control.Antikythera.Unit (module X) where++import Control.Antikythera.Unit.Time as X+import Control.Antikythera.Unit.Unit as X
+ src/Control/Antikythera/Unit/Time.hs view
@@ -0,0 +1,342 @@+-- |+-- Module        : Control.Antikythera.Unit.Time+-- Copyright     : Gautier DI FOLCO+-- License       : ISC+--+-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability     : Stable+-- Portability   : Portable+--+-- Every time-'Unit' classes/instances+--+-- > every 5 minute+module Control.Antikythera.Unit.Time+  ( -- * Units+    HasMinute (..),+    HasHour (..),+    HasWeekDay (..),+    HasMonthDay (..),+    HasMonth (..),+    HasYear (..),++    -- * Helpers+    ZonedTimeWrapped (..),+  )+where++import Control.Antikythera.Unit.Unit+import Data.Function (on)+import Data.List (find)+import Data.Time+import Data.Time.Calendar.Month+import Data.Time.Format.ISO8601 (ISO8601)++-- * Units++-- | Every type with minutes+--+-- > every 5 minute+class HasMinute a where+  minute :: Unit Int a++instance HasMinute TimeOfDay where+  minute =+    Unit+      { extract = todMin,+        nextUnitWith = \n x ->+          let m = n `mod` 60+           in Just $ TimeOfDay ((x.todHour + (if m <= x.todMin then 1 else 0)) `mod` 24) m 0+      }++instance HasMinute LocalTime where+  minute =+    Unit+      { extract = minute.extract . localTimeOfDay,+        nextUnitWith = \n x ->+          flip fmap (minute.nextUnitWith n x.localTimeOfDay) $ \tod ->+            LocalTime ((if tod <= x.localTimeOfDay then succ else id) x.localDay) tod+      }++instance HasMinute UTCTime where+  minute =+    Unit+      { extract = minute.extract . timeToTimeOfDay . utctDayTime,+        nextUnitWith = \n x ->+          flip fmap (minute.nextUnitWith n $ timeToTimeOfDay x.utctDayTime) $ \tod ->+            UTCTime ((if timeOfDayToTime tod <= x.utctDayTime then succ else id) x.utctDay) (timeOfDayToTime tod)+      }++instance HasMinute ZonedTime where+  minute =+    Unit+      { extract = minute.extract . zonedTimeToLocalTime,+        nextUnitWith = \n x ->+          flip ZonedTime (zonedTimeZone x) <$> minute.nextUnitWith n (zonedTimeToLocalTime x)+      }++instance HasMinute UniversalTime where+  minute =+    Unit+      { extract = minute.extract . ut1ToLocalTime 0,+        nextUnitWith = \n x ->+          localTimeToUT1 0 <$> minute.nextUnitWith n (ut1ToLocalTime 0 x)+      }++-- | Every type with hours+--+-- > every 5 hour+class HasHour a where+  hour :: Unit Int a++instance HasHour TimeOfDay where+  hour =+    Unit+      { extract = todHour,+        nextUnitWith = \n _ ->+          Just $ TimeOfDay (n `mod` 24) 0 0+      }++instance HasHour LocalTime where+  hour =+    Unit+      { extract = hour.extract . localTimeOfDay,+        nextUnitWith = \n x ->+          flip fmap (hour.nextUnitWith n x.localTimeOfDay) $ \tod ->+            LocalTime ((if tod <= x.localTimeOfDay then succ else id) x.localDay) tod+      }++instance HasHour UTCTime where+  hour =+    Unit+      { extract = hour.extract . timeToTimeOfDay . utctDayTime,+        nextUnitWith = \n x ->+          flip fmap (hour.nextUnitWith n $ timeToTimeOfDay x.utctDayTime) $ \tod ->+            UTCTime ((if timeOfDayToTime tod <= x.utctDayTime then succ else id) x.utctDay) (timeOfDayToTime tod)+      }++instance HasHour ZonedTime where+  hour =+    Unit+      { extract = hour.extract . zonedTimeToLocalTime,+        nextUnitWith = \n x ->+          flip ZonedTime (zonedTimeZone x) <$> hour.nextUnitWith n (zonedTimeToLocalTime x)+      }++instance HasHour UniversalTime where+  hour =+    Unit+      { extract = hour.extract . ut1ToLocalTime 0,+        nextUnitWith = \n x ->+          localTimeToUT1 0 <$> hour.nextUnitWith n (ut1ToLocalTime 0 x)+      }++-- | Every type with week days (Mon - Sun)+--+-- > every 5 weekDay+class HasWeekDay a where+  weekDay :: Unit DayOfWeek a++instance HasWeekDay DayOfWeek where+  weekDay =+    Unit+      { extract = id,+        nextUnitWith = const . Just+      }++instance HasWeekDay Day where+  weekDay =+    Unit+      { extract = weekDay.extract . dayOfWeek,+        nextUnitWith = \n x ->+          let wd = dayOfWeek $ succ x+           in (\wd' -> addDays (fromIntegral (dayOfWeekDiff wd' wd) + 1) x) <$> weekDay.nextUnitWith n wd+      }++instance HasWeekDay LocalTime where+  weekDay =+    Unit+      { extract = weekDay.extract . localDay,+        nextUnitWith = \n x ->+          (`LocalTime` midnight) <$> weekDay.nextUnitWith n (localDay x)+      }++instance HasWeekDay UTCTime where+  weekDay =+    Unit+      { extract = weekDay.extract . utctDay,+        nextUnitWith = \n x ->+          (`UTCTime` 0) <$> weekDay.nextUnitWith n (utctDay x)+      }++instance HasWeekDay ZonedTime where+  weekDay =+    Unit+      { extract = weekDay.extract . zonedTimeToLocalTime,+        nextUnitWith = \n x ->+          flip ZonedTime (zonedTimeZone x) <$> weekDay.nextUnitWith n (zonedTimeToLocalTime x)+      }++instance HasWeekDay UniversalTime where+  weekDay =+    Unit+      { extract = weekDay.extract . ut1ToLocalTime 0,+        nextUnitWith = \n x ->+          localTimeToUT1 0 <$> weekDay.nextUnitWith n (ut1ToLocalTime 0 x)+      }++-- | Every type with month days (1-31)+--+-- > every 5 monthDay+class HasMonthDay a where+  -- | 0 == Monday+  monthDay :: Unit Int a++instance HasMonthDay Day where+  monthDay =+    Unit+      { extract = \(MonthDay _ d) -> d,+        nextUnitWith = \n x@(MonthDay m _) ->+          let td = if n > 31 then 1 + (n `mod` 32) else n+           in find (\x'@(MonthDay _ d') -> d' == td && x' > x) $ map (`MonthDay` td) [m ..]+      }++instance HasMonthDay LocalTime where+  monthDay =+    Unit+      { extract = monthDay.extract . localDay,+        nextUnitWith = \n x ->+          (`LocalTime` midnight) <$> monthDay.nextUnitWith n (localDay x)+      }++instance HasMonthDay UTCTime where+  monthDay =+    Unit+      { extract = monthDay.extract . utctDay,+        nextUnitWith = \n x ->+          (`UTCTime` 0) <$> monthDay.nextUnitWith n (utctDay x)+      }++instance HasMonthDay ZonedTime where+  monthDay =+    Unit+      { extract = monthDay.extract . zonedTimeToLocalTime,+        nextUnitWith = \n x ->+          flip ZonedTime (zonedTimeZone x) <$> monthDay.nextUnitWith n (zonedTimeToLocalTime x)+      }++instance HasMonthDay UniversalTime where+  monthDay =+    Unit+      { extract = monthDay.extract . ut1ToLocalTime 0,+        nextUnitWith = \n x ->+          localTimeToUT1 0 <$> monthDay.nextUnitWith n (ut1ToLocalTime 0 x)+      }++-- | Every type with months+--+-- > every 5 month+class HasMonth a where+  month :: Unit Int a++instance HasMonth Day where+  month =+    Unit+      { extract = \(MonthDay (YearMonth _ m) _) -> m,+        nextUnitWith = \n (MonthDay (YearMonth y m) _) ->+          let (ty, tm)+                | n > 12 && mm <= m = (y + 1, mm)+                | n > 12 = (y, mm)+                | n <= m = (y + 1, n)+                | otherwise = (y, n)+              mm = 1 + (n `mod` 13)+           in Just $ MonthDay (YearMonth ty tm) 1+      }++instance HasMonth LocalTime where+  month =+    Unit+      { extract = month.extract . localDay,+        nextUnitWith = \n x ->+          (`LocalTime` midnight) <$> month.nextUnitWith n (localDay x)+      }++instance HasMonth UTCTime where+  month =+    Unit+      { extract = month.extract . utctDay,+        nextUnitWith = \n x ->+          (`UTCTime` 0) <$> month.nextUnitWith n (utctDay x)+      }++instance HasMonth ZonedTime where+  month =+    Unit+      { extract = month.extract . zonedTimeToLocalTime,+        nextUnitWith = \n x ->+          flip ZonedTime (zonedTimeZone x) <$> month.nextUnitWith n (zonedTimeToLocalTime x)+      }++instance HasMonth UniversalTime where+  month =+    Unit+      { extract = month.extract . ut1ToLocalTime 0,+        nextUnitWith = \n x ->+          localTimeToUT1 0 <$> month.nextUnitWith n (ut1ToLocalTime 0 x)+      }++-- | Every type with years+--+-- > every 5 year+class HasYear a where+  year :: Unit Integer a++instance HasYear Day where+  year =+    Unit+      { extract = \(MonthDay (YearMonth y _) _) -> y,+        nextUnitWith = \n _ -> Just $ MonthDay (YearMonth n 1) 1+      }++instance HasYear LocalTime where+  year =+    Unit+      { extract = year.extract . localDay,+        nextUnitWith = \n x ->+          (`LocalTime` midnight) <$> year.nextUnitWith n (localDay x)+      }++instance HasYear UTCTime where+  year =+    Unit+      { extract = year.extract . utctDay,+        nextUnitWith = \n x ->+          (`UTCTime` 0) <$> year.nextUnitWith n (utctDay x)+      }++instance HasYear ZonedTime where+  year =+    Unit+      { extract = year.extract . zonedTimeToLocalTime,+        nextUnitWith = \n x ->+          flip ZonedTime (zonedTimeZone x) <$> year.nextUnitWith n (zonedTimeToLocalTime x)+      }++instance HasYear UniversalTime where+  year =+    Unit+      { extract = year.extract . ut1ToLocalTime 0,+        nextUnitWith = \n x ->+          localTimeToUT1 0 <$> year.nextUnitWith n (ut1ToLocalTime 0 x)+      }++-- * Helpers++-- | 'ZonedTime' with 'Eq' and `Ord` instances via 'UTCTime'+newtype ZonedTimeWrapped = ZonedTimeWrapped {unwrapZonedTime :: ZonedTime}+  deriving newtype (Show, Read, HasMinute, HasHour, HasWeekDay, HasMonthDay, HasMonth, HasYear, ISO8601)++instance Eq ZonedTimeWrapped where+  (==) = (==) `on` zonedTimeToUTC . unwrapZonedTime++instance Ord ZonedTimeWrapped where+  compare = compare `on` zonedTimeToUTC . unwrapZonedTime
+ src/Control/Antikythera/Unit/Unit.hs view
@@ -0,0 +1,29 @@+-- |+-- Module        : Control.Antikythera.Unit.Unit+-- Copyright     : Gautier DI FOLCO+-- License       : ISC+--+-- Maintainer    : Gautier DI FOLCO <gautier.difolco@gmail.com>+-- Stability     : Stable+-- Portability   : Portable+--+-- Standalone definition 'Unit', for 'Periodicy' definition+module Control.Antikythera.Unit.Unit (Unit (..)) where++-- | Type use to define 'Periodicy' patterns (e.g. 'every', 'at') for time types+--+-- For example:+--+-- > instance HasMinute TimeOfDay where+-- >   minute =+-- >     Unit+-- >       { extract = todMin+-- >       , nextUnitWith = \n x ->+-- >           let m = n `mod` 60+-- >           in Just $ TimeOfDay ((x.todHour + (if m <= x.todMin then 1 else 0)) `mod` 24) m 0+-- >       }+data Unit i a = Unit+  { extract :: a -> i,+    -- | should apply modulo+    nextUnitWith :: i -> a -> Maybe a+  }
+ test/Spec.hs view
@@ -0,0 +1,131 @@+module Main (main) where++import Control.Antikythera+import Data.Time+import Data.Time.Format.ISO8601 (ISO8601, iso8601ParseM, iso8601Show)+import GHC.Exts (IsList (fromList))+import GHC.IO (unsafePerformIO)+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec =+  describe "Antikythera" $ do+    let testFor :: (ISO8601 a) => Periodicity a -> String -> Maybe String+        testFor p x = iso8601Show <$> p.nextPeriod (time x)+        time :: (ISO8601 a) => String -> a+        time = unsafePerformIO . iso8601ParseM+    describe "nextPeriod" $ do+      describe "ZonedTime" $ do+        describe "every 5 minutes" $ do+          let t = testFor @ZonedTime $ every 5 minute+          it "non overflowing" $+            t "2025-03-15T18:50:50+01:00" `shouldBe` Just "2025-03-15T18:55:00+01:00"+          it "overflowing hour" $+            t "2025-03-15T18:56:50+01:00" `shouldBe` Just "2025-03-15T19:00:00+01:00"+          it "overflowing day" $+            t "2025-03-15T23:56:50+01:00" `shouldBe` Just "2025-03-16T00:00:00+01:00"+          it "overflowing month" $+            t "2025-03-31T23:56:50+01:00" `shouldBe` Just "2025-04-01T00:00:00+01:00"+          it "overflowing year" $+            t "2025-12-31T23:56:50+01:00" `shouldBe` Just "2026-01-01T00:00:00+01:00"+        describe "at 5 minutes" $ do+          let t = testFor @ZonedTime $ at 5 minute+          it "non overflowing" $+            t "2025-03-15T18:01:50+01:00" `shouldBe` Just "2025-03-15T18:05:00+01:00"+          it "overflowing hour" $+            t "2025-03-15T18:56:50+01:00" `shouldBe` Just "2025-03-15T19:05:00+01:00"+          it "overflowing day" $+            t "2025-03-15T23:56:50+01:00" `shouldBe` Just "2025-03-16T00:05:00+01:00"+          it "overflowing month" $+            t "2025-03-31T23:56:50+01:00" `shouldBe` Just "2025-04-01T00:05:00+01:00"+          it "overflowing year" $+            t "2025-12-31T23:56:50+01:00" `shouldBe` Just "2026-01-01T00:05:00+01:00"+        describe "ats 5,35 minutes" $ do+          let t = testFor @ZonedTime $ ats (fromList [5, 35]) minute+          it "non overflowing (5)" $+            t "2025-03-15T18:01:50+01:00" `shouldBe` Just "2025-03-15T18:05:00+01:00"+          it "non overflowing (35)" $+            t "2025-03-15T18:11:50+01:00" `shouldBe` Just "2025-03-15T18:35:00+01:00"+          it "overflowing hour" $+            t "2025-03-15T18:56:50+01:00" `shouldBe` Just "2025-03-15T19:05:00+01:00"+          it "overflowing day" $+            t "2025-03-15T23:56:50+01:00" `shouldBe` Just "2025-03-16T00:05:00+01:00"+          it "overflowing month" $+            t "2025-03-31T23:56:50+01:00" `shouldBe` Just "2025-04-01T00:05:00+01:00"+          it "overflowing year" $+            t "2025-12-31T23:56:50+01:00" `shouldBe` Just "2026-01-01T00:05:00+01:00"+        describe "at 5 hour" $ do+          let t = testFor @ZonedTime $ at 5 hour+          it "non overflowing" $+            t "2025-03-15T02:01:50+01:00" `shouldBe` Just "2025-03-15T05:00:00+01:00"+          it "overflowing day" $+            t "2025-03-15T23:56:50+01:00" `shouldBe` Just "2025-03-16T05:00:00+01:00"+          it "overflowing month" $+            t "2025-03-31T23:56:50+01:00" `shouldBe` Just "2025-04-01T05:00:00+01:00"+          it "overflowing year" $+            t "2025-12-31T23:56:50+01:00" `shouldBe` Just "2026-01-01T05:00:00+01:00"+        describe "at Sunday (weekday)" $ do+          let t = testFor @ZonedTime $ at Sunday weekDay+          it "non overflowing" $+            t "2025-03-15T02:01:50+01:00" `shouldBe` Just "2025-03-16T00:00:00+01:00"+          it "overflowing week" $+            t "2025-03-17T23:56:50+01:00" `shouldBe` Just "2025-03-23T00:00:00+01:00"+          it "overflowing month" $+            t "2025-03-31T23:56:50+01:00" `shouldBe` Just "2025-04-06T00:00:00+01:00"+          it "overflowing year" $+            t "2025-12-31T23:56:50+01:00" `shouldBe` Just "2026-01-04T00:00:00+01:00"+        describe "at 5 month" $ do+          let t = testFor @ZonedTime $ at 5 month+          it "non overflowing" $+            t "2025-03-15T02:01:50+01:00" `shouldBe` Just "2025-05-01T00:00:00+01:00"+          it "overflowing year" $+            t "2025-12-31T23:56:50+01:00" `shouldBe` Just "2026-05-01T00:00:00+01:00"+        describe "at 2026 year" $ do+          let t = testFor @ZonedTime $ at 2026 year+          it "non overflowing" $+            t "2025-03-15T02:01:50+01:00" `shouldBe` Just "2026-01-01T00:00:00+01:00"+        describe "at 5 hour .|| at 5 minute" $ do+          let t = testFor @ZonedTimeWrapped (at 5 hour .|| at 5 minute)+          it "non overflowing (minute)" $+            t "2025-03-15T02:01:50+01:00" `shouldBe` Just "2025-03-15T02:05:00+01:00"+          it "non overflowing (hour)" $+            t "2025-03-15T04:06:50+01:00" `shouldBe` Just "2025-03-15T05:00:00+01:00"+          it "overflowing day" $+            t "2025-03-15T23:56:50+01:00" `shouldBe` Just "2025-03-16T00:05:00+01:00"+        describe "at 5 hour .&& at 5 minute" $ do+          let t = testFor @ZonedTimeWrapped (at 5 hour .&& at 5 minute)+          it "non overflowing" $+            t "2025-03-15T02:01:50+01:00" `shouldBe` Just "2025-03-15T05:05:00+01:00"+          it "overflowing day" $+            t "2025-03-15T23:56:50+01:00" `shouldBe` Just "2025-03-16T05:05:00+01:00"+      describe "ZonedTime" $ do+        describe "at 5 hour .&& sinceInclusive" $ do+          let t = testFor @UTCTime (at 5 hour .&& sinceInclusive (addUTCTime nominalDay) (time "2025-03-15T04:05:00Z"))+          it "non overflowing" $+            t "2025-03-15T02:01:50Z" `shouldBe` Just "2025-03-15T05:00:00Z"+          it "overflowing day (at)" $+            t "2025-03-15T23:56:50Z" `shouldBe` Just "2025-03-16T05:00:00Z"+          it "overflowing day (sinceInclusive)" $+            t "2025-03-14T23:56:50Z" `shouldBe` Just "2025-03-15T05:00:00Z"+        describe "at 5 hour .&& untilInclusive" $ do+          let t = testFor @UTCTime (at 5 hour .&& untilInclusive (addUTCTime nominalDay) (time "2025-03-17T04:05:00Z"))+          it "non overflowing" $+            t "2025-03-15T02:01:50Z" `shouldBe` Just "2025-03-15T05:00:00Z"+          it "overflowing day (at)" $+            t "2025-03-15T23:56:50Z" `shouldBe` Just "2025-03-16T05:00:00Z"+          it "overflowing day (untilInclusive)" $+            t "2025-03-16T23:56:50Z" `shouldBe` Nothing+    describe "Utils" $ do+      describe "nextPeriods" $ do+        describe "at 5 hour .&& untilInclusive" $ do+          it "before the deadline" $ do+            let p = at 5 hour .&& untilInclusive (addUTCTime nominalDay) (time "2025-03-17T04:05:00Z")+            (iso8601Show <$> nextPeriods p (time "2025-03-15T02:01:50Z"))+              `shouldBe` ["2025-03-15T05:00:00Z", "2025-03-16T05:00:00Z"]+          it "after the deadline" $ do+            let p = at 5 hour .&& untilInclusive (addUTCTime nominalDay) (time "2025-03-17T04:05:00Z")+            (iso8601Show <$> nextPeriods p (time "2025-03-18T02:01:50Z"))+              `shouldBe` []