diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/antikythera.cabal b/antikythera.cabal new file mode 100644 --- /dev/null +++ b/antikythera.cabal @@ -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 diff --git a/src/Control/Antikythera.hs b/src/Control/Antikythera.hs new file mode 100644 --- /dev/null +++ b/src/Control/Antikythera.hs @@ -0,0 +1,20 @@ +-- | +-- Module : Control.Antikythera +-- Copyright : Gautier DI FOLCO +-- License : ISC +-- +-- Maintainer : Gautier DI FOLCO +-- 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 diff --git a/src/Control/Antikythera/Periodicity.hs b/src/Control/Antikythera/Periodicity.hs new file mode 100644 --- /dev/null +++ b/src/Control/Antikythera/Periodicity.hs @@ -0,0 +1,276 @@ +-- | +-- Module : Control.Antikythera.Periodicity +-- Copyright : Gautier DI FOLCO +-- License : ISC +-- +-- Maintainer : Gautier DI FOLCO +-- 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 + } diff --git a/src/Control/Antikythera/Scheduling.hs b/src/Control/Antikythera/Scheduling.hs new file mode 100644 --- /dev/null +++ b/src/Control/Antikythera/Scheduling.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE NumericUnderscores #-} + +-- | +-- Module : Control.Antikythera +-- Copyright : Gautier DI FOLCO +-- License : ISC +-- +-- Maintainer : Gautier DI FOLCO +-- 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)) + } diff --git a/src/Control/Antikythera/Unit.hs b/src/Control/Antikythera/Unit.hs new file mode 100644 --- /dev/null +++ b/src/Control/Antikythera/Unit.hs @@ -0,0 +1,14 @@ +-- | +-- Module : Control.Antikythera.Unit +-- Copyright : Gautier DI FOLCO +-- License : ISC +-- +-- Maintainer : Gautier DI FOLCO +-- 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 diff --git a/src/Control/Antikythera/Unit/Time.hs b/src/Control/Antikythera/Unit/Time.hs new file mode 100644 --- /dev/null +++ b/src/Control/Antikythera/Unit/Time.hs @@ -0,0 +1,342 @@ +-- | +-- Module : Control.Antikythera.Unit.Time +-- Copyright : Gautier DI FOLCO +-- License : ISC +-- +-- Maintainer : Gautier DI FOLCO +-- 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 diff --git a/src/Control/Antikythera/Unit/Unit.hs b/src/Control/Antikythera/Unit/Unit.hs new file mode 100644 --- /dev/null +++ b/src/Control/Antikythera/Unit/Unit.hs @@ -0,0 +1,29 @@ +-- | +-- Module : Control.Antikythera.Unit.Unit +-- Copyright : Gautier DI FOLCO +-- License : ISC +-- +-- Maintainer : Gautier DI FOLCO +-- 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 + } diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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` []