diff --git a/saturn.cabal b/saturn.cabal --- a/saturn.cabal +++ b/saturn.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: saturn -version: 1.0.0.9 +version: 1.1.0.0 synopsis: Handle POSIX cron schedules. description: Saturn handles POSIX cron schedules. build-type: Simple @@ -22,7 +22,7 @@ manual: True common library - build-depends: base ^>=4.19.0.0 || ^>=4.20.0.0 || ^>=4.21.0.0 + build-depends: base ^>=4.19 || ^>=4.20 || ^>=4.21 default-language: Haskell2010 ghc-options: -Weverything @@ -40,89 +40,71 @@ if flag(pedantic) ghc-options: -Werror -library unstable +library import: library build-depends: + QuickCheck ^>=2.14.3 || ^>=2.15 || ^>=2.16, containers ^>=0.6.7 || ^>=0.7, + heck ^>=0.2025.5.22, + hspec ^>=2.11.8, parsec ^>=3.1.16.1, text ^>=2.0.2 || ^>=2.1, time ^>=1.12.2 || ^>=1.14, - -- cabal-gild: discover source/libraries/unstable + -- cabal-gild: discover source/library exposed-modules: + Saturn Saturn.Unstable.Constant - Saturn.Unstable.Extra.Int - Saturn.Unstable.Extra.Ord - Saturn.Unstable.Extra.Parsec - Saturn.Unstable.Extra.Time - Saturn.Unstable.Extra.Tuple - Saturn.Unstable.Match - Saturn.Unstable.Parse - Saturn.Unstable.Render - Saturn.Unstable.Type.Day - Saturn.Unstable.Type.Element - Saturn.Unstable.Type.Field - Saturn.Unstable.Type.Hour - Saturn.Unstable.Type.Minute - Saturn.Unstable.Type.Month - Saturn.Unstable.Type.Number - Saturn.Unstable.Type.Range - Saturn.Unstable.Type.Schedule - Saturn.Unstable.Type.Weekday - Saturn.Unstable.Type.Wildcard - - hs-source-dirs: source/libraries/unstable - visibility: public - -library - import: library - build-depends: saturn:unstable - -- cabal-gild: discover source/libraries/saturn - exposed-modules: Saturn - hs-source-dirs: source/libraries/saturn - -library spec - import: library - build-depends: - QuickCheck ^>=2.14.3 || ^>=2.15 || ^>=2.16, - hspec ^>=2.11.8, - parsec, - saturn:unstable, - text, - time, - - -- cabal-gild: discover source/libraries/spec - exposed-modules: Saturn.Unstable.ConstantSpec + Saturn.Unstable.Extra.Int Saturn.Unstable.Extra.IntSpec + Saturn.Unstable.Extra.Ord Saturn.Unstable.Extra.OrdSpec + Saturn.Unstable.Extra.Parsec Saturn.Unstable.Extra.ParsecSpec + Saturn.Unstable.Extra.Time Saturn.Unstable.Extra.TimeSpec + Saturn.Unstable.Extra.Tuple Saturn.Unstable.Extra.TupleSpec + Saturn.Unstable.Match Saturn.Unstable.MatchSpec + Saturn.Unstable.Parse Saturn.Unstable.ParseSpec + Saturn.Unstable.Render Saturn.Unstable.RenderSpec + Saturn.Unstable.Type.Day Saturn.Unstable.Type.DaySpec + Saturn.Unstable.Type.Element Saturn.Unstable.Type.ElementSpec + Saturn.Unstable.Type.Field Saturn.Unstable.Type.FieldSpec + Saturn.Unstable.Type.Hour Saturn.Unstable.Type.HourSpec + Saturn.Unstable.Type.Minute Saturn.Unstable.Type.MinuteSpec + Saturn.Unstable.Type.Month Saturn.Unstable.Type.MonthSpec + Saturn.Unstable.Type.Number Saturn.Unstable.Type.NumberSpec + Saturn.Unstable.Type.Range Saturn.Unstable.Type.RangeSpec + Saturn.Unstable.Type.Schedule Saturn.Unstable.Type.ScheduleSpec + Saturn.Unstable.Type.Weekday Saturn.Unstable.Type.WeekdaySpec + Saturn.Unstable.Type.Wildcard Saturn.Unstable.Type.WildcardSpec SaturnSpec - hs-source-dirs: source/libraries/spec - visibility: public + hs-source-dirs: source/library test-suite saturn-test-suite import: library build-depends: + heck, hspec, - saturn:spec, + hspec-core, + saturn, ghc-options: -rtsopts diff --git a/source/libraries/saturn/Saturn.hs b/source/libraries/saturn/Saturn.hs deleted file mode 100644 --- a/source/libraries/saturn/Saturn.hs +++ /dev/null @@ -1,71 +0,0 @@ --- | Saturn handles POSIX cron schedules, which are defined here: --- . --- --- A cron schedule is specified with five fields, each separated with at least --- one space. Each field can either be a wildcard (represented by an asterisk), --- or it can be one or more elements separated by commas. Each element can --- either be a number or a range, which is two numbers separated by a hyphen. --- --- In order, the fields represent: --- --- 1. Minute, between 0 and 59. --- 2. Hour, between 0 and 23. --- 3. Day, between 1 and 31. --- 4. Month, between 1 and 12. --- 5. Weekday, between 0 and 6 where 0 represents Sunday. --- --- Here is a more graphical representation of the fields: --- --- > +--------- Minute --- > | +------- Hour --- > | | +----- Day --- > | | | +--- Month --- > | | | | +- Weekday --- > | | | | | --- > "* * * * *" --- --- To get started, use 'Parse.fromText' to parse a 'Schedule.Schedule'. Then --- use 'Render.toText' to render it again. To see if the 'Schedule.Schedule' --- matches a certain time, use 'Match.isMatch'. To get the next time that --- matches a schedule, use 'Match.nextMatch'. --- --- >>> :set -XOverloadedStrings --- >>> let Right schedule = fromText "* * * * *" --- >>> toText schedule --- "* * * * *" --- >>> let utcTime = Data.Time.UTCTime (Data.Time.fromGregorian 1970 1 1) 0 --- >>> isMatch utcTime schedule --- True --- >>> nextMatch utcTime schedule --- Just 1970-01-01 00:01:00 UTC -module Saturn - ( -- * Types - Schedule.Schedule, - Constant.everyMinute, - Constant.hourly, - Constant.daily, - Constant.weekly, - Constant.monthly, - Constant.yearly, - - -- * Parsing - Parse.fromText, - Parse.fromLazyText, - Parse.fromString, - - -- * Rendering - Render.toText, - Render.toLazyText, - Render.toString, - - -- * Matching - Match.isMatch, - Match.nextMatch, - ) -where - -import qualified Saturn.Unstable.Constant as Constant -import qualified Saturn.Unstable.Match as Match -import qualified Saturn.Unstable.Parse as Parse -import qualified Saturn.Unstable.Render as Render -import qualified Saturn.Unstable.Type.Schedule as Schedule diff --git a/source/libraries/spec/Saturn/Unstable/ConstantSpec.hs b/source/libraries/spec/Saturn/Unstable/ConstantSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/ConstantSpec.hs +++ /dev/null @@ -1,31 +0,0 @@ -module Saturn.Unstable.ConstantSpec where - -import qualified Saturn.Unstable.Constant as Constant -import qualified Saturn.Unstable.Render as Render -import qualified Test.Hspec as Hspec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Constant" $ do - Hspec.describe "everyMinute" $ do - Hspec.it "renders correctly" $ do - Render.toString Constant.everyMinute `Hspec.shouldBe` "* * * * *" - - Hspec.describe "hourly" $ do - Hspec.it "renders correctly" $ do - Render.toString Constant.hourly `Hspec.shouldBe` "0 * * * *" - - Hspec.describe "daily" $ do - Hspec.it "renders correctly" $ do - Render.toString Constant.daily `Hspec.shouldBe` "0 0 * * *" - - Hspec.describe "weekly" $ do - Hspec.it "renders correctly" $ do - Render.toString Constant.weekly `Hspec.shouldBe` "0 0 * * 0" - - Hspec.describe "monthly" $ do - Hspec.it "renders correctly" $ do - Render.toString Constant.monthly `Hspec.shouldBe` "0 0 1 * *" - - Hspec.describe "yearly" $ do - Hspec.it "renders correctly" $ do - Render.toString Constant.yearly `Hspec.shouldBe` "0 0 1 1 *" diff --git a/source/libraries/spec/Saturn/Unstable/Extra/IntSpec.hs b/source/libraries/spec/Saturn/Unstable/Extra/IntSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Extra/IntSpec.hs +++ /dev/null @@ -1,23 +0,0 @@ -module Saturn.Unstable.Extra.IntSpec where - -import qualified Saturn.Unstable.Extra.Int as Int -import qualified Test.Hspec as Hspec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Extra.Int" $ do - Hspec.describe "fromWord8" $ do - Hspec.it "works" $ do - Int.fromWord8 0 `Hspec.shouldBe` 0 - - Hspec.describe "toWord8" $ do - Hspec.it "succeeds with minimum" $ do - Int.toWord8 0 `Hspec.shouldBe` Just 0 - - Hspec.it "succeeds with maximum" $ do - Int.toWord8 255 `Hspec.shouldBe` Just 255 - - Hspec.it "fails below minimum" $ do - Int.toWord8 (-1) `Hspec.shouldBe` Nothing - - Hspec.it "fails above maximum" $ do - Int.toWord8 256 `Hspec.shouldBe` Nothing diff --git a/source/libraries/spec/Saturn/Unstable/Extra/OrdSpec.hs b/source/libraries/spec/Saturn/Unstable/Extra/OrdSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Extra/OrdSpec.hs +++ /dev/null @@ -1,22 +0,0 @@ -module Saturn.Unstable.Extra.OrdSpec where - -import qualified Saturn.Unstable.Extra.Ord as Ord -import qualified Test.Hspec as Hspec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Extra.Ord" $ do - Hspec.describe "within" $ do - Hspec.it "fails below lower bound" $ do - 'a' `Hspec.shouldNotSatisfy` Ord.within ('b', 'd') - - Hspec.it "succeeds at lower bound" $ do - 'b' `Hspec.shouldSatisfy` Ord.within ('b', 'd') - - Hspec.it "succeeds within bounds" $ do - 'c' `Hspec.shouldSatisfy` Ord.within ('b', 'd') - - Hspec.it "succeeds at upper bound" $ do - 'd' `Hspec.shouldSatisfy` Ord.within ('b', 'd') - - Hspec.it "fails above upper bound" $ do - 'e' `Hspec.shouldNotSatisfy` Ord.within ('b', 'd') diff --git a/source/libraries/spec/Saturn/Unstable/Extra/ParsecSpec.hs b/source/libraries/spec/Saturn/Unstable/Extra/ParsecSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Extra/ParsecSpec.hs +++ /dev/null @@ -1,37 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Extra.ParsecSpec where - -import qualified Data.Either as Either -import qualified Data.List.NonEmpty as NonEmpty -import qualified Saturn.Unstable.Extra.Parsec as Parsec -import qualified Test.Hspec as Hspec -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Extra.Parsec" $ do - Hspec.describe "either" $ do - let parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m (Either Char Char) - parsec = Parsec.either (Parsec.char 'a') (Parsec.char 'b') - - Hspec.it "succeeds with left" $ do - Parsec.parse parsec "" "a" `Hspec.shouldBe` Right (Left 'a') - - Hspec.it "succeeds with right" $ do - Parsec.parse parsec "" "b" `Hspec.shouldBe` Right (Right 'b') - - Hspec.it "fails with neither" $ do - Parsec.parse parsec "" "c" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.describe "sepByNE" $ do - let parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m (NonEmpty.NonEmpty Char) - parsec = Parsec.sepByNE (Parsec.char 'a') (Parsec.char ' ') - - Hspec.it "succeeds with one" $ do - Parsec.parse parsec "" "a" `Hspec.shouldBe` Right ('a' NonEmpty.:| []) - - Hspec.it "succeeds with many" $ do - Parsec.parse parsec "" "a a" `Hspec.shouldBe` Right ('a' NonEmpty.:| "a") - - Hspec.it "fails with none" $ do - Parsec.parse parsec "" "" `Hspec.shouldSatisfy` Either.isLeft diff --git a/source/libraries/spec/Saturn/Unstable/Extra/TimeSpec.hs b/source/libraries/spec/Saturn/Unstable/Extra/TimeSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Extra/TimeSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Saturn.Unstable.Extra.TimeSpec where - -import qualified Data.Time as Time -import qualified Saturn.Unstable.Extra.Time as Time -import qualified Test.Hspec as Hspec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Extra.Time" $ do - Hspec.describe "dayOfWeekToWord8" $ do - Hspec.it "works with Sunday" $ do - Time.dayOfWeekToWord8 Time.Sunday `Hspec.shouldBe` 0 - - Hspec.it "works with Monday" $ do - Time.dayOfWeekToWord8 Time.Monday `Hspec.shouldBe` 1 - - Hspec.it "works with Tuesday" $ do - Time.dayOfWeekToWord8 Time.Tuesday `Hspec.shouldBe` 2 - - Hspec.it "works with Wednesday" $ do - Time.dayOfWeekToWord8 Time.Wednesday `Hspec.shouldBe` 3 - - Hspec.it "works with Thursday" $ do - Time.dayOfWeekToWord8 Time.Thursday `Hspec.shouldBe` 4 - - Hspec.it "works with Friday" $ do - Time.dayOfWeekToWord8 Time.Friday `Hspec.shouldBe` 5 - - Hspec.it "works with Saturday" $ do - Time.dayOfWeekToWord8 Time.Saturday `Hspec.shouldBe` 6 diff --git a/source/libraries/spec/Saturn/Unstable/Extra/TupleSpec.hs b/source/libraries/spec/Saturn/Unstable/Extra/TupleSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Extra/TupleSpec.hs +++ /dev/null @@ -1,20 +0,0 @@ -module Saturn.Unstable.Extra.TupleSpec where - -import qualified Saturn.Unstable.Extra.Tuple as Tuple -import qualified Test.Hspec as Hspec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Extra.Tuple" $ do - Hspec.describe "mapBoth" $ do - Hspec.it "works" $ do - Tuple.mapBoth succ ('A', 'a') `Hspec.shouldBe` ('B', 'b') - - Hspec.describe "toSequence" $ do - Hspec.it "works" $ do - Tuple.toSequence ('b', 'd') `Hspec.shouldBe` "bcd" - - Hspec.it "works with singleton" $ do - Tuple.toSequence ('a', 'a') `Hspec.shouldBe` "a" - - Hspec.it "works with empty" $ do - Tuple.toSequence ('b', 'a') `Hspec.shouldBe` "" diff --git a/source/libraries/spec/Saturn/Unstable/MatchSpec.hs b/source/libraries/spec/Saturn/Unstable/MatchSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/MatchSpec.hs +++ /dev/null @@ -1,484 +0,0 @@ -module Saturn.Unstable.MatchSpec where - -import qualified Data.Fixed as Fixed -import qualified Data.Time as Time -import qualified Data.Time.Calendar.WeekDate as Time -import qualified Saturn.Unstable.Match as Match -import qualified Saturn.Unstable.Type.ScheduleSpec as ScheduleSpec -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Match" $ do - Hspec.describe "isMatch" $ do - Hspec.it "is always true with all wildcards" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch utcTime - - Hspec.it "is true when day or weekday matches" $ do - s <- ScheduleSpec.new [] [] [[5]] [] [[5]] - t1 <- newUtcTime 1970 1 5 0 0 0 - s `Hspec.shouldSatisfy` Match.isMatch t1 - t2 <- newUtcTime 1970 1 2 0 0 0 - s `Hspec.shouldSatisfy` Match.isMatch t2 - - Hspec.describe "minute" $ do - Hspec.it "is always true when a number matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [[5]] [] [] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withMinute 5 utcTime) - - Hspec.it "is always true when a range matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [[4, 5]] [] [] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withMinute 5 utcTime) - - Hspec.it "is always true when a choice matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [[4], [5]] [] [] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withMinute 5 utcTime) - - Hspec.it "is true when a number matches" $ do - t <- newUtcTime 1970 1 1 0 5 0 - s <- ScheduleSpec.new [[5]] [] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a number does not match" $ do - t <- newUtcTime 1970 1 1 0 6 0 - s <- ScheduleSpec.new [[5]] [] [] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a range matches" $ do - t <- newUtcTime 1970 1 1 0 5 0 - s <- ScheduleSpec.new [[4, 5]] [] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a range does not match" $ do - t <- newUtcTime 1970 1 1 0 6 0 - s <- ScheduleSpec.new [[4, 5]] [] [] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a choice matches" $ do - t <- newUtcTime 1970 1 1 0 5 0 - s <- ScheduleSpec.new [[4], [5]] [] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a choice does not match" $ do - t <- newUtcTime 1970 1 1 0 6 0 - s <- ScheduleSpec.new [[4], [5]] [] [] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "accepts any second" $ do - t <- newUtcTime 1970 1 1 0 5 6 - s <- ScheduleSpec.new [[5]] [] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any hour" $ do - t <- newUtcTime 1970 1 1 6 5 0 - s <- ScheduleSpec.new [[5]] [] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any day" $ do - t <- newUtcTime 1970 1 6 0 5 0 - s <- ScheduleSpec.new [[5]] [] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any month" $ do - t <- newUtcTime 1970 6 1 0 5 0 - s <- ScheduleSpec.new [[5]] [] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.describe "hour" $ do - Hspec.it "is always true when a number matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [[5]] [] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withHour 5 utcTime) - - Hspec.it "is always true when a range matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [[4, 5]] [] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withHour 5 utcTime) - - Hspec.it "is always true when a choice matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [[4], [5]] [] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withHour 5 utcTime) - - Hspec.it "is true when a number matches" $ do - t <- newUtcTime 1970 1 1 5 0 0 - s <- ScheduleSpec.new [] [[5]] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a number does not match" $ do - t <- newUtcTime 1970 1 1 6 0 0 - s <- ScheduleSpec.new [] [[5]] [] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a range matches" $ do - t <- newUtcTime 1970 1 1 5 0 0 - s <- ScheduleSpec.new [] [[4, 5]] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a range does not match" $ do - t <- newUtcTime 1970 1 1 6 0 0 - s <- ScheduleSpec.new [] [[4, 5]] [] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a choice matches" $ do - t <- newUtcTime 1970 1 1 5 0 0 - s <- ScheduleSpec.new [] [[4], [5]] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a choice does not match" $ do - t <- newUtcTime 1970 1 1 6 0 0 - s <- ScheduleSpec.new [] [[4], [5]] [] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "accepts any second" $ do - t <- newUtcTime 1970 1 1 5 0 6 - s <- ScheduleSpec.new [] [[5]] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any minute" $ do - t <- newUtcTime 1970 1 1 5 6 0 - s <- ScheduleSpec.new [] [[5]] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any day" $ do - t <- newUtcTime 1970 1 6 5 0 0 - s <- ScheduleSpec.new [] [[5]] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any month" $ do - t <- newUtcTime 1970 6 1 5 0 0 - s <- ScheduleSpec.new [] [[5]] [] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.describe "day" $ do - Hspec.it "is always true when a number matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [[5]] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfMonth 5 utcTime) - - Hspec.it "is always true when a range matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [[4, 5]] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfMonth 5 utcTime) - - Hspec.it "is always true when a choice matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [[4], [5]] [] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfMonth 5 utcTime) - - Hspec.it "is true when a number matches" $ do - t <- newUtcTime 1970 1 5 0 0 0 - s <- ScheduleSpec.new [] [] [[5]] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a number does not match" $ do - t <- newUtcTime 1970 1 6 0 0 0 - s <- ScheduleSpec.new [] [] [[5]] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a range matches" $ do - t <- newUtcTime 1970 1 5 0 0 0 - s <- ScheduleSpec.new [] [] [[4, 5]] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a range does not match" $ do - t <- newUtcTime 1970 1 6 0 0 0 - s <- ScheduleSpec.new [] [] [[4, 5]] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a choice matches" $ do - t <- newUtcTime 1970 1 5 0 0 0 - s <- ScheduleSpec.new [] [] [[4], [5]] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a choice does not match" $ do - t <- newUtcTime 1970 1 6 0 0 0 - s <- ScheduleSpec.new [] [] [[4], [5]] [] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "accepts any second" $ do - t <- newUtcTime 1970 1 5 0 0 6 - s <- ScheduleSpec.new [] [] [[5]] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any minute" $ do - t <- newUtcTime 1970 1 5 0 6 0 - s <- ScheduleSpec.new [] [] [[5]] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any hour" $ do - t <- newUtcTime 1970 1 5 6 0 0 - s <- ScheduleSpec.new [] [] [[5]] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any month" $ do - t <- newUtcTime 1970 6 5 0 0 0 - s <- ScheduleSpec.new [] [] [[5]] [] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.describe "month" $ do - Hspec.it "is always true when a number matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [] [[5]] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withMonthOfYear 5 utcTime) - - Hspec.it "is always true when a range matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [] [[4, 5]] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withMonthOfYear 5 utcTime) - - Hspec.it "is always true when a choice matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [] [[4], [5]] [] - schedule `Hspec.shouldSatisfy` Match.isMatch (withMonthOfYear 5 utcTime) - - Hspec.it "is true when a number matches" $ do - t <- newUtcTime 1970 5 1 0 0 0 - s <- ScheduleSpec.new [] [] [] [[5]] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a number does not match" $ do - t <- newUtcTime 1970 6 1 0 0 0 - s <- ScheduleSpec.new [] [] [] [[5]] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a range matches" $ do - t <- newUtcTime 1970 5 1 0 0 0 - s <- ScheduleSpec.new [] [] [] [[4, 5]] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a range does not match" $ do - t <- newUtcTime 1970 6 1 0 0 0 - s <- ScheduleSpec.new [] [] [] [[4, 5]] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a choice matches" $ do - t <- newUtcTime 1970 5 1 0 0 0 - s <- ScheduleSpec.new [] [] [] [[4], [5]] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a choice does not match" $ do - t <- newUtcTime 1970 6 1 0 0 0 - s <- ScheduleSpec.new [] [] [] [[4], [5]] [] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "accepts any second" $ do - t <- newUtcTime 1970 5 1 0 0 6 - s <- ScheduleSpec.new [] [] [] [[5]] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any minute" $ do - t <- newUtcTime 1970 5 1 0 6 0 - s <- ScheduleSpec.new [] [] [] [[5]] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any hour" $ do - t <- newUtcTime 1970 5 1 6 0 0 - s <- ScheduleSpec.new [] [] [] [[5]] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any day" $ do - t <- newUtcTime 1970 5 6 0 0 0 - s <- ScheduleSpec.new [] [] [] [[5]] [] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.describe "weekday" $ do - Hspec.it "is always true when a number matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [] [] [[5]] - schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfWeek Time.Friday utcTime) - - Hspec.it "is always true when a range matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [] [] [[4, 5]] - schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfWeek Time.Friday utcTime) - - Hspec.it "is always true when a choice matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \utcTime -> do - schedule <- ScheduleSpec.new [] [] [] [] [[4], [5]] - schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfWeek Time.Friday utcTime) - - Hspec.it "is true when a number matches" $ do - t <- newUtcTime 1970 1 2 0 0 0 - s <- ScheduleSpec.new [] [] [] [] [[5]] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a number does not match" $ do - t <- newUtcTime 1970 1 3 0 0 0 - s <- ScheduleSpec.new [] [] [] [] [[5]] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a range matches" $ do - t <- newUtcTime 1970 1 2 0 0 0 - s <- ScheduleSpec.new [] [] [] [] [[4, 5]] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a range does not match" $ do - t <- newUtcTime 1970 1 3 0 0 0 - s <- ScheduleSpec.new [] [] [] [] [[4, 5]] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "is true when a choice matches" $ do - t <- newUtcTime 1970 1 2 0 0 0 - s <- ScheduleSpec.new [] [] [] [] [[4], [5]] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "is false when a choice does not match" $ do - t <- newUtcTime 1970 1 3 0 0 0 - s <- ScheduleSpec.new [] [] [] [] [[4], [5]] - s `Hspec.shouldNotSatisfy` Match.isMatch t - - Hspec.it "accepts any second" $ do - t <- newUtcTime 1970 1 2 0 0 6 - s <- ScheduleSpec.new [] [] [] [] [[5]] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any minute" $ do - t <- newUtcTime 1970 1 2 0 6 0 - s <- ScheduleSpec.new [] [] [] [] [[5]] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any hour" $ do - t <- newUtcTime 1970 1 2 6 0 0 - s <- ScheduleSpec.new [] [] [] [] [[5]] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.it "accepts any day" $ do - t <- newUtcTime 1970 1 9 0 0 0 - s <- ScheduleSpec.new [] [] [] [] [[5]] - s `Hspec.shouldSatisfy` Match.isMatch t - - Hspec.describe "nextMatch" $ do - Hspec.it "succeeds with a leap day" $ do - s <- ScheduleSpec.new [[0]] [[0]] [[29]] [[2]] [] - t1 <- newUtcTime 1970 1 1 0 0 0 - t2 <- newUtcTime 1972 2 29 0 0 0 - Match.nextMatch t1 s `Hspec.shouldBe` Just t2 - - Hspec.it "succeeds with the next leap day" $ do - s <- ScheduleSpec.new [[0]] [[0]] [[29]] [[2]] [] - t1 <- newUtcTime 1972 2 29 0 0 0 - t2 <- newUtcTime 1976 2 29 0 0 0 - Match.nextMatch t1 s `Hspec.shouldBe` Just t2 - - Hspec.it "succeeds with the furthest leap day" $ do - s <- ScheduleSpec.new [[0]] [[0]] [[29]] [[2]] [] - t1 <- newUtcTime 1896 2 29 0 0 0 - t2 <- newUtcTime 1904 2 29 0 0 0 - Match.nextMatch t1 s `Hspec.shouldBe` Just t2 - - Hspec.it "fails with an impossible date" $ do - s <- ScheduleSpec.new [[0]] [[0]] [[30]] [[2]] [] - t <- newUtcTime 1970 1 1 0 0 0 - Match.nextMatch t s `Hspec.shouldBe` Nothing - - Hspec.it "is always in the future" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \t1 -> do - schedule <- ScheduleSpec.new [] [] [] [] [] - t2 <- maybe (fail "impossible") pure $ Match.nextMatch t1 schedule - t2 `Hspec.shouldSatisfy` (>= t1) - - Hspec.it "always matches" - . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime - $ \t1 -> do - schedule <- ScheduleSpec.new [] [] [] [] [] - t2 <- maybe (fail "impossible") pure $ Match.nextMatch t1 schedule - schedule `Hspec.shouldSatisfy` Match.isMatch t2 - -withMinute :: Int -> Time.UTCTime -> Time.UTCTime -withMinute minute = overTimeOfDay $ \timeOfDay -> timeOfDay {Time.todMin = minute} - -withHour :: Int -> Time.UTCTime -> Time.UTCTime -withHour hour = overTimeOfDay $ \timeOfDay -> timeOfDay {Time.todHour = hour} - -overTimeOfDay :: (Time.TimeOfDay -> Time.TimeOfDay) -> Time.UTCTime -> Time.UTCTime -overTimeOfDay f utcTime = - utcTime - { Time.utctDayTime = - Time.sinceMidnight . f . Time.pastMidnight $ Time.utctDayTime utcTime - } - -withDayOfMonth :: Time.DayOfMonth -> Time.UTCTime -> Time.UTCTime -withDayOfMonth dayOfMonth = overDay $ \day -> - let (year, monthOfYear, _) = Time.toGregorian day - in Time.fromGregorian year monthOfYear dayOfMonth - -withMonthOfYear :: Time.MonthOfYear -> Time.UTCTime -> Time.UTCTime -withMonthOfYear monthOfYear = overDay $ \day -> - let (year, _, dayOfMonth) = Time.toGregorian day - in Time.fromGregorian year monthOfYear dayOfMonth - -withDayOfWeek :: Time.DayOfWeek -> Time.UTCTime -> Time.UTCTime -withDayOfWeek dayOfWeek = overDay $ \day -> - let fwt = Time.FirstWholeWeek - dow = Time.Sunday - (year, weekOfYear, _) = Time.toWeekCalendar fwt dow day - in Time.fromWeekCalendar fwt dow year weekOfYear dayOfWeek - -overDay :: (Time.Day -> Time.Day) -> Time.UTCTime -> Time.UTCTime -overDay f utcTime = utcTime {Time.utctDay = f $ Time.utctDay utcTime} - -newUtcTime :: - (MonadFail m) => - Time.Year -> - Time.MonthOfYear -> - Time.DayOfMonth -> - Int -> - Int -> - Fixed.Pico -> - m Time.UTCTime -newUtcTime year monthOfYear dayOfMonth hour minute second = do - day <- - maybe (fail "invalid Day") pure $ - Time.fromGregorianValid year monthOfYear dayOfMonth - timeOfDay <- - maybe (fail "invalid TimeOfDay") pure $ - Time.makeTimeOfDayValid hour minute second - pure - Time.UTCTime - { Time.utctDay = day, - Time.utctDayTime = Time.sinceMidnight timeOfDay - } - -arbitraryUtcTime :: QuickCheck.Gen Time.UTCTime -arbitraryUtcTime = - Time.UTCTime - <$> fmap Time.ModifiedJulianDay QuickCheck.arbitrary - <*> fmap Time.picosecondsToDiffTime (QuickCheck.chooseInteger (0, 86400000000000000 - 1)) - -shrinkUtcTime :: Time.UTCTime -> [Time.UTCTime] -shrinkUtcTime = - QuickCheck.shrinkMap - ( \(d, t) -> - Time.UTCTime - { Time.utctDay = Time.ModifiedJulianDay d, - Time.utctDayTime = Time.picosecondsToDiffTime t - } - ) - ( \x -> - ( Time.toModifiedJulianDay $ Time.utctDay x, - Time.diffTimeToPicoseconds $ Time.utctDayTime x - ) - ) diff --git a/source/libraries/spec/Saturn/Unstable/ParseSpec.hs b/source/libraries/spec/Saturn/Unstable/ParseSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/ParseSpec.hs +++ /dev/null @@ -1,214 +0,0 @@ -module Saturn.Unstable.ParseSpec where - -import qualified Data.Either as Either -import qualified Saturn.Unstable.Parse as Parse -import qualified Saturn.Unstable.Type.ScheduleSpec as ScheduleSpec -import qualified Test.Hspec as Hspec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Parse" $ do - Hspec.describe "fromString" $ do - Hspec.it "accepts wildcards" $ do - schedule <- ScheduleSpec.new [] [] [] [] [] - Parse.fromString "* * * * *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts extra spaces" $ do - schedule <- ScheduleSpec.new [] [] [] [] [] - Parse.fromString " * * * * * " `Hspec.shouldBe` Right schedule - - Hspec.it "accepts numbers" $ do - schedule <- ScheduleSpec.new [[4]] [[3]] [[2]] [[1]] [[0]] - Parse.fromString "4 3 2 1 0" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts ranges" $ do - schedule <- ScheduleSpec.new [[8, 9]] [[6, 7]] [[4, 5]] [[2, 3]] [[0, 1]] - Parse.fromString "8-9 6-7 4-5 2-3 0-1" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts choices" $ do - schedule <- ScheduleSpec.new [[8], [9]] [[6], [7]] [[4], [5]] [[2], [3]] [[0], [1]] - Parse.fromString "8,9 6,7 4,5 2,3 0,1" `Hspec.shouldBe` Right schedule - - Hspec.describe "minute" $ do - Hspec.it "accepts a number" $ do - schedule <- ScheduleSpec.new [[0]] [] [] [] [] - Parse.fromString "0 * * * *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a range" $ do - schedule <- ScheduleSpec.new [[0, 1]] [] [] [] [] - Parse.fromString "0-1 * * * *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a choice" $ do - schedule <- ScheduleSpec.new [[0], [1]] [] [] [] [] - Parse.fromString "0,1 * * * *" `Hspec.shouldBe` Right schedule - - Hspec.it "rejects two wildcards" $ do - Parse.fromString "*,* * * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a number" $ do - Parse.fromString "*,0 * * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a range" $ do - Parse.fromString "*,0-0 * * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number" $ do - Parse.fromString "60 * * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number as part of a choice" $ do - Parse.fromString "0,60 * * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds range" $ do - Parse.fromString "60-61 * * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a half out of bounds range" $ do - Parse.fromString "0-60 * * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a backwards range" $ do - Parse.fromString "1-0 * * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.describe "hour" $ do - Hspec.it "accepts a number" $ do - schedule <- ScheduleSpec.new [] [[0]] [] [] [] - Parse.fromString "* 0 * * *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a range" $ do - schedule <- ScheduleSpec.new [] [[0, 1]] [] [] [] - Parse.fromString "* 0-1 * * *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a choice" $ do - schedule <- ScheduleSpec.new [] [[0], [1]] [] [] [] - Parse.fromString "* 0,1 * * *" `Hspec.shouldBe` Right schedule - - Hspec.it "rejects two wildcards" $ do - Parse.fromString "* *,* * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a number" $ do - Parse.fromString "* *,0 * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a range" $ do - Parse.fromString "* *,0-0 * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number" $ do - Parse.fromString "* 24 * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number as part of a choice" $ do - Parse.fromString "* 0,24 * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds range" $ do - Parse.fromString "* 24-25 * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a half out of bounds range" $ do - Parse.fromString "* 0-24 * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a backwards range" $ do - Parse.fromString "* 1-0 * * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.describe "day" $ do - Hspec.it "accepts a number" $ do - schedule <- ScheduleSpec.new [] [] [[1]] [] [] - Parse.fromString "* * 1 * *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a range" $ do - schedule <- ScheduleSpec.new [] [] [[1, 2]] [] [] - Parse.fromString "* * 1-2 * *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a choice" $ do - schedule <- ScheduleSpec.new [] [] [[1], [2]] [] [] - Parse.fromString "* * 1,2 * *" `Hspec.shouldBe` Right schedule - - Hspec.it "rejects two wildcards" $ do - Parse.fromString "* * *,* * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a number" $ do - Parse.fromString "* * *,1 * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a range" $ do - Parse.fromString "* * *,1-1 * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number" $ do - Parse.fromString "* * 32 * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number as part of a choice" $ do - Parse.fromString "* * 1,32 * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds range" $ do - Parse.fromString "* * 32-33 * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a half out of bounds range" $ do - Parse.fromString "* * 1-32 * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a backwards range" $ do - Parse.fromString "* * 2-1 * *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.describe "month" $ do - Hspec.it "accepts a number" $ do - schedule <- ScheduleSpec.new [] [] [] [[1]] [] - Parse.fromString "* * * 1 *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a range" $ do - schedule <- ScheduleSpec.new [] [] [] [[1, 2]] [] - Parse.fromString "* * * 1-2 *" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a choice" $ do - schedule <- ScheduleSpec.new [] [] [] [[1], [2]] [] - Parse.fromString "* * * 1,2 *" `Hspec.shouldBe` Right schedule - - Hspec.it "rejects two wildcards" $ do - Parse.fromString "* * * *,* *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a number" $ do - Parse.fromString "* * * *,1 *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a range" $ do - Parse.fromString "* * * *,1-1 *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number" $ do - Parse.fromString "* * * 13 *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number as part of a choice" $ do - Parse.fromString "* * * 1,13 *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds range" $ do - Parse.fromString "* * * 13-14 *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a half out of bounds range" $ do - Parse.fromString "* * * 1-13 *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a backwards range" $ do - Parse.fromString "* * * 2-1 *" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.describe "weekday" $ do - Hspec.it "accepts a number" $ do - schedule <- ScheduleSpec.new [] [] [] [] [[0]] - Parse.fromString "* * * * 0" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a range" $ do - schedule <- ScheduleSpec.new [] [] [] [] [[0, 1]] - Parse.fromString "* * * * 0-1" `Hspec.shouldBe` Right schedule - - Hspec.it "accepts a choice" $ do - schedule <- ScheduleSpec.new [] [] [] [] [[0], [1]] - Parse.fromString "* * * * 0,1" `Hspec.shouldBe` Right schedule - - Hspec.it "rejects two wildcards" $ do - Parse.fromString "* * * * *,*" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a number" $ do - Parse.fromString "* * * * *,0" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a wildcard and a range" $ do - Parse.fromString "* * * * *,0-0" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number" $ do - Parse.fromString "* * * * 7" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds number as part of a choice" $ do - Parse.fromString "* * * * 0,7" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects an out of bounds range" $ do - Parse.fromString "* * * * 7-8" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a half out of bounds range" $ do - Parse.fromString "* * * * 0-7" `Hspec.shouldSatisfy` Either.isLeft - - Hspec.it "rejects a backwards range" $ do - Parse.fromString "* * * * 1-0" `Hspec.shouldSatisfy` Either.isLeft diff --git a/source/libraries/spec/Saturn/Unstable/RenderSpec.hs b/source/libraries/spec/Saturn/Unstable/RenderSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/RenderSpec.hs +++ /dev/null @@ -1,24 +0,0 @@ -module Saturn.Unstable.RenderSpec where - -import qualified Saturn.Unstable.Render as Render -import qualified Saturn.Unstable.Type.ScheduleSpec as ScheduleSpec -import qualified Test.Hspec as Hspec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Render" $ do - Hspec.describe "toString" $ do - Hspec.it "works with wildcards" $ do - schedule <- ScheduleSpec.new [] [] [] [] [] - Render.toString schedule `Hspec.shouldBe` "* * * * *" - - Hspec.it "works with numbers" $ do - schedule <- ScheduleSpec.new [[4]] [[3]] [[2]] [[1]] [[0]] - Render.toString schedule `Hspec.shouldBe` "4 3 2 1 0" - - Hspec.it "works with ranges" $ do - schedule <- ScheduleSpec.new [[8, 9]] [[6, 7]] [[4, 5]] [[2, 3]] [[0, 1]] - Render.toString schedule `Hspec.shouldBe` "8-9 6-7 4-5 2-3 0-1" - - Hspec.it "works with choices" $ do - schedule <- ScheduleSpec.new [[8], [9]] [[6], [7]] [[4], [5]] [[2], [3]] [[0], [1]] - Render.toString schedule `Hspec.shouldBe` "8,9 6,7 4,5 2,3 0,1" diff --git a/source/libraries/spec/Saturn/Unstable/Type/DaySpec.hs b/source/libraries/spec/Saturn/Unstable/Type/DaySpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/DaySpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Saturn.Unstable.Type.DaySpec where - -import qualified Data.Maybe as Maybe -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.Day as Day -import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Day" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Day.parsec "" (Builder.toLazyText $ Day.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Day.Day -arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Day.fromField - -shrink :: Day.Day -> [Day.Day] -shrink = Maybe.mapMaybe Day.fromField . FieldSpec.shrink . Day.toField - -new :: (MonadFail m) => [[Word.Word8]] -> m Day.Day -new xs = do - field <- FieldSpec.new xs - maybe (fail $ "invalid Day: " <> show xs) pure $ Day.fromField field diff --git a/source/libraries/spec/Saturn/Unstable/Type/ElementSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/ElementSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/ElementSpec.hs +++ /dev/null @@ -1,45 +0,0 @@ -module Saturn.Unstable.Type.ElementSpec where - -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.Element as Element -import qualified Saturn.Unstable.Type.Number as Number -import qualified Saturn.Unstable.Type.NumberSpec as NumberSpec -import qualified Saturn.Unstable.Type.Range as Range -import qualified Saturn.Unstable.Type.RangeSpec as RangeSpec -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Element" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Element.parsec "" (Builder.toLazyText $ Element.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Element.Element -arbitrary = - Element.fromEither - <$> QuickCheck.liftArbitrary2 - RangeSpec.arbitrary - NumberSpec.arbitrary - -shrink :: Element.Element -> [Element.Element] -shrink element = - let xs = case Element.toEither element of - Left range -> - let (lo, hi) = Range.toTuple range - in fmap (Element.fromEither . Right) [lo, hi] - Right _ -> [] - in mappend xs - . fmap Element.fromEither - . QuickCheck.liftShrink2 RangeSpec.shrink NumberSpec.shrink - $ Element.toEither element - -new :: (MonadFail m) => [Word.Word8] -> m Element.Element -new xs = case xs of - [x] -> pure . Element.fromEither . Right $ Number.fromWord8 x - [x, y] -> Element.fromEither . Left <$> RangeSpec.new (x, y) - _ -> fail $ "invalid Element: " <> show xs diff --git a/source/libraries/spec/Saturn/Unstable/Type/FieldSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/FieldSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/FieldSpec.hs +++ /dev/null @@ -1,53 +0,0 @@ -module Saturn.Unstable.Type.FieldSpec where - -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Maybe as Maybe -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.ElementSpec as ElementSpec -import qualified Saturn.Unstable.Type.Field as Field -import qualified Saturn.Unstable.Type.Wildcard as Wildcard -import qualified Saturn.Unstable.Type.WildcardSpec as WildcardSpec -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Field" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Field.parsec "" (Builder.toLazyText $ Field.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Field.Field -arbitrary = - Field.fromEither - <$> QuickCheck.liftArbitrary2 - WildcardSpec.arbitrary - (arbitraryNonEmpty ElementSpec.arbitrary) - -arbitraryNonEmpty :: QuickCheck.Gen a -> QuickCheck.Gen (NonEmpty.NonEmpty a) -arbitraryNonEmpty g = (NonEmpty.:|) <$> g <*> QuickCheck.listOf g - -shrink :: Field.Field -> [Field.Field] -shrink field = - let xs = case Field.toEither field of - Left _ -> [] - Right _ -> [Field.fromEither . Left $ Wildcard.fromUnit ()] - in mappend xs - . fmap Field.fromEither - . QuickCheck.liftShrink2 WildcardSpec.shrink (shrinkNonEmpty ElementSpec.shrink) - $ Field.toEither field - -shrinkNonEmpty :: (a -> [a]) -> NonEmpty.NonEmpty a -> [NonEmpty.NonEmpty a] -shrinkNonEmpty f = Maybe.mapMaybe (NonEmpty.nonEmpty . f) . NonEmpty.toList - -new :: (MonadFail m) => [[Word.Word8]] -> m Field.Field -new = - fmap - ( Field.fromEither - . maybe (Left $ Wildcard.fromUnit ()) Right - . NonEmpty.nonEmpty - ) - . mapM ElementSpec.new diff --git a/source/libraries/spec/Saturn/Unstable/Type/HourSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/HourSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/HourSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Saturn.Unstable.Type.HourSpec where - -import qualified Data.Maybe as Maybe -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec -import qualified Saturn.Unstable.Type.Hour as Hour -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Hour" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Hour.parsec "" (Builder.toLazyText $ Hour.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Hour.Hour -arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Hour.fromField - -shrink :: Hour.Hour -> [Hour.Hour] -shrink = Maybe.mapMaybe Hour.fromField . FieldSpec.shrink . Hour.toField - -new :: (MonadFail m) => [[Word.Word8]] -> m Hour.Hour -new xs = do - field <- FieldSpec.new xs - maybe (fail $ "invalid Hour: " <> show xs) pure $ Hour.fromField field diff --git a/source/libraries/spec/Saturn/Unstable/Type/MinuteSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/MinuteSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/MinuteSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Saturn.Unstable.Type.MinuteSpec where - -import qualified Data.Maybe as Maybe -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec -import qualified Saturn.Unstable.Type.Minute as Minute -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Minute" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Minute.parsec "" (Builder.toLazyText $ Minute.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Minute.Minute -arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Minute.fromField - -shrink :: Minute.Minute -> [Minute.Minute] -shrink = Maybe.mapMaybe Minute.fromField . FieldSpec.shrink . Minute.toField - -new :: (MonadFail m) => [[Word.Word8]] -> m Minute.Minute -new xs = do - field <- FieldSpec.new xs - maybe (fail $ "invalid Minute: " <> show xs) pure $ Minute.fromField field diff --git a/source/libraries/spec/Saturn/Unstable/Type/MonthSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/MonthSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/MonthSpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Saturn.Unstable.Type.MonthSpec where - -import qualified Data.Maybe as Maybe -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec -import qualified Saturn.Unstable.Type.Month as Month -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Month" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Month.parsec "" (Builder.toLazyText $ Month.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Month.Month -arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Month.fromField - -shrink :: Month.Month -> [Month.Month] -shrink = Maybe.mapMaybe Month.fromField . FieldSpec.shrink . Month.toField - -new :: (MonadFail m) => [[Word.Word8]] -> m Month.Month -new xs = do - field <- FieldSpec.new xs - maybe (fail $ "invalid Month: " <> show xs) pure $ Month.fromField field diff --git a/source/libraries/spec/Saturn/Unstable/Type/NumberSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/NumberSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/NumberSpec.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Saturn.Unstable.Type.NumberSpec where - -import qualified Data.Text.Lazy.Builder as Builder -import qualified Saturn.Unstable.Type.Number as Number -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Number" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Number.parsec "" (Builder.toLazyText $ Number.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Number.Number -arbitrary = Number.fromWord8 <$> QuickCheck.arbitrary - -shrink :: Number.Number -> [Number.Number] -shrink = fmap Number.fromWord8 . QuickCheck.shrink . Number.toWord8 diff --git a/source/libraries/spec/Saturn/Unstable/Type/RangeSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/RangeSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/RangeSpec.hs +++ /dev/null @@ -1,38 +0,0 @@ -module Saturn.Unstable.Type.RangeSpec where - -import qualified Data.Maybe as Maybe -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Extra.Tuple as Tuple -import qualified Saturn.Unstable.Type.Number as Number -import qualified Saturn.Unstable.Type.NumberSpec as NumberSpec -import qualified Saturn.Unstable.Type.Range as Range -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Range" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Range.parsec "" (Builder.toLazyText $ Range.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Range.Range -arbitrary = - QuickCheck.suchThatMap - (QuickCheck.liftArbitrary2 NumberSpec.arbitrary NumberSpec.arbitrary) - Range.fromTuple - -shrink :: Range.Range -> [Range.Range] -shrink = - Maybe.mapMaybe Range.fromTuple - . QuickCheck.liftShrink2 NumberSpec.shrink NumberSpec.shrink - . Range.toTuple - -new :: (MonadFail m) => (Word.Word8, Word.Word8) -> m Range.Range -new tuple = - maybe (fail $ "invalid Range: " <> show tuple) pure - . Range.fromTuple - $ Tuple.mapBoth Number.fromWord8 tuple diff --git a/source/libraries/spec/Saturn/Unstable/Type/ScheduleSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/ScheduleSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/ScheduleSpec.hs +++ /dev/null @@ -1,85 +0,0 @@ -module Saturn.Unstable.Type.ScheduleSpec where - -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.DaySpec as DaySpec -import qualified Saturn.Unstable.Type.HourSpec as HourSpec -import qualified Saturn.Unstable.Type.MinuteSpec as MinuteSpec -import qualified Saturn.Unstable.Type.MonthSpec as MonthSpec -import qualified Saturn.Unstable.Type.Schedule as Schedule -import qualified Saturn.Unstable.Type.WeekdaySpec as WeekdaySpec -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Schedule" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Schedule.parsec "" (Builder.toLazyText $ Schedule.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Schedule.Schedule -arbitrary = - Schedule.Schedule - <$> MinuteSpec.arbitrary - <*> HourSpec.arbitrary - <*> DaySpec.arbitrary - <*> MonthSpec.arbitrary - <*> WeekdaySpec.arbitrary - -shrink :: Schedule.Schedule -> [Schedule.Schedule] -shrink schedule = - ( \(minute, hour, day, month, weekday) -> - Schedule.Schedule - { Schedule.minute = minute, - Schedule.hour = hour, - Schedule.day = day, - Schedule.month = month, - Schedule.weekday = weekday - } - ) - <$> liftShrink5 - MinuteSpec.shrink - HourSpec.shrink - DaySpec.shrink - MonthSpec.shrink - WeekdaySpec.shrink - ( Schedule.minute schedule, - Schedule.hour schedule, - Schedule.day schedule, - Schedule.month schedule, - Schedule.weekday schedule - ) - -liftShrink5 :: - (t1 -> [t1]) -> - (t2 -> [t2]) -> - (t3 -> [t3]) -> - (t4 -> [t4]) -> - (t5 -> [t5]) -> - (t1, t2, t3, t4, t5) -> - [(t1, t2, t3, t4, t5)] -liftShrink5 f1 f2 f3 f4 f5 (x1, x2, x3, x4, x5) = - (\((y1, y2), (y3, (y4, y5))) -> (y1, y2, y3, y4, y5)) - <$> QuickCheck.liftShrink2 - (QuickCheck.liftShrink2 f1 f2) - (QuickCheck.liftShrink2 f3 (QuickCheck.liftShrink2 f4 f5)) - ((x1, x2), (x3, (x4, x5))) - -new :: - (MonadFail m) => - [[Word.Word8]] -> - [[Word.Word8]] -> - [[Word.Word8]] -> - [[Word.Word8]] -> - [[Word.Word8]] -> - m Schedule.Schedule -new minutes hours days months weekdays = - Schedule.Schedule - <$> MinuteSpec.new minutes - <*> HourSpec.new hours - <*> DaySpec.new days - <*> MonthSpec.new months - <*> WeekdaySpec.new weekdays diff --git a/source/libraries/spec/Saturn/Unstable/Type/WeekdaySpec.hs b/source/libraries/spec/Saturn/Unstable/Type/WeekdaySpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/WeekdaySpec.hs +++ /dev/null @@ -1,29 +0,0 @@ -module Saturn.Unstable.Type.WeekdaySpec where - -import qualified Data.Maybe as Maybe -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec -import qualified Saturn.Unstable.Type.Weekday as Weekday -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Weekday" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Weekday.parsec "" (Builder.toLazyText $ Weekday.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Weekday.Weekday -arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Weekday.fromField - -shrink :: Weekday.Weekday -> [Weekday.Weekday] -shrink = Maybe.mapMaybe Weekday.fromField . FieldSpec.shrink . Weekday.toField - -new :: (MonadFail m) => [[Word.Word8]] -> m Weekday.Weekday -new xs = do - field <- FieldSpec.new xs - maybe (fail $ "invalid Weekday: " <> show xs) pure $ Weekday.fromField field diff --git a/source/libraries/spec/Saturn/Unstable/Type/WildcardSpec.hs b/source/libraries/spec/Saturn/Unstable/Type/WildcardSpec.hs deleted file mode 100644 --- a/source/libraries/spec/Saturn/Unstable/Type/WildcardSpec.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Saturn.Unstable.Type.WildcardSpec where - -import qualified Data.Text.Lazy.Builder as Builder -import qualified Saturn.Unstable.Type.Wildcard as Wildcard -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck -import qualified Text.Parsec as Parsec - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn.Unstable.Type.Wildcard" $ do - Hspec.it "round trips" - . QuickCheck.forAllShrink arbitrary shrink - $ \x -> do - Parsec.parse Wildcard.parsec "" (Builder.toLazyText $ Wildcard.toBuilder x) - `Hspec.shouldBe` Right x - -arbitrary :: QuickCheck.Gen Wildcard.Wildcard -arbitrary = Wildcard.fromUnit <$> QuickCheck.arbitrary - -shrink :: Wildcard.Wildcard -> [Wildcard.Wildcard] -shrink = fmap Wildcard.fromUnit . QuickCheck.shrink . Wildcard.toUnit diff --git a/source/libraries/spec/SaturnSpec.hs b/source/libraries/spec/SaturnSpec.hs deleted file mode 100644 --- a/source/libraries/spec/SaturnSpec.hs +++ /dev/null @@ -1,25 +0,0 @@ -module SaturnSpec where - -import qualified Saturn.Unstable.Parse as Parse -import qualified Saturn.Unstable.Render as Render -import qualified Saturn.Unstable.Type.ScheduleSpec as ScheduleSpec -import qualified Test.Hspec as Hspec -import qualified Test.QuickCheck as QuickCheck - -spec :: Hspec.Spec -spec = Hspec.describe "Saturn" $ do - Hspec.describe "round trips" $ do - Hspec.it "through string" - . QuickCheck.forAllShrink ScheduleSpec.arbitrary ScheduleSpec.shrink - $ \schedule -> - Parse.fromString (Render.toString schedule) `Hspec.shouldBe` Right schedule - - Hspec.it "through strict text" - . QuickCheck.forAllShrink ScheduleSpec.arbitrary ScheduleSpec.shrink - $ \schedule -> - Parse.fromText (Render.toText schedule) `Hspec.shouldBe` Right schedule - - Hspec.it "through lazy text" - . QuickCheck.forAllShrink ScheduleSpec.arbitrary ScheduleSpec.shrink - $ \schedule -> - Parse.fromLazyText (Render.toLazyText schedule) `Hspec.shouldBe` Right schedule diff --git a/source/libraries/unstable/Saturn/Unstable/Constant.hs b/source/libraries/unstable/Saturn/Unstable/Constant.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Constant.hs +++ /dev/null @@ -1,96 +0,0 @@ -module Saturn.Unstable.Constant where - -import qualified Data.Maybe as Maybe -import qualified Saturn.Unstable.Type.Day as Day -import qualified Saturn.Unstable.Type.Element as Element -import qualified Saturn.Unstable.Type.Field as Field -import qualified Saturn.Unstable.Type.Hour as Hour -import qualified Saturn.Unstable.Type.Minute as Minute -import qualified Saturn.Unstable.Type.Month as Month -import qualified Saturn.Unstable.Type.Number as Number -import qualified Saturn.Unstable.Type.Schedule as Schedule -import qualified Saturn.Unstable.Type.Weekday as Weekday -import qualified Saturn.Unstable.Type.Wildcard as Wildcard - --- | > "* * * * *" -everyMinute :: Schedule.Schedule -everyMinute = Maybe.fromMaybe (error "Saturn.Unstable.Constant.everyMinute") $ do - let wildcard = Field.fromEither . Left $ Wildcard.fromUnit () - minute <- Minute.fromField wildcard - hour <- Hour.fromField wildcard - day <- Day.fromField wildcard - month <- Month.fromField wildcard - weekday <- Weekday.fromField wildcard - pure - Schedule.Schedule - { Schedule.minute = minute, - Schedule.hour = hour, - Schedule.day = day, - Schedule.month = month, - Schedule.weekday = weekday - } - --- | > "0 * * * *" -hourly :: Schedule.Schedule -hourly = Maybe.fromMaybe (error "Saturn.Unstable.Constant.hourly") $ do - minute <- - Minute.fromField - . Field.fromEither - . Right - . pure - . Element.fromEither - . Right - $ Number.fromWord8 0 - pure everyMinute {Schedule.minute = minute} - --- | > "0 0 * * *" -daily :: Schedule.Schedule -daily = Maybe.fromMaybe (error "Saturn.Unstable.Constant.daily") $ do - hour <- - Hour.fromField - . Field.fromEither - . Right - . pure - . Element.fromEither - . Right - $ Number.fromWord8 0 - pure hourly {Schedule.hour = hour} - --- | > "0 0 * * 0" -weekly :: Schedule.Schedule -weekly = Maybe.fromMaybe (error "Saturn.Unstable.Constant.weekly") $ do - weekday <- - Weekday.fromField - . Field.fromEither - . Right - . pure - . Element.fromEither - . Right - $ Number.fromWord8 0 - pure daily {Schedule.weekday = weekday} - --- | > "0 0 1 * *" -monthly :: Schedule.Schedule -monthly = Maybe.fromMaybe (error "Saturn.Unstable.Constant.monthly") $ do - day <- - Day.fromField - . Field.fromEither - . Right - . pure - . Element.fromEither - . Right - $ Number.fromWord8 1 - pure daily {Schedule.day = day} - --- | > "0 0 1 1 *" -yearly :: Schedule.Schedule -yearly = Maybe.fromMaybe (error "Saturn.Unstable.Constant.yearly") $ do - month <- - Month.fromField - . Field.fromEither - . Right - . pure - . Element.fromEither - . Right - $ Number.fromWord8 1 - pure monthly {Schedule.month = month} diff --git a/source/libraries/unstable/Saturn/Unstable/Extra/Int.hs b/source/libraries/unstable/Saturn/Unstable/Extra/Int.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Extra/Int.hs +++ /dev/null @@ -1,10 +0,0 @@ -module Saturn.Unstable.Extra.Int where - -import qualified Data.Bits as Bits -import qualified Data.Word as Word - -fromWord8 :: Word.Word8 -> Int -fromWord8 = fromIntegral - -toWord8 :: Int -> Maybe Word.Word8 -toWord8 = Bits.toIntegralSized diff --git a/source/libraries/unstable/Saturn/Unstable/Extra/Ord.hs b/source/libraries/unstable/Saturn/Unstable/Extra/Ord.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Extra/Ord.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Saturn.Unstable.Extra.Ord where - -within :: (Ord a) => (a, a) -> a -> Bool -within (lo, hi) x = lo <= x && x <= hi diff --git a/source/libraries/unstable/Saturn/Unstable/Extra/Parsec.hs b/source/libraries/unstable/Saturn/Unstable/Extra/Parsec.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Extra/Parsec.hs +++ /dev/null @@ -1,16 +0,0 @@ -module Saturn.Unstable.Extra.Parsec where - -import qualified Data.List.NonEmpty as NonEmpty -import qualified Text.Parsec as Parsec - -either :: - Parsec.ParsecT s u m a -> - Parsec.ParsecT s u m b -> - Parsec.ParsecT s u m (Either a b) -either l r = fmap Left l Parsec.<|> fmap Right r - -sepByNE :: - Parsec.ParsecT s u m a -> - Parsec.ParsecT s u m sep -> - Parsec.ParsecT s u m (NonEmpty.NonEmpty a) -sepByNE p s = (NonEmpty.:|) <$> p <*> Parsec.many (s *> p) diff --git a/source/libraries/unstable/Saturn/Unstable/Extra/Time.hs b/source/libraries/unstable/Saturn/Unstable/Extra/Time.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Extra/Time.hs +++ /dev/null @@ -1,14 +0,0 @@ -module Saturn.Unstable.Extra.Time where - -import qualified Data.Time as Time -import qualified Data.Word as Word - -dayOfWeekToWord8 :: Time.DayOfWeek -> Word.Word8 -dayOfWeekToWord8 dayOfWeek = case dayOfWeek of - Time.Sunday -> 0 - Time.Monday -> 1 - Time.Tuesday -> 2 - Time.Wednesday -> 3 - Time.Thursday -> 4 - Time.Friday -> 5 - Time.Saturday -> 6 diff --git a/source/libraries/unstable/Saturn/Unstable/Extra/Tuple.hs b/source/libraries/unstable/Saturn/Unstable/Extra/Tuple.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Extra/Tuple.hs +++ /dev/null @@ -1,9 +0,0 @@ -module Saturn.Unstable.Extra.Tuple where - -import qualified Data.Bifunctor as Bifunctor - -mapBoth :: (a -> b) -> (a, a) -> (b, b) -mapBoth f = Bifunctor.bimap f f - -toSequence :: (Enum a) => (a, a) -> [a] -toSequence = uncurry enumFromTo diff --git a/source/libraries/unstable/Saturn/Unstable/Match.hs b/source/libraries/unstable/Saturn/Unstable/Match.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Match.hs +++ /dev/null @@ -1,89 +0,0 @@ -module Saturn.Unstable.Match where - -import qualified Control.Monad as Monad -import qualified Data.List as List -import qualified Data.Maybe as Maybe -import qualified Data.Set as Set -import qualified Data.Time as Time -import qualified Saturn.Unstable.Extra.Int as Int -import qualified Saturn.Unstable.Extra.Time as Time -import qualified Saturn.Unstable.Type.Day as Day -import qualified Saturn.Unstable.Type.Field as Field -import qualified Saturn.Unstable.Type.Hour as Hour -import qualified Saturn.Unstable.Type.Minute as Minute -import qualified Saturn.Unstable.Type.Month as Month -import qualified Saturn.Unstable.Type.Schedule as Schedule -import qualified Saturn.Unstable.Type.Weekday as Weekday -import qualified Saturn.Unstable.Type.Wildcard as Wildcard - --- | Returns 'True' if the given 'Time.UTCTime' matches the given --- 'Schedule.Schedule', otherwise returns 'False'. -isMatch :: Time.UTCTime -> Schedule.Schedule -> Bool -isMatch utcTime schedule = Maybe.fromMaybe False $ do - let time = Time.pastMidnight $ Time.utctDayTime utcTime - minute <- Int.toWord8 $ Time.todMin time - Monad.guard . Minute.isMatch minute $ Schedule.minute schedule - - hour <- Int.toWord8 $ Time.todHour time - Monad.guard . Hour.isMatch hour $ Schedule.hour schedule - - let date = Time.utctDay utcTime - let (_, monthOfYear, dayOfMonth) = Time.toGregorian date - month <- Int.toWord8 monthOfYear - Monad.guard . Month.isMatch month $ Schedule.month schedule - - day <- Int.toWord8 dayOfMonth - let dayMatches = Day.isMatch day $ Schedule.day schedule - let weekday = Time.dayOfWeekToWord8 $ Time.dayOfWeek date - let weekdayMatches = Weekday.isMatch weekday $ Schedule.weekday schedule - Monad.guard $ - if dayIsWildcard schedule || weekdayIsWildcard schedule - then dayMatches && weekdayMatches - else dayMatches || weekdayMatches - - pure True - -dayIsWildcard :: Schedule.Schedule -> Bool -dayIsWildcard = Field.isWildcard . Day.toField . Schedule.day - -weekdayIsWildcard :: Schedule.Schedule -> Bool -weekdayIsWildcard = Field.isWildcard . Weekday.toField . Schedule.weekday - --- | Looks for the first time after the given 'Time.UTCTime' that matches the --- given 'Schedule.Schedule'. Returns 'Nothing' if the 'Schedule.Schedule' only --- matches dates that cannot happen, like February 30th. -nextMatch :: Time.UTCTime -> Schedule.Schedule -> Maybe Time.UTCTime -nextMatch utcTime schedule = - if dayIsWildcard schedule || weekdayIsWildcard schedule - then incompleteNextMatch utcTime schedule - else do - let wildcard = Field.fromEither . Left $ Wildcard.fromUnit () - day <- Day.fromField wildcard - weekday <- Weekday.fromField wildcard - Maybe.listToMaybe . List.sort $ - Maybe.catMaybes - [ incompleteNextMatch utcTime schedule {Schedule.day = day}, - incompleteNextMatch utcTime schedule {Schedule.weekday = weekday} - ] - -incompleteNextMatch :: Time.UTCTime -> Schedule.Schedule -> Maybe Time.UTCTime -incompleteNextMatch utcTime schedule = Maybe.listToMaybe $ do - let oldDate = Time.utctDay utcTime - let (oldYear, _, _) = Time.toGregorian oldDate - year <- [oldYear .. oldYear + 8] - month <- fmap Int.fromWord8 . Set.toAscList . Month.expand $ Schedule.month schedule - day <- fmap Int.fromWord8 . Set.toAscList . Day.expand $ Schedule.day schedule - date <- Maybe.maybeToList $ Time.fromGregorianValid year month day - Monad.guard $ date >= oldDate - Monad.guard - . Set.member (Time.dayOfWeekToWord8 $ Time.dayOfWeek date) - . Weekday.expand - $ Schedule.weekday schedule - hour <- fmap Int.fromWord8 . Set.toAscList . Hour.expand $ Schedule.hour schedule - minute <- fmap Int.fromWord8 . Set.toAscList . Minute.expand $ Schedule.minute schedule - time <- - fmap Time.sinceMidnight - . Maybe.maybeToList - $ Time.makeTimeOfDayValid hour minute 0 - Monad.when (date == oldDate) . Monad.guard $ time > Time.utctDayTime utcTime - pure Time.UTCTime {Time.utctDay = date, Time.utctDayTime = time} diff --git a/source/libraries/unstable/Saturn/Unstable/Parse.hs b/source/libraries/unstable/Saturn/Unstable/Parse.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Parse.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Parse where - -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText -import qualified Saturn.Unstable.Type.Schedule as Schedule -import qualified Text.Parsec as Parsec - --- | Parses a lazy 'LazyText.Text' value into a 'Schedule.Schedule'. See --- 'fromText' for details. -fromLazyText :: LazyText.Text -> Either Parsec.ParseError Schedule.Schedule -fromLazyText = Parsec.parse parsec "" - --- | Parses a 'String' into a 'Schedule.Schedule'. See 'fromText' for details. -fromString :: String -> Either Parsec.ParseError Schedule.Schedule -fromString = Parsec.parse parsec "" - --- | Parses a strict 'Text.Text' value into a 'Schedule.Schedule'. The input --- should have five fields, each separated by at least one space. Leading and --- trailing spaces are allowed. -fromText :: Text.Text -> Either Parsec.ParseError Schedule.Schedule -fromText = Parsec.parse parsec "" - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Schedule.Schedule -parsec = - Parsec.skipMany (Parsec.char ' ') - *> Schedule.parsec - <* Parsec.skipMany (Parsec.char ' ') - <* Parsec.eof diff --git a/source/libraries/unstable/Saturn/Unstable/Render.hs b/source/libraries/unstable/Saturn/Unstable/Render.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Render.hs +++ /dev/null @@ -1,21 +0,0 @@ -module Saturn.Unstable.Render where - -import qualified Data.Text as Text -import qualified Data.Text.Lazy as LazyText -import qualified Data.Text.Lazy.Builder as Builder -import qualified Saturn.Unstable.Type.Schedule as Schedule - --- | Renders a 'Schedule.Schedule' into a lazy 'LazyText.Text' value. See --- 'toText' for details. -toLazyText :: Schedule.Schedule -> LazyText.Text -toLazyText = Builder.toLazyText . Schedule.toBuilder - --- | Renders a 'Schedule.Schedule' into a 'String' value. See 'toText' for --- details. -toString :: Schedule.Schedule -> String -toString = LazyText.unpack . toLazyText - --- | Renders a 'Schedule.Schedule' into a strict 'Text.Text' value. The output --- will have five fields, each separated by a single space. -toText :: Schedule.Schedule -> Text.Text -toText = LazyText.toStrict . toLazyText diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Day.hs b/source/libraries/unstable/Saturn/Unstable/Type/Day.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Day.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Day where - -import qualified Data.Coerce as Coerce -import qualified Data.Set as Set -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.Field as Field -import qualified Text.Parsec as Parsec - -newtype Day - = Day Field.Field - deriving (Eq, Show) - -bounds :: (Word.Word8, Word.Word8) -bounds = (1, 31) - -fromField :: Field.Field -> Maybe Day -fromField field = - if Field.isValid bounds field then Just $ Day field else Nothing - -toField :: Day -> Field.Field -toField = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Day -parsec = do - field <- Field.parsec - maybe (fail "invalid Day") pure $ fromField field - -toBuilder :: Day -> Builder.Builder -toBuilder = Field.toBuilder . toField - -expand :: Day -> Set.Set Word.Word8 -expand = Field.expand bounds . toField - -isMatch :: Word.Word8 -> Day -> Bool -isMatch word8 = Set.member word8 . expand diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Element.hs b/source/libraries/unstable/Saturn/Unstable/Type/Element.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Element.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Element where - -import qualified Data.Coerce as Coerce -import qualified Data.Set as Set -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Extra.Parsec as Parsec -import qualified Saturn.Unstable.Type.Number as Number -import qualified Saturn.Unstable.Type.Range as Range -import qualified Text.Parsec as Parsec - -newtype Element - = Element (Either Range.Range Number.Number) - deriving (Eq, Show) - -fromEither :: Either Range.Range Number.Number -> Element -fromEither = Coerce.coerce - -toEither :: Element -> Either Range.Range Number.Number -toEither = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Element -parsec = fromEither <$> Parsec.either (Parsec.try Range.parsec) Number.parsec - -toBuilder :: Element -> Builder.Builder -toBuilder = either Range.toBuilder Number.toBuilder . toEither - -isValid :: (Word.Word8, Word.Word8) -> Element -> Bool -isValid tuple = either (Range.isValid tuple) (Number.isValid tuple) . toEither - -expand :: Element -> Set.Set Word.Word8 -expand = either Range.expand (Set.singleton . Number.toWord8) . toEither diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Field.hs b/source/libraries/unstable/Saturn/Unstable/Type/Field.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Field.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Field where - -import qualified Data.Coerce as Coerce -import qualified Data.Either as Either -import qualified Data.Foldable as Foldable -import qualified Data.List.NonEmpty as NonEmpty -import qualified Data.Set as Set -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Extra.Parsec as Parsec -import qualified Saturn.Unstable.Extra.Tuple as Tuple -import qualified Saturn.Unstable.Type.Element as Element -import qualified Saturn.Unstable.Type.Wildcard as Wildcard -import qualified Text.Parsec as Parsec - -newtype Field - = Field (Either Wildcard.Wildcard (NonEmpty.NonEmpty Element.Element)) - deriving (Eq, Show) - -fromEither :: - Either Wildcard.Wildcard (NonEmpty.NonEmpty Element.Element) -> Field -fromEither = Coerce.coerce - -toEither :: - Field -> Either Wildcard.Wildcard (NonEmpty.NonEmpty Element.Element) -toEither = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Field -parsec = - fromEither - <$> Parsec.either - Wildcard.parsec - (Parsec.sepByNE Element.parsec $ Parsec.char ',') - -toBuilder :: Field -> Builder.Builder -toBuilder = - either - Wildcard.toBuilder - ( Foldable.fold - . NonEmpty.intersperse (Builder.singleton ',') - . fmap Element.toBuilder - ) - . toEither - -isValid :: (Word.Word8, Word.Word8) -> Field -> Bool -isValid tuple = either (const True) (all $ Element.isValid tuple) . toEither - -expand :: (Word.Word8, Word.Word8) -> Field -> Set.Set Word.Word8 -expand tuple = - either - (const . Set.fromList $ Tuple.toSequence tuple) - (Set.unions . fmap Element.expand) - . toEither - -isWildcard :: Field -> Bool -isWildcard = Either.isLeft . toEither diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Hour.hs b/source/libraries/unstable/Saturn/Unstable/Type/Hour.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Hour.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Hour where - -import qualified Data.Coerce as Coerce -import qualified Data.Set as Set -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.Field as Field -import qualified Text.Parsec as Parsec - -newtype Hour - = Hour Field.Field - deriving (Eq, Show) - -bounds :: (Word.Word8, Word.Word8) -bounds = (0, 23) - -fromField :: Field.Field -> Maybe Hour -fromField field = - if Field.isValid bounds field then Just $ Hour field else Nothing - -toField :: Hour -> Field.Field -toField = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Hour -parsec = do - field <- Field.parsec - maybe (fail "invalid Hour") pure $ fromField field - -toBuilder :: Hour -> Builder.Builder -toBuilder = Field.toBuilder . toField - -expand :: Hour -> Set.Set Word.Word8 -expand = Field.expand bounds . toField - -isMatch :: Word.Word8 -> Hour -> Bool -isMatch word8 = Set.member word8 . expand diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Minute.hs b/source/libraries/unstable/Saturn/Unstable/Type/Minute.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Minute.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Minute where - -import qualified Data.Coerce as Coerce -import qualified Data.Set as Set -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.Field as Field -import qualified Text.Parsec as Parsec - -newtype Minute - = Minute Field.Field - deriving (Eq, Show) - -bounds :: (Word.Word8, Word.Word8) -bounds = (0, 59) - -fromField :: Field.Field -> Maybe Minute -fromField field = - if Field.isValid bounds field then Just $ Minute field else Nothing - -toField :: Minute -> Field.Field -toField = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Minute -parsec = do - field <- Field.parsec - maybe (fail "invalid Minute") pure $ fromField field - -toBuilder :: Minute -> Builder.Builder -toBuilder = Field.toBuilder . toField - -expand :: Minute -> Set.Set Word.Word8 -expand = Field.expand bounds . toField - -isMatch :: Word.Word8 -> Minute -> Bool -isMatch word8 = Set.member word8 . expand diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Month.hs b/source/libraries/unstable/Saturn/Unstable/Type/Month.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Month.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Month where - -import qualified Data.Coerce as Coerce -import qualified Data.Set as Set -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.Field as Field -import qualified Text.Parsec as Parsec - -newtype Month - = Month Field.Field - deriving (Eq, Show) - -bounds :: (Word.Word8, Word.Word8) -bounds = (1, 12) - -fromField :: Field.Field -> Maybe Month -fromField field = - if Field.isValid bounds field then Just $ Month field else Nothing - -toField :: Month -> Field.Field -toField = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Month -parsec = do - field <- Field.parsec - maybe (fail "invalid Month") pure $ fromField field - -toBuilder :: Month -> Builder.Builder -toBuilder = Field.toBuilder . toField - -expand :: Month -> Set.Set Word.Word8 -expand = Field.expand bounds . toField - -isMatch :: Word.Word8 -> Month -> Bool -isMatch word8 = Set.member word8 . expand diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Number.hs b/source/libraries/unstable/Saturn/Unstable/Type/Number.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Number.hs +++ /dev/null @@ -1,35 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Number where - -import qualified Data.Bits as Bits -import qualified Data.Coerce as Coerce -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Text.Lazy.Builder.Int as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Extra.Ord as Ord -import qualified Text.Parsec as Parsec -import qualified Text.Read as Read - -newtype Number - = Number Word.Word8 - deriving (Eq, Show) - -fromWord8 :: Word.Word8 -> Number -fromWord8 = Coerce.coerce - -toWord8 :: Number -> Word.Word8 -toWord8 = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Number -parsec = do - string <- Parsec.many1 Parsec.digit - integer <- maybe (fail "invalidNumber") pure $ Read.readMaybe string - maybe (fail "invalidNumber") (pure . fromWord8) $ - Bits.toIntegralSized (integer :: Integer) - -toBuilder :: Number -> Builder.Builder -toBuilder = Builder.decimal . toWord8 - -isValid :: (Word.Word8, Word.Word8) -> Number -> Bool -isValid tuple = Ord.within tuple . toWord8 diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Range.hs b/source/libraries/unstable/Saturn/Unstable/Type/Range.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Range.hs +++ /dev/null @@ -1,47 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Range where - -import qualified Control.Monad as Monad -import qualified Data.Coerce as Coerce -import qualified Data.Set as Set -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Extra.Tuple as Tuple -import qualified Saturn.Unstable.Type.Number as Number -import qualified Text.Parsec as Parsec - -newtype Range - = Range (Number.Number, Number.Number) - deriving (Eq, Show) - -fromTuple :: (Number.Number, Number.Number) -> Maybe Range -fromTuple (lo, hi) = - if Number.toWord8 lo > Number.toWord8 hi - then Nothing - else Just $ Range (lo, hi) - -toTuple :: Range -> (Number.Number, Number.Number) -toTuple = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Range -parsec = do - lo <- Number.parsec - Monad.void $ Parsec.char '-' - hi <- Number.parsec - maybe (fail "invalid Range") pure $ fromTuple (lo, hi) - -toBuilder :: Range -> Builder.Builder -toBuilder range = - let (lo, hi) = toTuple range - in Number.toBuilder lo <> Builder.singleton '-' <> Number.toBuilder hi - -isValid :: (Word.Word8, Word.Word8) -> Range -> Bool -isValid tuple = uncurry (&&) . Tuple.mapBoth (Number.isValid tuple) . toTuple - -expand :: Range -> Set.Set Word.Word8 -expand = - Set.fromList - . Tuple.toSequence - . Tuple.mapBoth Number.toWord8 - . toTuple diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Schedule.hs b/source/libraries/unstable/Saturn/Unstable/Type/Schedule.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Schedule.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Schedule where - -import qualified Data.Text.Lazy.Builder as Builder -import qualified Saturn.Unstable.Type.Day as Day -import qualified Saturn.Unstable.Type.Hour as Hour -import qualified Saturn.Unstable.Type.Minute as Minute -import qualified Saturn.Unstable.Type.Month as Month -import qualified Saturn.Unstable.Type.Weekday as Weekday -import qualified Text.Parsec as Parsec - -data Schedule = Schedule - { minute :: Minute.Minute, - hour :: Hour.Hour, - day :: Day.Day, - month :: Month.Month, - weekday :: Weekday.Weekday - } - deriving (Eq, Show) - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Schedule -parsec = - Schedule - <$> Minute.parsec - <* Parsec.skipMany1 (Parsec.char ' ') - <*> Hour.parsec - <* Parsec.skipMany1 (Parsec.char ' ') - <*> Day.parsec - <* Parsec.skipMany1 (Parsec.char ' ') - <*> Month.parsec - <* Parsec.skipMany1 (Parsec.char ' ') - <*> Weekday.parsec - -toBuilder :: Schedule -> Builder.Builder -toBuilder schedule = - Minute.toBuilder (minute schedule) - <> Builder.singleton ' ' - <> Hour.toBuilder (hour schedule) - <> Builder.singleton ' ' - <> Day.toBuilder (day schedule) - <> Builder.singleton ' ' - <> Month.toBuilder (month schedule) - <> Builder.singleton ' ' - <> Weekday.toBuilder (weekday schedule) diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Weekday.hs b/source/libraries/unstable/Saturn/Unstable/Type/Weekday.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Weekday.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Weekday where - -import qualified Data.Coerce as Coerce -import qualified Data.Set as Set -import qualified Data.Text.Lazy.Builder as Builder -import qualified Data.Word as Word -import qualified Saturn.Unstable.Type.Field as Field -import qualified Text.Parsec as Parsec - -newtype Weekday - = Weekday Field.Field - deriving (Eq, Show) - -bounds :: (Word.Word8, Word.Word8) -bounds = (0, 6) - -fromField :: Field.Field -> Maybe Weekday -fromField field = - if Field.isValid bounds field then Just $ Weekday field else Nothing - -toField :: Weekday -> Field.Field -toField = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Weekday -parsec = do - field <- Field.parsec - maybe (fail "invalid Weekday") pure $ fromField field - -toBuilder :: Weekday -> Builder.Builder -toBuilder = Field.toBuilder . toField - -expand :: Weekday -> Set.Set Word.Word8 -expand = Field.expand bounds . toField - -isMatch :: Word.Word8 -> Weekday -> Bool -isMatch word8 = Set.member word8 . expand diff --git a/source/libraries/unstable/Saturn/Unstable/Type/Wildcard.hs b/source/libraries/unstable/Saturn/Unstable/Type/Wildcard.hs deleted file mode 100644 --- a/source/libraries/unstable/Saturn/Unstable/Type/Wildcard.hs +++ /dev/null @@ -1,24 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module Saturn.Unstable.Type.Wildcard where - -import qualified Control.Monad as Monad -import qualified Data.Coerce as Coerce -import qualified Data.Text.Lazy.Builder as Builder -import qualified Text.Parsec as Parsec - -newtype Wildcard - = Wildcard () - deriving (Eq, Show) - -fromUnit :: () -> Wildcard -fromUnit = Coerce.coerce - -toUnit :: Wildcard -> () -toUnit = Coerce.coerce - -parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Wildcard -parsec = fmap fromUnit . Monad.void $ Parsec.char '*' - -toBuilder :: Wildcard -> Builder.Builder -toBuilder = const $ Builder.singleton '*' diff --git a/source/library/Saturn.hs b/source/library/Saturn.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn.hs @@ -0,0 +1,71 @@ +-- | Saturn handles POSIX cron schedules, which are defined here: +-- . +-- +-- A cron schedule is specified with five fields, each separated with at least +-- one space. Each field can either be a wildcard (represented by an asterisk), +-- or it can be one or more elements separated by commas. Each element can +-- either be a number or a range, which is two numbers separated by a hyphen. +-- +-- In order, the fields represent: +-- +-- 1. Minute, between 0 and 59. +-- 2. Hour, between 0 and 23. +-- 3. Day, between 1 and 31. +-- 4. Month, between 1 and 12. +-- 5. Weekday, between 0 and 6 where 0 represents Sunday. +-- +-- Here is a more graphical representation of the fields: +-- +-- > +--------- Minute +-- > | +------- Hour +-- > | | +----- Day +-- > | | | +--- Month +-- > | | | | +- Weekday +-- > | | | | | +-- > "* * * * *" +-- +-- To get started, use 'Parse.fromText' to parse a 'Schedule.Schedule'. Then +-- use 'Render.toText' to render it again. To see if the 'Schedule.Schedule' +-- matches a certain time, use 'Match.isMatch'. To get the next time that +-- matches a schedule, use 'Match.nextMatch'. +-- +-- >>> :set -XOverloadedStrings +-- >>> let Right schedule = fromText "* * * * *" +-- >>> toText schedule +-- "* * * * *" +-- >>> let utcTime = Data.Time.UTCTime (Data.Time.fromGregorian 1970 1 1) 0 +-- >>> isMatch utcTime schedule +-- True +-- >>> nextMatch utcTime schedule +-- Just 1970-01-01 00:01:00 UTC +module Saturn + ( -- * Types + Schedule.Schedule, + Constant.everyMinute, + Constant.hourly, + Constant.daily, + Constant.weekly, + Constant.monthly, + Constant.yearly, + + -- * Parsing + Parse.fromText, + Parse.fromLazyText, + Parse.fromString, + + -- * Rendering + Render.toText, + Render.toLazyText, + Render.toString, + + -- * Matching + Match.isMatch, + Match.nextMatch, + ) +where + +import qualified Saturn.Unstable.Constant as Constant +import qualified Saturn.Unstable.Match as Match +import qualified Saturn.Unstable.Parse as Parse +import qualified Saturn.Unstable.Render as Render +import qualified Saturn.Unstable.Type.Schedule as Schedule diff --git a/source/library/Saturn/Unstable/Constant.hs b/source/library/Saturn/Unstable/Constant.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Constant.hs @@ -0,0 +1,96 @@ +module Saturn.Unstable.Constant where + +import qualified Data.Maybe as Maybe +import qualified Saturn.Unstable.Type.Day as Day +import qualified Saturn.Unstable.Type.Element as Element +import qualified Saturn.Unstable.Type.Field as Field +import qualified Saturn.Unstable.Type.Hour as Hour +import qualified Saturn.Unstable.Type.Minute as Minute +import qualified Saturn.Unstable.Type.Month as Month +import qualified Saturn.Unstable.Type.Number as Number +import qualified Saturn.Unstable.Type.Schedule as Schedule +import qualified Saturn.Unstable.Type.Weekday as Weekday +import qualified Saturn.Unstable.Type.Wildcard as Wildcard + +-- | > "* * * * *" +everyMinute :: Schedule.Schedule +everyMinute = Maybe.fromMaybe (error "Saturn.Unstable.Constant.everyMinute") $ do + let wildcard = Field.fromEither . Left $ Wildcard.fromUnit () + minute <- Minute.fromField wildcard + hour <- Hour.fromField wildcard + day <- Day.fromField wildcard + month <- Month.fromField wildcard + weekday <- Weekday.fromField wildcard + pure + Schedule.Schedule + { Schedule.minute = minute, + Schedule.hour = hour, + Schedule.day = day, + Schedule.month = month, + Schedule.weekday = weekday + } + +-- | > "0 * * * *" +hourly :: Schedule.Schedule +hourly = Maybe.fromMaybe (error "Saturn.Unstable.Constant.hourly") $ do + minute <- + Minute.fromField + . Field.fromEither + . Right + . pure + . Element.fromEither + . Right + $ Number.fromWord8 0 + pure everyMinute {Schedule.minute = minute} + +-- | > "0 0 * * *" +daily :: Schedule.Schedule +daily = Maybe.fromMaybe (error "Saturn.Unstable.Constant.daily") $ do + hour <- + Hour.fromField + . Field.fromEither + . Right + . pure + . Element.fromEither + . Right + $ Number.fromWord8 0 + pure hourly {Schedule.hour = hour} + +-- | > "0 0 * * 0" +weekly :: Schedule.Schedule +weekly = Maybe.fromMaybe (error "Saturn.Unstable.Constant.weekly") $ do + weekday <- + Weekday.fromField + . Field.fromEither + . Right + . pure + . Element.fromEither + . Right + $ Number.fromWord8 0 + pure daily {Schedule.weekday = weekday} + +-- | > "0 0 1 * *" +monthly :: Schedule.Schedule +monthly = Maybe.fromMaybe (error "Saturn.Unstable.Constant.monthly") $ do + day <- + Day.fromField + . Field.fromEither + . Right + . pure + . Element.fromEither + . Right + $ Number.fromWord8 1 + pure daily {Schedule.day = day} + +-- | > "0 0 1 1 *" +yearly :: Schedule.Schedule +yearly = Maybe.fromMaybe (error "Saturn.Unstable.Constant.yearly") $ do + month <- + Month.fromField + . Field.fromEither + . Right + . pure + . Element.fromEither + . Right + $ Number.fromWord8 1 + pure monthly {Schedule.month = month} diff --git a/source/library/Saturn/Unstable/ConstantSpec.hs b/source/library/Saturn/Unstable/ConstantSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/ConstantSpec.hs @@ -0,0 +1,31 @@ +module Saturn.Unstable.ConstantSpec where + +import qualified Heck +import qualified Saturn.Unstable.Constant as Constant +import qualified Saturn.Unstable.Render as Render + +spec :: (Applicative m, Monad n) => Heck.Test m n -> n () +spec t = Heck.describe t "Saturn.Unstable.Constant" $ do + Heck.describe t "everyMinute" $ do + Heck.it t "renders correctly" $ do + Heck.assertEq t "* * * * *" (Render.toString Constant.everyMinute) + + Heck.describe t "hourly" $ do + Heck.it t "renders correctly" $ do + Heck.assertEq t "0 * * * *" (Render.toString Constant.hourly) + + Heck.describe t "daily" $ do + Heck.it t "renders correctly" $ do + Heck.assertEq t "0 0 * * *" (Render.toString Constant.daily) + + Heck.describe t "weekly" $ do + Heck.it t "renders correctly" $ do + Heck.assertEq t "0 0 * * 0" (Render.toString Constant.weekly) + + Heck.describe t "monthly" $ do + Heck.it t "renders correctly" $ do + Heck.assertEq t "0 0 1 * *" (Render.toString Constant.monthly) + + Heck.describe t "yearly" $ do + Heck.it t "renders correctly" $ do + Heck.assertEq t "0 0 1 1 *" (Render.toString Constant.yearly) diff --git a/source/library/Saturn/Unstable/Extra/Int.hs b/source/library/Saturn/Unstable/Extra/Int.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/Int.hs @@ -0,0 +1,10 @@ +module Saturn.Unstable.Extra.Int where + +import qualified Data.Bits as Bits +import qualified Data.Word as Word + +fromWord8 :: Word.Word8 -> Int +fromWord8 = fromIntegral + +toWord8 :: Int -> Maybe Word.Word8 +toWord8 = Bits.toIntegralSized diff --git a/source/library/Saturn/Unstable/Extra/IntSpec.hs b/source/library/Saturn/Unstable/Extra/IntSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/IntSpec.hs @@ -0,0 +1,23 @@ +module Saturn.Unstable.Extra.IntSpec where + +import qualified Heck +import qualified Saturn.Unstable.Extra.Int as Int + +spec :: (Applicative m, Monad n) => Heck.Test m n -> n () +spec t = Heck.describe t "Saturn.Unstable.Extra.Int" $ do + Heck.describe t "fromWord8" $ do + Heck.it t "works" $ do + Heck.assertEq t (Int.fromWord8 0) 0 + + Heck.describe t "toWord8" $ do + Heck.it t "succeeds with minimum" $ do + Heck.assertEq t (Int.toWord8 0) (Just 0) + + Heck.it t "succeeds with maximum" $ do + Heck.assertEq t (Int.toWord8 255) (Just 255) + + Heck.it t "fails below minimum" $ do + Heck.assertEq t (Int.toWord8 (-1)) Nothing + + Heck.it t "fails above maximum" $ do + Heck.assertEq t (Int.toWord8 256) Nothing diff --git a/source/library/Saturn/Unstable/Extra/Ord.hs b/source/library/Saturn/Unstable/Extra/Ord.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/Ord.hs @@ -0,0 +1,4 @@ +module Saturn.Unstable.Extra.Ord where + +within :: (Ord a) => (a, a) -> a -> Bool +within (lo, hi) x = lo <= x && x <= hi diff --git a/source/library/Saturn/Unstable/Extra/OrdSpec.hs b/source/library/Saturn/Unstable/Extra/OrdSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/OrdSpec.hs @@ -0,0 +1,22 @@ +module Saturn.Unstable.Extra.OrdSpec where + +import qualified Heck +import qualified Saturn.Unstable.Extra.Ord as Ord + +spec :: (Applicative m, Monad n) => Heck.Test m n -> n () +spec t = Heck.describe t "Saturn.Unstable.Extra.Ord" $ do + Heck.describe t "within" $ do + Heck.it t "fails below lower bound" $ do + Heck.assertEq t False (Ord.within ('b', 'd') 'a') + + Heck.it t "succeeds at lower bound" $ do + Heck.assertEq t True (Ord.within ('b', 'd') 'b') + + Heck.it t "succeeds within bounds" $ do + Heck.assertEq t True (Ord.within ('b', 'd') 'c') + + Heck.it t "succeeds at upper bound" $ do + Heck.assertEq t True (Ord.within ('b', 'd') 'd') + + Heck.it t "fails above upper bound" $ do + Heck.assertEq t False (Ord.within ('b', 'd') 'e') diff --git a/source/library/Saturn/Unstable/Extra/Parsec.hs b/source/library/Saturn/Unstable/Extra/Parsec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/Parsec.hs @@ -0,0 +1,16 @@ +module Saturn.Unstable.Extra.Parsec where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Text.Parsec as Parsec + +either :: + Parsec.ParsecT s u m a -> + Parsec.ParsecT s u m b -> + Parsec.ParsecT s u m (Either a b) +either l r = fmap Left l Parsec.<|> fmap Right r + +sepByNE :: + Parsec.ParsecT s u m a -> + Parsec.ParsecT s u m sep -> + Parsec.ParsecT s u m (NonEmpty.NonEmpty a) +sepByNE p s = (NonEmpty.:|) <$> p <*> Parsec.many (s *> p) diff --git a/source/library/Saturn/Unstable/Extra/ParsecSpec.hs b/source/library/Saturn/Unstable/Extra/ParsecSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/ParsecSpec.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Extra.ParsecSpec where + +import qualified Data.Either as Either +import qualified Data.List.NonEmpty as NonEmpty +import qualified Heck +import qualified Saturn.Unstable.Extra.Parsec as Parsec +import qualified Text.Parsec as Parsec + +spec :: (Applicative m, Monad n) => Heck.Test m n -> n () +spec t = Heck.describe t "Saturn.Unstable.Extra.Parsec" $ do + Heck.describe t "either" $ do + let parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m (Either Char Char) + parsec = Parsec.either (Parsec.char 'a') (Parsec.char 'b') + + Heck.it t "succeeds with left" $ do + Heck.assertEq t (Right (Left 'a')) (Parsec.parse parsec "" "a") + + Heck.it t "succeeds with right" $ do + Heck.assertEq t (Right (Right 'b')) (Parsec.parse parsec "" "b") + + Heck.it t "fails with neither" $ do + Heck.assertEq t True (Either.isLeft (Parsec.parse parsec "" "c")) + + Heck.describe t "sepByNE" $ do + let parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m (NonEmpty.NonEmpty Char) + parsec = Parsec.sepByNE (Parsec.char 'a') (Parsec.char ' ') + + Heck.it t "succeeds with one" $ do + Heck.assertEq t (Right ('a' NonEmpty.:| [])) (Parsec.parse parsec "" "a") + + Heck.it t "succeeds with many" $ do + Heck.assertEq t (Right ('a' NonEmpty.:| "a")) (Parsec.parse parsec "" "a a") + + Heck.it t "fails with none" $ do + Heck.assertEq t True (Either.isLeft (Parsec.parse parsec "" "")) diff --git a/source/library/Saturn/Unstable/Extra/Time.hs b/source/library/Saturn/Unstable/Extra/Time.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/Time.hs @@ -0,0 +1,14 @@ +module Saturn.Unstable.Extra.Time where + +import qualified Data.Time as Time +import qualified Data.Word as Word + +dayOfWeekToWord8 :: Time.DayOfWeek -> Word.Word8 +dayOfWeekToWord8 dayOfWeek = case dayOfWeek of + Time.Sunday -> 0 + Time.Monday -> 1 + Time.Tuesday -> 2 + Time.Wednesday -> 3 + Time.Thursday -> 4 + Time.Friday -> 5 + Time.Saturday -> 6 diff --git a/source/library/Saturn/Unstable/Extra/TimeSpec.hs b/source/library/Saturn/Unstable/Extra/TimeSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/TimeSpec.hs @@ -0,0 +1,29 @@ +module Saturn.Unstable.Extra.TimeSpec where + +import qualified Data.Time as Time +import qualified Heck +import qualified Saturn.Unstable.Extra.Time as Time + +spec :: (Applicative m, Monad n) => Heck.Test m n -> n () +spec t = Heck.describe t "Saturn.Unstable.Extra.Time" $ do + Heck.describe t "dayOfWeekToWord8" $ do + Heck.it t "works with Sunday" $ do + Heck.assertEq t 0 (Time.dayOfWeekToWord8 Time.Sunday) + + Heck.it t "works with Monday" $ do + Heck.assertEq t 1 (Time.dayOfWeekToWord8 Time.Monday) + + Heck.it t "works with Tuesday" $ do + Heck.assertEq t 2 (Time.dayOfWeekToWord8 Time.Tuesday) + + Heck.it t "works with Wednesday" $ do + Heck.assertEq t 3 (Time.dayOfWeekToWord8 Time.Wednesday) + + Heck.it t "works with Thursday" $ do + Heck.assertEq t 4 (Time.dayOfWeekToWord8 Time.Thursday) + + Heck.it t "works with Friday" $ do + Heck.assertEq t 5 (Time.dayOfWeekToWord8 Time.Friday) + + Heck.it t "works with Saturday" $ do + Heck.assertEq t 6 (Time.dayOfWeekToWord8 Time.Saturday) diff --git a/source/library/Saturn/Unstable/Extra/Tuple.hs b/source/library/Saturn/Unstable/Extra/Tuple.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/Tuple.hs @@ -0,0 +1,9 @@ +module Saturn.Unstable.Extra.Tuple where + +import qualified Data.Bifunctor as Bifunctor + +mapBoth :: (a -> b) -> (a, a) -> (b, b) +mapBoth f = Bifunctor.bimap f f + +toSequence :: (Enum a) => (a, a) -> [a] +toSequence = uncurry enumFromTo diff --git a/source/library/Saturn/Unstable/Extra/TupleSpec.hs b/source/library/Saturn/Unstable/Extra/TupleSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Extra/TupleSpec.hs @@ -0,0 +1,20 @@ +module Saturn.Unstable.Extra.TupleSpec where + +import qualified Heck +import qualified Saturn.Unstable.Extra.Tuple as Tuple + +spec :: (Applicative m, Monad n) => Heck.Test m n -> n () +spec t = Heck.describe t "Saturn.Unstable.Extra.Tuple" $ do + Heck.describe t "mapBoth" $ do + Heck.it t "works" $ do + Heck.assertEq t ('B', 'b') (Tuple.mapBoth succ ('A', 'a')) + + Heck.describe t "toSequence" $ do + Heck.it t "works" $ do + Heck.assertEq t "bcd" (Tuple.toSequence ('b', 'd')) + + Heck.it t "works with singleton" $ do + Heck.assertEq t "a" (Tuple.toSequence ('a', 'a')) + + Heck.it t "works with empty" $ do + Heck.assertEq t "" (Tuple.toSequence ('b', 'a')) diff --git a/source/library/Saturn/Unstable/Match.hs b/source/library/Saturn/Unstable/Match.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Match.hs @@ -0,0 +1,89 @@ +module Saturn.Unstable.Match where + +import qualified Control.Monad as Monad +import qualified Data.List as List +import qualified Data.Maybe as Maybe +import qualified Data.Set as Set +import qualified Data.Time as Time +import qualified Saturn.Unstable.Extra.Int as Int +import qualified Saturn.Unstable.Extra.Time as Time +import qualified Saturn.Unstable.Type.Day as Day +import qualified Saturn.Unstable.Type.Field as Field +import qualified Saturn.Unstable.Type.Hour as Hour +import qualified Saturn.Unstable.Type.Minute as Minute +import qualified Saturn.Unstable.Type.Month as Month +import qualified Saturn.Unstable.Type.Schedule as Schedule +import qualified Saturn.Unstable.Type.Weekday as Weekday +import qualified Saturn.Unstable.Type.Wildcard as Wildcard + +-- | Returns 'True' if the given 'Time.UTCTime' matches the given +-- 'Schedule.Schedule', otherwise returns 'False'. +isMatch :: Time.UTCTime -> Schedule.Schedule -> Bool +isMatch utcTime schedule = Maybe.fromMaybe False $ do + let time = Time.pastMidnight $ Time.utctDayTime utcTime + minute <- Int.toWord8 $ Time.todMin time + Monad.guard . Minute.isMatch minute $ Schedule.minute schedule + + hour <- Int.toWord8 $ Time.todHour time + Monad.guard . Hour.isMatch hour $ Schedule.hour schedule + + let date = Time.utctDay utcTime + let (_, monthOfYear, dayOfMonth) = Time.toGregorian date + month <- Int.toWord8 monthOfYear + Monad.guard . Month.isMatch month $ Schedule.month schedule + + day <- Int.toWord8 dayOfMonth + let dayMatches = Day.isMatch day $ Schedule.day schedule + let weekday = Time.dayOfWeekToWord8 $ Time.dayOfWeek date + let weekdayMatches = Weekday.isMatch weekday $ Schedule.weekday schedule + Monad.guard $ + if dayIsWildcard schedule || weekdayIsWildcard schedule + then dayMatches && weekdayMatches + else dayMatches || weekdayMatches + + pure True + +dayIsWildcard :: Schedule.Schedule -> Bool +dayIsWildcard = Field.isWildcard . Day.toField . Schedule.day + +weekdayIsWildcard :: Schedule.Schedule -> Bool +weekdayIsWildcard = Field.isWildcard . Weekday.toField . Schedule.weekday + +-- | Looks for the first time after the given 'Time.UTCTime' that matches the +-- given 'Schedule.Schedule'. Returns 'Nothing' if the 'Schedule.Schedule' only +-- matches dates that cannot happen, like February 30th. +nextMatch :: Time.UTCTime -> Schedule.Schedule -> Maybe Time.UTCTime +nextMatch utcTime schedule = + if dayIsWildcard schedule || weekdayIsWildcard schedule + then incompleteNextMatch utcTime schedule + else do + let wildcard = Field.fromEither . Left $ Wildcard.fromUnit () + day <- Day.fromField wildcard + weekday <- Weekday.fromField wildcard + Maybe.listToMaybe . List.sort $ + Maybe.catMaybes + [ incompleteNextMatch utcTime schedule {Schedule.day = day}, + incompleteNextMatch utcTime schedule {Schedule.weekday = weekday} + ] + +incompleteNextMatch :: Time.UTCTime -> Schedule.Schedule -> Maybe Time.UTCTime +incompleteNextMatch utcTime schedule = Maybe.listToMaybe $ do + let oldDate = Time.utctDay utcTime + let (oldYear, _, _) = Time.toGregorian oldDate + year <- [oldYear .. oldYear + 8] + month <- fmap Int.fromWord8 . Set.toAscList . Month.expand $ Schedule.month schedule + day <- fmap Int.fromWord8 . Set.toAscList . Day.expand $ Schedule.day schedule + date <- Maybe.maybeToList $ Time.fromGregorianValid year month day + Monad.guard $ date >= oldDate + Monad.guard + . Set.member (Time.dayOfWeekToWord8 $ Time.dayOfWeek date) + . Weekday.expand + $ Schedule.weekday schedule + hour <- fmap Int.fromWord8 . Set.toAscList . Hour.expand $ Schedule.hour schedule + minute <- fmap Int.fromWord8 . Set.toAscList . Minute.expand $ Schedule.minute schedule + time <- + fmap Time.sinceMidnight + . Maybe.maybeToList + $ Time.makeTimeOfDayValid hour minute 0 + Monad.when (date == oldDate) . Monad.guard $ time > Time.utctDayTime utcTime + pure Time.UTCTime {Time.utctDay = date, Time.utctDayTime = time} diff --git a/source/library/Saturn/Unstable/MatchSpec.hs b/source/library/Saturn/Unstable/MatchSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/MatchSpec.hs @@ -0,0 +1,503 @@ +module Saturn.Unstable.MatchSpec where + +import qualified Data.Fixed as Fixed +import qualified Data.Time as Time +import qualified Data.Time.Calendar.WeekDate as Time +import qualified Heck +import qualified Saturn.Unstable.Match as Match +import qualified Saturn.Unstable.Type.ScheduleSpec as ScheduleSpec +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck + +spec :: (Monad n) => Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Match" $ do + Heck.describe t "isMatch" $ do + Heck.it t "is always true with all wildcards" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch utcTime + + Heck.it t "is true when day or weekday matches" $ do + s <- ScheduleSpec.new [] [] [[5]] [] [[5]] + t1 <- newUtcTime 1970 1 5 0 0 0 + s `Hspec.shouldSatisfy` Match.isMatch t1 + t2 <- newUtcTime 1970 1 2 0 0 0 + s `Hspec.shouldSatisfy` Match.isMatch t2 + + Heck.describe t "minute" $ do + Heck.it t "is always true when a number matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [[5]] [] [] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withMinute 5 utcTime) + + Heck.it t "is always true when a range matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [[4, 5]] [] [] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withMinute 5 utcTime) + + Heck.it t "is always true when a choice matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [[4], [5]] [] [] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withMinute 5 utcTime) + + Heck.it t "is true when a number matches" $ do + x <- newUtcTime 1970 1 1 0 5 0 + s <- ScheduleSpec.new [[5]] [] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a number does not match" $ do + x <- newUtcTime 1970 1 1 0 6 0 + s <- ScheduleSpec.new [[5]] [] [] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a range matches" $ do + x <- newUtcTime 1970 1 1 0 5 0 + s <- ScheduleSpec.new [[4, 5]] [] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a range does not match" $ do + x <- newUtcTime 1970 1 1 0 6 0 + s <- ScheduleSpec.new [[4, 5]] [] [] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a choice matches" $ do + x <- newUtcTime 1970 1 1 0 5 0 + s <- ScheduleSpec.new [[4], [5]] [] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a choice does not match" $ do + x <- newUtcTime 1970 1 1 0 6 0 + s <- ScheduleSpec.new [[4], [5]] [] [] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "accepts any second" $ do + x <- newUtcTime 1970 1 1 0 5 6 + s <- ScheduleSpec.new [[5]] [] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any hour" $ do + x <- newUtcTime 1970 1 1 6 5 0 + s <- ScheduleSpec.new [[5]] [] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any day" $ do + x <- newUtcTime 1970 1 6 0 5 0 + s <- ScheduleSpec.new [[5]] [] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any month" $ do + x <- newUtcTime 1970 6 1 0 5 0 + s <- ScheduleSpec.new [[5]] [] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.describe t "hour" $ do + Heck.it t "is always true when a number matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [[5]] [] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withHour 5 utcTime) + + Heck.it t "is always true when a range matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [[4, 5]] [] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withHour 5 utcTime) + + Heck.it t "is always true when a choice matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [[4], [5]] [] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withHour 5 utcTime) + + Heck.it t "is true when a number matches" $ do + x <- newUtcTime 1970 1 1 5 0 0 + s <- ScheduleSpec.new [] [[5]] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a number does not match" $ do + x <- newUtcTime 1970 1 1 6 0 0 + s <- ScheduleSpec.new [] [[5]] [] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a range matches" $ do + x <- newUtcTime 1970 1 1 5 0 0 + s <- ScheduleSpec.new [] [[4, 5]] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a range does not match" $ do + x <- newUtcTime 1970 1 1 6 0 0 + s <- ScheduleSpec.new [] [[4, 5]] [] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a choice matches" $ do + x <- newUtcTime 1970 1 1 5 0 0 + s <- ScheduleSpec.new [] [[4], [5]] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a choice does not match" $ do + x <- newUtcTime 1970 1 1 6 0 0 + s <- ScheduleSpec.new [] [[4], [5]] [] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "accepts any second" $ do + x <- newUtcTime 1970 1 1 5 0 6 + s <- ScheduleSpec.new [] [[5]] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any minute" $ do + x <- newUtcTime 1970 1 1 5 6 0 + s <- ScheduleSpec.new [] [[5]] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any day" $ do + x <- newUtcTime 1970 1 6 5 0 0 + s <- ScheduleSpec.new [] [[5]] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any month" $ do + x <- newUtcTime 1970 6 1 5 0 0 + s <- ScheduleSpec.new [] [[5]] [] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.describe t "day" $ do + Heck.it t "is always true when a number matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [[5]] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfMonth 5 utcTime) + + Heck.it t "is always true when a range matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [[4, 5]] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfMonth 5 utcTime) + + Heck.it t "is always true when a choice matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [[4], [5]] [] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfMonth 5 utcTime) + + Heck.it t "is true when a number matches" $ do + x <- newUtcTime 1970 1 5 0 0 0 + s <- ScheduleSpec.new [] [] [[5]] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a number does not match" $ do + x <- newUtcTime 1970 1 6 0 0 0 + s <- ScheduleSpec.new [] [] [[5]] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a range matches" $ do + x <- newUtcTime 1970 1 5 0 0 0 + s <- ScheduleSpec.new [] [] [[4, 5]] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a range does not match" $ do + x <- newUtcTime 1970 1 6 0 0 0 + s <- ScheduleSpec.new [] [] [[4, 5]] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a choice matches" $ do + x <- newUtcTime 1970 1 5 0 0 0 + s <- ScheduleSpec.new [] [] [[4], [5]] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a choice does not match" $ do + x <- newUtcTime 1970 1 6 0 0 0 + s <- ScheduleSpec.new [] [] [[4], [5]] [] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "accepts any second" $ do + x <- newUtcTime 1970 1 5 0 0 6 + s <- ScheduleSpec.new [] [] [[5]] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any minute" $ do + x <- newUtcTime 1970 1 5 0 6 0 + s <- ScheduleSpec.new [] [] [[5]] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any hour" $ do + x <- newUtcTime 1970 1 5 6 0 0 + s <- ScheduleSpec.new [] [] [[5]] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any month" $ do + x <- newUtcTime 1970 6 5 0 0 0 + s <- ScheduleSpec.new [] [] [[5]] [] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.describe t "month" $ do + Heck.it t "is always true when a number matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [] [[5]] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withMonthOfYear 5 utcTime) + + Heck.it t "is always true when a range matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [] [[4, 5]] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withMonthOfYear 5 utcTime) + + Heck.it t "is always true when a choice matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [] [[4], [5]] [] + schedule `Hspec.shouldSatisfy` Match.isMatch (withMonthOfYear 5 utcTime) + + Heck.it t "is true when a number matches" $ do + x <- newUtcTime 1970 5 1 0 0 0 + s <- ScheduleSpec.new [] [] [] [[5]] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a number does not match" $ do + x <- newUtcTime 1970 6 1 0 0 0 + s <- ScheduleSpec.new [] [] [] [[5]] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a range matches" $ do + x <- newUtcTime 1970 5 1 0 0 0 + s <- ScheduleSpec.new [] [] [] [[4, 5]] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a range does not match" $ do + x <- newUtcTime 1970 6 1 0 0 0 + s <- ScheduleSpec.new [] [] [] [[4, 5]] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a choice matches" $ do + x <- newUtcTime 1970 5 1 0 0 0 + s <- ScheduleSpec.new [] [] [] [[4], [5]] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a choice does not match" $ do + x <- newUtcTime 1970 6 1 0 0 0 + s <- ScheduleSpec.new [] [] [] [[4], [5]] [] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "accepts any second" $ do + x <- newUtcTime 1970 5 1 0 0 6 + s <- ScheduleSpec.new [] [] [] [[5]] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any minute" $ do + x <- newUtcTime 1970 5 1 0 6 0 + s <- ScheduleSpec.new [] [] [] [[5]] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any hour" $ do + x <- newUtcTime 1970 5 1 6 0 0 + s <- ScheduleSpec.new [] [] [] [[5]] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any day" $ do + x <- newUtcTime 1970 5 6 0 0 0 + s <- ScheduleSpec.new [] [] [] [[5]] [] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.describe t "weekday" $ do + Heck.it t "is always true when a number matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [] [] [[5]] + schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfWeek Time.Friday utcTime) + + Heck.it t "is always true when a range matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [] [] [[4, 5]] + schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfWeek Time.Friday utcTime) + + Heck.it t "is always true when a choice matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \utcTime -> do + schedule <- ScheduleSpec.new [] [] [] [] [[4], [5]] + schedule `Hspec.shouldSatisfy` Match.isMatch (withDayOfWeek Time.Friday utcTime) + + Heck.it t "is true when a number matches" $ do + x <- newUtcTime 1970 1 2 0 0 0 + s <- ScheduleSpec.new [] [] [] [] [[5]] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a number does not match" $ do + x <- newUtcTime 1970 1 3 0 0 0 + s <- ScheduleSpec.new [] [] [] [] [[5]] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a range matches" $ do + x <- newUtcTime 1970 1 2 0 0 0 + s <- ScheduleSpec.new [] [] [] [] [[4, 5]] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a range does not match" $ do + x <- newUtcTime 1970 1 3 0 0 0 + s <- ScheduleSpec.new [] [] [] [] [[4, 5]] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "is true when a choice matches" $ do + x <- newUtcTime 1970 1 2 0 0 0 + s <- ScheduleSpec.new [] [] [] [] [[4], [5]] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "is false when a choice does not match" $ do + x <- newUtcTime 1970 1 3 0 0 0 + s <- ScheduleSpec.new [] [] [] [] [[4], [5]] + s `Hspec.shouldNotSatisfy` Match.isMatch x + + Heck.it t "accepts any second" $ do + x <- newUtcTime 1970 1 2 0 0 6 + s <- ScheduleSpec.new [] [] [] [] [[5]] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any minute" $ do + x <- newUtcTime 1970 1 2 0 6 0 + s <- ScheduleSpec.new [] [] [] [] [[5]] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any hour" $ do + x <- newUtcTime 1970 1 2 6 0 0 + s <- ScheduleSpec.new [] [] [] [] [[5]] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.it t "accepts any day" $ do + x <- newUtcTime 1970 1 9 0 0 0 + s <- ScheduleSpec.new [] [] [] [] [[5]] + s `Hspec.shouldSatisfy` Match.isMatch x + + Heck.describe t "nextMatch" $ do + Heck.it t "succeeds with a leap day" $ do + s <- ScheduleSpec.new [[0]] [[0]] [[29]] [[2]] [] + t1 <- newUtcTime 1970 1 1 0 0 0 + t2 <- newUtcTime 1972 2 29 0 0 0 + Match.nextMatch t1 s `Hspec.shouldBe` Just t2 + + Heck.it t "succeeds with the next leap day" $ do + s <- ScheduleSpec.new [[0]] [[0]] [[29]] [[2]] [] + t1 <- newUtcTime 1972 2 29 0 0 0 + t2 <- newUtcTime 1976 2 29 0 0 0 + Match.nextMatch t1 s `Hspec.shouldBe` Just t2 + + Heck.it t "succeeds with the furthest leap day" $ do + s <- ScheduleSpec.new [[0]] [[0]] [[29]] [[2]] [] + t1 <- newUtcTime 1896 2 29 0 0 0 + t2 <- newUtcTime 1904 2 29 0 0 0 + Match.nextMatch t1 s `Hspec.shouldBe` Just t2 + + Heck.it t "fails with an impossible date" $ do + s <- ScheduleSpec.new [[0]] [[0]] [[30]] [[2]] [] + x <- newUtcTime 1970 1 1 0 0 0 + Match.nextMatch x s `Hspec.shouldBe` Nothing + + Heck.it t "is always in the future" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \t1 -> do + schedule <- ScheduleSpec.new [] [] [] [] [] + t2 <- maybe (fail "impossible") pure $ Match.nextMatch t1 schedule + t2 `Hspec.shouldSatisfy` (>= t1) + + Heck.it t "always matches" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitraryUtcTime shrinkUtcTime + $ \t1 -> do + schedule <- ScheduleSpec.new [] [] [] [] [] + t2 <- maybe (fail "impossible") pure $ Match.nextMatch t1 schedule + schedule `Hspec.shouldSatisfy` Match.isMatch t2 + +withMinute :: Int -> Time.UTCTime -> Time.UTCTime +withMinute minute = overTimeOfDay $ \timeOfDay -> timeOfDay {Time.todMin = minute} + +withHour :: Int -> Time.UTCTime -> Time.UTCTime +withHour hour = overTimeOfDay $ \timeOfDay -> timeOfDay {Time.todHour = hour} + +overTimeOfDay :: (Time.TimeOfDay -> Time.TimeOfDay) -> Time.UTCTime -> Time.UTCTime +overTimeOfDay f utcTime = + utcTime + { Time.utctDayTime = + Time.sinceMidnight . f . Time.pastMidnight $ Time.utctDayTime utcTime + } + +withDayOfMonth :: Time.DayOfMonth -> Time.UTCTime -> Time.UTCTime +withDayOfMonth dayOfMonth = overDay $ \day -> + let (year, monthOfYear, _) = Time.toGregorian day + in Time.fromGregorian year monthOfYear dayOfMonth + +withMonthOfYear :: Time.MonthOfYear -> Time.UTCTime -> Time.UTCTime +withMonthOfYear monthOfYear = overDay $ \day -> + let (year, _, dayOfMonth) = Time.toGregorian day + in Time.fromGregorian year monthOfYear dayOfMonth + +withDayOfWeek :: Time.DayOfWeek -> Time.UTCTime -> Time.UTCTime +withDayOfWeek dayOfWeek = overDay $ \day -> + let fwt = Time.FirstWholeWeek + dow = Time.Sunday + (year, weekOfYear, _) = Time.toWeekCalendar fwt dow day + in Time.fromWeekCalendar fwt dow year weekOfYear dayOfWeek + +overDay :: (Time.Day -> Time.Day) -> Time.UTCTime -> Time.UTCTime +overDay f utcTime = utcTime {Time.utctDay = f $ Time.utctDay utcTime} + +newUtcTime :: + (MonadFail m) => + Time.Year -> + Time.MonthOfYear -> + Time.DayOfMonth -> + Int -> + Int -> + Fixed.Pico -> + m Time.UTCTime +newUtcTime year monthOfYear dayOfMonth hour minute second = do + day <- + maybe (fail "invalid Day") pure $ + Time.fromGregorianValid year monthOfYear dayOfMonth + timeOfDay <- + maybe (fail "invalid TimeOfDay") pure $ + Time.makeTimeOfDayValid hour minute second + pure + Time.UTCTime + { Time.utctDay = day, + Time.utctDayTime = Time.sinceMidnight timeOfDay + } + +arbitraryUtcTime :: QuickCheck.Gen Time.UTCTime +arbitraryUtcTime = + Time.UTCTime + <$> fmap Time.ModifiedJulianDay QuickCheck.arbitrary + <*> fmap Time.picosecondsToDiffTime (QuickCheck.chooseInteger (0, 86400000000000000 - 1)) + +shrinkUtcTime :: Time.UTCTime -> [Time.UTCTime] +shrinkUtcTime = + QuickCheck.shrinkMap + ( \(d, t) -> + Time.UTCTime + { Time.utctDay = Time.ModifiedJulianDay d, + Time.utctDayTime = Time.picosecondsToDiffTime t + } + ) + ( \x -> + ( Time.toModifiedJulianDay $ Time.utctDay x, + Time.diffTimeToPicoseconds $ Time.utctDayTime x + ) + ) diff --git a/source/library/Saturn/Unstable/Parse.hs b/source/library/Saturn/Unstable/Parse.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Parse.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Parse where + +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Saturn.Unstable.Type.Schedule as Schedule +import qualified Text.Parsec as Parsec + +-- | Parses a lazy 'LazyText.Text' value into a 'Schedule.Schedule'. See +-- 'fromText' for details. +fromLazyText :: LazyText.Text -> Either Parsec.ParseError Schedule.Schedule +fromLazyText = Parsec.parse parsec "" + +-- | Parses a 'String' into a 'Schedule.Schedule'. See 'fromText' for details. +fromString :: String -> Either Parsec.ParseError Schedule.Schedule +fromString = Parsec.parse parsec "" + +-- | Parses a strict 'Text.Text' value into a 'Schedule.Schedule'. The input +-- should have five fields, each separated by at least one space. Leading and +-- trailing spaces are allowed. +fromText :: Text.Text -> Either Parsec.ParseError Schedule.Schedule +fromText = Parsec.parse parsec "" + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Schedule.Schedule +parsec = + Parsec.skipMany (Parsec.char ' ') + *> Schedule.parsec + <* Parsec.skipMany (Parsec.char ' ') + <* Parsec.eof diff --git a/source/library/Saturn/Unstable/ParseSpec.hs b/source/library/Saturn/Unstable/ParseSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/ParseSpec.hs @@ -0,0 +1,214 @@ +module Saturn.Unstable.ParseSpec where + +import qualified Data.Either as Either +import qualified Heck +import qualified Saturn.Unstable.Parse as Parse +import qualified Saturn.Unstable.Type.ScheduleSpec as ScheduleSpec + +spec :: (MonadFail m, Monad n) => Heck.Test m n -> n () +spec t = Heck.describe t "Saturn.Unstable.Parse" $ do + Heck.describe t "fromString" $ do + Heck.it t "accepts wildcards" $ do + schedule <- ScheduleSpec.new [] [] [] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* * * * *") + + Heck.it t "accepts extra spaces" $ do + schedule <- ScheduleSpec.new [] [] [] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString " * * * * * ") + + Heck.it t "accepts numbers" $ do + schedule <- ScheduleSpec.new [[4]] [[3]] [[2]] [[1]] [[0]] + Heck.assertEq t (Right schedule) (Parse.fromString "4 3 2 1 0") + + Heck.it t "accepts ranges" $ do + schedule <- ScheduleSpec.new [[8, 9]] [[6, 7]] [[4, 5]] [[2, 3]] [[0, 1]] + Heck.assertEq t (Right schedule) (Parse.fromString "8-9 6-7 4-5 2-3 0-1") + + Heck.it t "accepts choices" $ do + schedule <- ScheduleSpec.new [[8], [9]] [[6], [7]] [[4], [5]] [[2], [3]] [[0], [1]] + Heck.assertEq t (Right schedule) (Parse.fromString "8,9 6,7 4,5 2,3 0,1") + + Heck.describe t "minute" $ do + Heck.it t "accepts a number" $ do + schedule <- ScheduleSpec.new [[0]] [] [] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "0 * * * *") + + Heck.it t "accepts a range" $ do + schedule <- ScheduleSpec.new [[0, 1]] [] [] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "0-1 * * * *") + + Heck.it t "accepts a choice" $ do + schedule <- ScheduleSpec.new [[0], [1]] [] [] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "0,1 * * * *") + + Heck.it t "rejects two wildcards" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "*,* * * * *")) + + Heck.it t "rejects a wildcard and a number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "*,0 * * * *")) + + Heck.it t "rejects a wildcard and a range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "*,0-0 * * * *")) + + Heck.it t "rejects an out of bounds number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "60 * * * *")) + + Heck.it t "rejects an out of bounds number as part of a choice" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "0,60 * * * *")) + + Heck.it t "rejects an out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "60-61 * * * *")) + + Heck.it t "rejects a half out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "0-60 * * * *")) + + Heck.it t "rejects a backwards range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "1-0 * * * *")) + + Heck.describe t "hour" $ do + Heck.it t "accepts a number" $ do + schedule <- ScheduleSpec.new [] [[0]] [] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* 0 * * *") + + Heck.it t "accepts a range" $ do + schedule <- ScheduleSpec.new [] [[0, 1]] [] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* 0-1 * * *") + + Heck.it t "accepts a choice" $ do + schedule <- ScheduleSpec.new [] [[0], [1]] [] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* 0,1 * * *") + + Heck.it t "rejects two wildcards" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* *,* * * *")) + + Heck.it t "rejects a wildcard and a number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* *,0 * * *")) + + Heck.it t "rejects a wildcard and a range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* *,0-0 * * *")) + + Heck.it t "rejects an out of bounds number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* 24 * * *")) + + Heck.it t "rejects an out of bounds number as part of a choice" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* 0,24 * * *")) + + Heck.it t "rejects an out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* 24-25 * * *")) + + Heck.it t "rejects a half out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* 0-24 * * *")) + + Heck.it t "rejects a backwards range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* 1-0 * * *")) + + Heck.describe t "day" $ do + Heck.it t "accepts a number" $ do + schedule <- ScheduleSpec.new [] [] [[1]] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* * 1 * *") + + Heck.it t "accepts a range" $ do + schedule <- ScheduleSpec.new [] [] [[1, 2]] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* * 1-2 * *") + + Heck.it t "accepts a choice" $ do + schedule <- ScheduleSpec.new [] [] [[1], [2]] [] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* * 1,2 * *") + + Heck.it t "rejects two wildcards" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * *,* * *")) + + Heck.it t "rejects a wildcard and a number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * *,1 * *")) + + Heck.it t "rejects a wildcard and a range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * *,1-1 * *")) + + Heck.it t "rejects an out of bounds number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * 32 * *")) + + Heck.it t "rejects an out of bounds number as part of a choice" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * 1,32 * *")) + + Heck.it t "rejects an out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * 32-33 * *")) + + Heck.it t "rejects a half out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * 1-32 * *")) + + Heck.it t "rejects a backwards range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * 2-1 * *")) + + Heck.describe t "month" $ do + Heck.it t "accepts a number" $ do + schedule <- ScheduleSpec.new [] [] [] [[1]] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* * * 1 *") + + Heck.it t "accepts a range" $ do + schedule <- ScheduleSpec.new [] [] [] [[1, 2]] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* * * 1-2 *") + + Heck.it t "accepts a choice" $ do + schedule <- ScheduleSpec.new [] [] [] [[1], [2]] [] + Heck.assertEq t (Right schedule) (Parse.fromString "* * * 1,2 *") + + Heck.it t "rejects two wildcards" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * *,* *")) + + Heck.it t "rejects a wildcard and a number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * *,1 *")) + + Heck.it t "rejects a wildcard and a range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * *,1-1 *")) + + Heck.it t "rejects an out of bounds number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * 13 *")) + + Heck.it t "rejects an out of bounds number as part of a choice" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * 1,13 *")) + + Heck.it t "rejects an out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * 13-14 *")) + + Heck.it t "rejects a half out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * 1-13 *")) + + Heck.it t "rejects a backwards range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * 2-1 *")) + + Heck.describe t "weekday" $ do + Heck.it t "accepts a number" $ do + schedule <- ScheduleSpec.new [] [] [] [] [[0]] + Heck.assertEq t (Right schedule) (Parse.fromString "* * * * 0") + + Heck.it t "accepts a range" $ do + schedule <- ScheduleSpec.new [] [] [] [] [[0, 1]] + Heck.assertEq t (Right schedule) (Parse.fromString "* * * * 0-1") + + Heck.it t "accepts a choice" $ do + schedule <- ScheduleSpec.new [] [] [] [] [[0], [1]] + Heck.assertEq t (Right schedule) (Parse.fromString "* * * * 0,1") + + Heck.it t "rejects two wildcards" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * * *,*")) + + Heck.it t "rejects a wildcard and a number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * * *,0")) + + Heck.it t "rejects a wildcard and a range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * * *,0-0")) + + Heck.it t "rejects an out of bounds number" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * * 7")) + + Heck.it t "rejects an out of bounds number as part of a choice" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * * 0,7")) + + Heck.it t "rejects an out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * * 7-8")) + + Heck.it t "rejects a half out of bounds range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * * 0-7")) + + Heck.it t "rejects a backwards range" $ do + Heck.assertEq t True (Either.isLeft (Parse.fromString "* * * * 1-0")) diff --git a/source/library/Saturn/Unstable/Render.hs b/source/library/Saturn/Unstable/Render.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Render.hs @@ -0,0 +1,21 @@ +module Saturn.Unstable.Render where + +import qualified Data.Text as Text +import qualified Data.Text.Lazy as LazyText +import qualified Data.Text.Lazy.Builder as Builder +import qualified Saturn.Unstable.Type.Schedule as Schedule + +-- | Renders a 'Schedule.Schedule' into a lazy 'LazyText.Text' value. See +-- 'toText' for details. +toLazyText :: Schedule.Schedule -> LazyText.Text +toLazyText = Builder.toLazyText . Schedule.toBuilder + +-- | Renders a 'Schedule.Schedule' into a 'String' value. See 'toText' for +-- details. +toString :: Schedule.Schedule -> String +toString = LazyText.unpack . toLazyText + +-- | Renders a 'Schedule.Schedule' into a strict 'Text.Text' value. The output +-- will have five fields, each separated by a single space. +toText :: Schedule.Schedule -> Text.Text +toText = LazyText.toStrict . toLazyText diff --git a/source/library/Saturn/Unstable/RenderSpec.hs b/source/library/Saturn/Unstable/RenderSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/RenderSpec.hs @@ -0,0 +1,24 @@ +module Saturn.Unstable.RenderSpec where + +import qualified Heck +import qualified Saturn.Unstable.Render as Render +import qualified Saturn.Unstable.Type.ScheduleSpec as ScheduleSpec + +spec :: (MonadFail m, Monad n) => Heck.Test m n -> n () +spec t = Heck.describe t "Saturn.Unstable.Render" $ do + Heck.describe t "toString" $ do + Heck.it t "works with wildcards" $ do + schedule <- ScheduleSpec.new [] [] [] [] [] + Heck.assertEq t "* * * * *" (Render.toString schedule) + + Heck.it t "works with numbers" $ do + schedule <- ScheduleSpec.new [[4]] [[3]] [[2]] [[1]] [[0]] + Heck.assertEq t "4 3 2 1 0" (Render.toString schedule) + + Heck.it t "works with ranges" $ do + schedule <- ScheduleSpec.new [[8, 9]] [[6, 7]] [[4, 5]] [[2, 3]] [[0, 1]] + Heck.assertEq t "8-9 6-7 4-5 2-3 0-1" (Render.toString schedule) + + Heck.it t "works with choices" $ do + schedule <- ScheduleSpec.new [[8], [9]] [[6], [7]] [[4], [5]] [[2], [3]] [[0], [1]] + Heck.assertEq t "8,9 6,7 4,5 2,3 0,1" (Render.toString schedule) diff --git a/source/library/Saturn/Unstable/Type/Day.hs b/source/library/Saturn/Unstable/Type/Day.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Day.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Day where + +import qualified Data.Coerce as Coerce +import qualified Data.Set as Set +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Type.Field as Field +import qualified Text.Parsec as Parsec + +newtype Day + = Day Field.Field + deriving (Eq, Show) + +bounds :: (Word.Word8, Word.Word8) +bounds = (1, 31) + +fromField :: Field.Field -> Maybe Day +fromField field = + if Field.isValid bounds field then Just $ Day field else Nothing + +toField :: Day -> Field.Field +toField = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Day +parsec = do + field <- Field.parsec + maybe (fail "invalid Day") pure $ fromField field + +toBuilder :: Day -> Builder.Builder +toBuilder = Field.toBuilder . toField + +expand :: Day -> Set.Set Word.Word8 +expand = Field.expand bounds . toField + +isMatch :: Word.Word8 -> Day -> Bool +isMatch word8 = Set.member word8 . expand diff --git a/source/library/Saturn/Unstable/Type/DaySpec.hs b/source/library/Saturn/Unstable/Type/DaySpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/DaySpec.hs @@ -0,0 +1,31 @@ +module Saturn.Unstable.Type.DaySpec where + +import qualified Data.Maybe as Maybe +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Type.Day as Day +import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Day" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Day.parsec "" (Builder.toLazyText $ Day.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Day.Day +arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Day.fromField + +shrink :: Day.Day -> [Day.Day] +shrink = Maybe.mapMaybe Day.fromField . FieldSpec.shrink . Day.toField + +new :: (MonadFail m) => [[Word.Word8]] -> m Day.Day +new xs = do + field <- FieldSpec.new xs + maybe (fail $ "invalid Day: " <> show xs) pure $ Day.fromField field diff --git a/source/library/Saturn/Unstable/Type/Element.hs b/source/library/Saturn/Unstable/Type/Element.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Element.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Element where + +import qualified Data.Coerce as Coerce +import qualified Data.Set as Set +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Extra.Parsec as Parsec +import qualified Saturn.Unstable.Type.Number as Number +import qualified Saturn.Unstable.Type.Range as Range +import qualified Text.Parsec as Parsec + +newtype Element + = Element (Either Range.Range Number.Number) + deriving (Eq, Show) + +fromEither :: Either Range.Range Number.Number -> Element +fromEither = Coerce.coerce + +toEither :: Element -> Either Range.Range Number.Number +toEither = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Element +parsec = fromEither <$> Parsec.either (Parsec.try Range.parsec) Number.parsec + +toBuilder :: Element -> Builder.Builder +toBuilder = either Range.toBuilder Number.toBuilder . toEither + +isValid :: (Word.Word8, Word.Word8) -> Element -> Bool +isValid tuple = either (Range.isValid tuple) (Number.isValid tuple) . toEither + +expand :: Element -> Set.Set Word.Word8 +expand = either Range.expand (Set.singleton . Number.toWord8) . toEither diff --git a/source/library/Saturn/Unstable/Type/ElementSpec.hs b/source/library/Saturn/Unstable/Type/ElementSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/ElementSpec.hs @@ -0,0 +1,47 @@ +module Saturn.Unstable.Type.ElementSpec where + +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Type.Element as Element +import qualified Saturn.Unstable.Type.Number as Number +import qualified Saturn.Unstable.Type.NumberSpec as NumberSpec +import qualified Saturn.Unstable.Type.Range as Range +import qualified Saturn.Unstable.Type.RangeSpec as RangeSpec +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Element" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Element.parsec "" (Builder.toLazyText $ Element.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Element.Element +arbitrary = + Element.fromEither + <$> QuickCheck.liftArbitrary2 + RangeSpec.arbitrary + NumberSpec.arbitrary + +shrink :: Element.Element -> [Element.Element] +shrink element = + let xs = case Element.toEither element of + Left range -> + let (lo, hi) = Range.toTuple range + in fmap (Element.fromEither . Right) [lo, hi] + Right _ -> [] + in mappend xs + . fmap Element.fromEither + . QuickCheck.liftShrink2 RangeSpec.shrink NumberSpec.shrink + $ Element.toEither element + +new :: (MonadFail m) => [Word.Word8] -> m Element.Element +new xs = case xs of + [x] -> pure . Element.fromEither . Right $ Number.fromWord8 x + [x, y] -> Element.fromEither . Left <$> RangeSpec.new (x, y) + _ -> fail $ "invalid Element: " <> show xs diff --git a/source/library/Saturn/Unstable/Type/Field.hs b/source/library/Saturn/Unstable/Type/Field.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Field.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Field where + +import qualified Data.Coerce as Coerce +import qualified Data.Either as Either +import qualified Data.Foldable as Foldable +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Set as Set +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Extra.Parsec as Parsec +import qualified Saturn.Unstable.Extra.Tuple as Tuple +import qualified Saturn.Unstable.Type.Element as Element +import qualified Saturn.Unstable.Type.Wildcard as Wildcard +import qualified Text.Parsec as Parsec + +newtype Field + = Field (Either Wildcard.Wildcard (NonEmpty.NonEmpty Element.Element)) + deriving (Eq, Show) + +fromEither :: + Either Wildcard.Wildcard (NonEmpty.NonEmpty Element.Element) -> Field +fromEither = Coerce.coerce + +toEither :: + Field -> Either Wildcard.Wildcard (NonEmpty.NonEmpty Element.Element) +toEither = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Field +parsec = + fromEither + <$> Parsec.either + Wildcard.parsec + (Parsec.sepByNE Element.parsec $ Parsec.char ',') + +toBuilder :: Field -> Builder.Builder +toBuilder = + either + Wildcard.toBuilder + ( Foldable.fold + . NonEmpty.intersperse (Builder.singleton ',') + . fmap Element.toBuilder + ) + . toEither + +isValid :: (Word.Word8, Word.Word8) -> Field -> Bool +isValid tuple = either (const True) (all $ Element.isValid tuple) . toEither + +expand :: (Word.Word8, Word.Word8) -> Field -> Set.Set Word.Word8 +expand tuple = + either + (const . Set.fromList $ Tuple.toSequence tuple) + (Set.unions . fmap Element.expand) + . toEither + +isWildcard :: Field -> Bool +isWildcard = Either.isLeft . toEither diff --git a/source/library/Saturn/Unstable/Type/FieldSpec.hs b/source/library/Saturn/Unstable/Type/FieldSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/FieldSpec.hs @@ -0,0 +1,55 @@ +module Saturn.Unstable.Type.FieldSpec where + +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Maybe as Maybe +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Type.ElementSpec as ElementSpec +import qualified Saturn.Unstable.Type.Field as Field +import qualified Saturn.Unstable.Type.Wildcard as Wildcard +import qualified Saturn.Unstable.Type.WildcardSpec as WildcardSpec +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Field" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Field.parsec "" (Builder.toLazyText $ Field.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Field.Field +arbitrary = + Field.fromEither + <$> QuickCheck.liftArbitrary2 + WildcardSpec.arbitrary + (arbitraryNonEmpty ElementSpec.arbitrary) + +arbitraryNonEmpty :: QuickCheck.Gen a -> QuickCheck.Gen (NonEmpty.NonEmpty a) +arbitraryNonEmpty g = (NonEmpty.:|) <$> g <*> QuickCheck.listOf g + +shrink :: Field.Field -> [Field.Field] +shrink field = + let xs = case Field.toEither field of + Left _ -> [] + Right _ -> [Field.fromEither . Left $ Wildcard.fromUnit ()] + in mappend xs + . fmap Field.fromEither + . QuickCheck.liftShrink2 WildcardSpec.shrink (shrinkNonEmpty ElementSpec.shrink) + $ Field.toEither field + +shrinkNonEmpty :: (a -> [a]) -> NonEmpty.NonEmpty a -> [NonEmpty.NonEmpty a] +shrinkNonEmpty f = Maybe.mapMaybe (NonEmpty.nonEmpty . f) . NonEmpty.toList + +new :: (MonadFail m) => [[Word.Word8]] -> m Field.Field +new = + fmap + ( Field.fromEither + . maybe (Left $ Wildcard.fromUnit ()) Right + . NonEmpty.nonEmpty + ) + . mapM ElementSpec.new diff --git a/source/library/Saturn/Unstable/Type/Hour.hs b/source/library/Saturn/Unstable/Type/Hour.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Hour.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Hour where + +import qualified Data.Coerce as Coerce +import qualified Data.Set as Set +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Type.Field as Field +import qualified Text.Parsec as Parsec + +newtype Hour + = Hour Field.Field + deriving (Eq, Show) + +bounds :: (Word.Word8, Word.Word8) +bounds = (0, 23) + +fromField :: Field.Field -> Maybe Hour +fromField field = + if Field.isValid bounds field then Just $ Hour field else Nothing + +toField :: Hour -> Field.Field +toField = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Hour +parsec = do + field <- Field.parsec + maybe (fail "invalid Hour") pure $ fromField field + +toBuilder :: Hour -> Builder.Builder +toBuilder = Field.toBuilder . toField + +expand :: Hour -> Set.Set Word.Word8 +expand = Field.expand bounds . toField + +isMatch :: Word.Word8 -> Hour -> Bool +isMatch word8 = Set.member word8 . expand diff --git a/source/library/Saturn/Unstable/Type/HourSpec.hs b/source/library/Saturn/Unstable/Type/HourSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/HourSpec.hs @@ -0,0 +1,31 @@ +module Saturn.Unstable.Type.HourSpec where + +import qualified Data.Maybe as Maybe +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec +import qualified Saturn.Unstable.Type.Hour as Hour +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Hour" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Hour.parsec "" (Builder.toLazyText $ Hour.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Hour.Hour +arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Hour.fromField + +shrink :: Hour.Hour -> [Hour.Hour] +shrink = Maybe.mapMaybe Hour.fromField . FieldSpec.shrink . Hour.toField + +new :: (MonadFail m) => [[Word.Word8]] -> m Hour.Hour +new xs = do + field <- FieldSpec.new xs + maybe (fail $ "invalid Hour: " <> show xs) pure $ Hour.fromField field diff --git a/source/library/Saturn/Unstable/Type/Minute.hs b/source/library/Saturn/Unstable/Type/Minute.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Minute.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Minute where + +import qualified Data.Coerce as Coerce +import qualified Data.Set as Set +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Type.Field as Field +import qualified Text.Parsec as Parsec + +newtype Minute + = Minute Field.Field + deriving (Eq, Show) + +bounds :: (Word.Word8, Word.Word8) +bounds = (0, 59) + +fromField :: Field.Field -> Maybe Minute +fromField field = + if Field.isValid bounds field then Just $ Minute field else Nothing + +toField :: Minute -> Field.Field +toField = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Minute +parsec = do + field <- Field.parsec + maybe (fail "invalid Minute") pure $ fromField field + +toBuilder :: Minute -> Builder.Builder +toBuilder = Field.toBuilder . toField + +expand :: Minute -> Set.Set Word.Word8 +expand = Field.expand bounds . toField + +isMatch :: Word.Word8 -> Minute -> Bool +isMatch word8 = Set.member word8 . expand diff --git a/source/library/Saturn/Unstable/Type/MinuteSpec.hs b/source/library/Saturn/Unstable/Type/MinuteSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/MinuteSpec.hs @@ -0,0 +1,31 @@ +module Saturn.Unstable.Type.MinuteSpec where + +import qualified Data.Maybe as Maybe +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec +import qualified Saturn.Unstable.Type.Minute as Minute +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Minute" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Minute.parsec "" (Builder.toLazyText $ Minute.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Minute.Minute +arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Minute.fromField + +shrink :: Minute.Minute -> [Minute.Minute] +shrink = Maybe.mapMaybe Minute.fromField . FieldSpec.shrink . Minute.toField + +new :: (MonadFail m) => [[Word.Word8]] -> m Minute.Minute +new xs = do + field <- FieldSpec.new xs + maybe (fail $ "invalid Minute: " <> show xs) pure $ Minute.fromField field diff --git a/source/library/Saturn/Unstable/Type/Month.hs b/source/library/Saturn/Unstable/Type/Month.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Month.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Month where + +import qualified Data.Coerce as Coerce +import qualified Data.Set as Set +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Type.Field as Field +import qualified Text.Parsec as Parsec + +newtype Month + = Month Field.Field + deriving (Eq, Show) + +bounds :: (Word.Word8, Word.Word8) +bounds = (1, 12) + +fromField :: Field.Field -> Maybe Month +fromField field = + if Field.isValid bounds field then Just $ Month field else Nothing + +toField :: Month -> Field.Field +toField = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Month +parsec = do + field <- Field.parsec + maybe (fail "invalid Month") pure $ fromField field + +toBuilder :: Month -> Builder.Builder +toBuilder = Field.toBuilder . toField + +expand :: Month -> Set.Set Word.Word8 +expand = Field.expand bounds . toField + +isMatch :: Word.Word8 -> Month -> Bool +isMatch word8 = Set.member word8 . expand diff --git a/source/library/Saturn/Unstable/Type/MonthSpec.hs b/source/library/Saturn/Unstable/Type/MonthSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/MonthSpec.hs @@ -0,0 +1,31 @@ +module Saturn.Unstable.Type.MonthSpec where + +import qualified Data.Maybe as Maybe +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec +import qualified Saturn.Unstable.Type.Month as Month +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Month" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Month.parsec "" (Builder.toLazyText $ Month.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Month.Month +arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Month.fromField + +shrink :: Month.Month -> [Month.Month] +shrink = Maybe.mapMaybe Month.fromField . FieldSpec.shrink . Month.toField + +new :: (MonadFail m) => [[Word.Word8]] -> m Month.Month +new xs = do + field <- FieldSpec.new xs + maybe (fail $ "invalid Month: " <> show xs) pure $ Month.fromField field diff --git a/source/library/Saturn/Unstable/Type/Number.hs b/source/library/Saturn/Unstable/Type/Number.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Number.hs @@ -0,0 +1,35 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Number where + +import qualified Data.Bits as Bits +import qualified Data.Coerce as Coerce +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Text.Lazy.Builder.Int as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Extra.Ord as Ord +import qualified Text.Parsec as Parsec +import qualified Text.Read as Read + +newtype Number + = Number Word.Word8 + deriving (Eq, Show) + +fromWord8 :: Word.Word8 -> Number +fromWord8 = Coerce.coerce + +toWord8 :: Number -> Word.Word8 +toWord8 = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Number +parsec = do + string <- Parsec.many1 Parsec.digit + integer <- maybe (fail "invalidNumber") pure $ Read.readMaybe string + maybe (fail "invalidNumber") (pure . fromWord8) $ + Bits.toIntegralSized (integer :: Integer) + +toBuilder :: Number -> Builder.Builder +toBuilder = Builder.decimal . toWord8 + +isValid :: (Word.Word8, Word.Word8) -> Number -> Bool +isValid tuple = Ord.within tuple . toWord8 diff --git a/source/library/Saturn/Unstable/Type/NumberSpec.hs b/source/library/Saturn/Unstable/Type/NumberSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/NumberSpec.hs @@ -0,0 +1,23 @@ +module Saturn.Unstable.Type.NumberSpec where + +import qualified Data.Text.Lazy.Builder as Builder +import qualified Heck +import qualified Saturn.Unstable.Type.Number as Number +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Number" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Number.parsec "" (Builder.toLazyText $ Number.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Number.Number +arbitrary = Number.fromWord8 <$> QuickCheck.arbitrary + +shrink :: Number.Number -> [Number.Number] +shrink = fmap Number.fromWord8 . QuickCheck.shrink . Number.toWord8 diff --git a/source/library/Saturn/Unstable/Type/Range.hs b/source/library/Saturn/Unstable/Type/Range.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Range.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Range where + +import qualified Control.Monad as Monad +import qualified Data.Coerce as Coerce +import qualified Data.Set as Set +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Extra.Tuple as Tuple +import qualified Saturn.Unstable.Type.Number as Number +import qualified Text.Parsec as Parsec + +newtype Range + = Range (Number.Number, Number.Number) + deriving (Eq, Show) + +fromTuple :: (Number.Number, Number.Number) -> Maybe Range +fromTuple (lo, hi) = + if Number.toWord8 lo > Number.toWord8 hi + then Nothing + else Just $ Range (lo, hi) + +toTuple :: Range -> (Number.Number, Number.Number) +toTuple = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Range +parsec = do + lo <- Number.parsec + Monad.void $ Parsec.char '-' + hi <- Number.parsec + maybe (fail "invalid Range") pure $ fromTuple (lo, hi) + +toBuilder :: Range -> Builder.Builder +toBuilder range = + let (lo, hi) = toTuple range + in Number.toBuilder lo <> Builder.singleton '-' <> Number.toBuilder hi + +isValid :: (Word.Word8, Word.Word8) -> Range -> Bool +isValid tuple = uncurry (&&) . Tuple.mapBoth (Number.isValid tuple) . toTuple + +expand :: Range -> Set.Set Word.Word8 +expand = + Set.fromList + . Tuple.toSequence + . Tuple.mapBoth Number.toWord8 + . toTuple diff --git a/source/library/Saturn/Unstable/Type/RangeSpec.hs b/source/library/Saturn/Unstable/Type/RangeSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/RangeSpec.hs @@ -0,0 +1,40 @@ +module Saturn.Unstable.Type.RangeSpec where + +import qualified Data.Maybe as Maybe +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Extra.Tuple as Tuple +import qualified Saturn.Unstable.Type.Number as Number +import qualified Saturn.Unstable.Type.NumberSpec as NumberSpec +import qualified Saturn.Unstable.Type.Range as Range +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Range" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Range.parsec "" (Builder.toLazyText $ Range.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Range.Range +arbitrary = + QuickCheck.suchThatMap + (QuickCheck.liftArbitrary2 NumberSpec.arbitrary NumberSpec.arbitrary) + Range.fromTuple + +shrink :: Range.Range -> [Range.Range] +shrink = + Maybe.mapMaybe Range.fromTuple + . QuickCheck.liftShrink2 NumberSpec.shrink NumberSpec.shrink + . Range.toTuple + +new :: (MonadFail m) => (Word.Word8, Word.Word8) -> m Range.Range +new tuple = + maybe (fail $ "invalid Range: " <> show tuple) pure + . Range.fromTuple + $ Tuple.mapBoth Number.fromWord8 tuple diff --git a/source/library/Saturn/Unstable/Type/Schedule.hs b/source/library/Saturn/Unstable/Type/Schedule.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Schedule.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Schedule where + +import qualified Data.Text.Lazy.Builder as Builder +import qualified Saturn.Unstable.Type.Day as Day +import qualified Saturn.Unstable.Type.Hour as Hour +import qualified Saturn.Unstable.Type.Minute as Minute +import qualified Saturn.Unstable.Type.Month as Month +import qualified Saturn.Unstable.Type.Weekday as Weekday +import qualified Text.Parsec as Parsec + +data Schedule = Schedule + { minute :: Minute.Minute, + hour :: Hour.Hour, + day :: Day.Day, + month :: Month.Month, + weekday :: Weekday.Weekday + } + deriving (Eq, Show) + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Schedule +parsec = + Schedule + <$> Minute.parsec + <* Parsec.skipMany1 (Parsec.char ' ') + <*> Hour.parsec + <* Parsec.skipMany1 (Parsec.char ' ') + <*> Day.parsec + <* Parsec.skipMany1 (Parsec.char ' ') + <*> Month.parsec + <* Parsec.skipMany1 (Parsec.char ' ') + <*> Weekday.parsec + +toBuilder :: Schedule -> Builder.Builder +toBuilder schedule = + Minute.toBuilder (minute schedule) + <> Builder.singleton ' ' + <> Hour.toBuilder (hour schedule) + <> Builder.singleton ' ' + <> Day.toBuilder (day schedule) + <> Builder.singleton ' ' + <> Month.toBuilder (month schedule) + <> Builder.singleton ' ' + <> Weekday.toBuilder (weekday schedule) diff --git a/source/library/Saturn/Unstable/Type/ScheduleSpec.hs b/source/library/Saturn/Unstable/Type/ScheduleSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/ScheduleSpec.hs @@ -0,0 +1,87 @@ +module Saturn.Unstable.Type.ScheduleSpec where + +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Type.DaySpec as DaySpec +import qualified Saturn.Unstable.Type.HourSpec as HourSpec +import qualified Saturn.Unstable.Type.MinuteSpec as MinuteSpec +import qualified Saturn.Unstable.Type.MonthSpec as MonthSpec +import qualified Saturn.Unstable.Type.Schedule as Schedule +import qualified Saturn.Unstable.Type.WeekdaySpec as WeekdaySpec +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Schedule" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Schedule.parsec "" (Builder.toLazyText $ Schedule.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Schedule.Schedule +arbitrary = + Schedule.Schedule + <$> MinuteSpec.arbitrary + <*> HourSpec.arbitrary + <*> DaySpec.arbitrary + <*> MonthSpec.arbitrary + <*> WeekdaySpec.arbitrary + +shrink :: Schedule.Schedule -> [Schedule.Schedule] +shrink schedule = + ( \(minute, hour, day, month, weekday) -> + Schedule.Schedule + { Schedule.minute = minute, + Schedule.hour = hour, + Schedule.day = day, + Schedule.month = month, + Schedule.weekday = weekday + } + ) + <$> liftShrink5 + MinuteSpec.shrink + HourSpec.shrink + DaySpec.shrink + MonthSpec.shrink + WeekdaySpec.shrink + ( Schedule.minute schedule, + Schedule.hour schedule, + Schedule.day schedule, + Schedule.month schedule, + Schedule.weekday schedule + ) + +liftShrink5 :: + (t1 -> [t1]) -> + (t2 -> [t2]) -> + (t3 -> [t3]) -> + (t4 -> [t4]) -> + (t5 -> [t5]) -> + (t1, t2, t3, t4, t5) -> + [(t1, t2, t3, t4, t5)] +liftShrink5 f1 f2 f3 f4 f5 (x1, x2, x3, x4, x5) = + (\((y1, y2), (y3, (y4, y5))) -> (y1, y2, y3, y4, y5)) + <$> QuickCheck.liftShrink2 + (QuickCheck.liftShrink2 f1 f2) + (QuickCheck.liftShrink2 f3 (QuickCheck.liftShrink2 f4 f5)) + ((x1, x2), (x3, (x4, x5))) + +new :: + (MonadFail m) => + [[Word.Word8]] -> + [[Word.Word8]] -> + [[Word.Word8]] -> + [[Word.Word8]] -> + [[Word.Word8]] -> + m Schedule.Schedule +new minutes hours days months weekdays = + Schedule.Schedule + <$> MinuteSpec.new minutes + <*> HourSpec.new hours + <*> DaySpec.new days + <*> MonthSpec.new months + <*> WeekdaySpec.new weekdays diff --git a/source/library/Saturn/Unstable/Type/Weekday.hs b/source/library/Saturn/Unstable/Type/Weekday.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Weekday.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Weekday where + +import qualified Data.Coerce as Coerce +import qualified Data.Set as Set +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Saturn.Unstable.Type.Field as Field +import qualified Text.Parsec as Parsec + +newtype Weekday + = Weekday Field.Field + deriving (Eq, Show) + +bounds :: (Word.Word8, Word.Word8) +bounds = (0, 6) + +fromField :: Field.Field -> Maybe Weekday +fromField field = + if Field.isValid bounds field then Just $ Weekday field else Nothing + +toField :: Weekday -> Field.Field +toField = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Weekday +parsec = do + field <- Field.parsec + maybe (fail "invalid Weekday") pure $ fromField field + +toBuilder :: Weekday -> Builder.Builder +toBuilder = Field.toBuilder . toField + +expand :: Weekday -> Set.Set Word.Word8 +expand = Field.expand bounds . toField + +isMatch :: Word.Word8 -> Weekday -> Bool +isMatch word8 = Set.member word8 . expand diff --git a/source/library/Saturn/Unstable/Type/WeekdaySpec.hs b/source/library/Saturn/Unstable/Type/WeekdaySpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/WeekdaySpec.hs @@ -0,0 +1,31 @@ +module Saturn.Unstable.Type.WeekdaySpec where + +import qualified Data.Maybe as Maybe +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Word as Word +import qualified Heck +import qualified Saturn.Unstable.Type.FieldSpec as FieldSpec +import qualified Saturn.Unstable.Type.Weekday as Weekday +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Weekday" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Weekday.parsec "" (Builder.toLazyText $ Weekday.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Weekday.Weekday +arbitrary = QuickCheck.suchThatMap FieldSpec.arbitrary Weekday.fromField + +shrink :: Weekday.Weekday -> [Weekday.Weekday] +shrink = Maybe.mapMaybe Weekday.fromField . FieldSpec.shrink . Weekday.toField + +new :: (MonadFail m) => [[Word.Word8]] -> m Weekday.Weekday +new xs = do + field <- FieldSpec.new xs + maybe (fail $ "invalid Weekday: " <> show xs) pure $ Weekday.fromField field diff --git a/source/library/Saturn/Unstable/Type/Wildcard.hs b/source/library/Saturn/Unstable/Type/Wildcard.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/Wildcard.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE FlexibleContexts #-} + +module Saturn.Unstable.Type.Wildcard where + +import qualified Control.Monad as Monad +import qualified Data.Coerce as Coerce +import qualified Data.Text.Lazy.Builder as Builder +import qualified Text.Parsec as Parsec + +newtype Wildcard + = Wildcard () + deriving (Eq, Show) + +fromUnit :: () -> Wildcard +fromUnit = Coerce.coerce + +toUnit :: Wildcard -> () +toUnit = Coerce.coerce + +parsec :: (Parsec.Stream s m Char) => Parsec.ParsecT s u m Wildcard +parsec = fmap fromUnit . Monad.void $ Parsec.char '*' + +toBuilder :: Wildcard -> Builder.Builder +toBuilder = const $ Builder.singleton '*' diff --git a/source/library/Saturn/Unstable/Type/WildcardSpec.hs b/source/library/Saturn/Unstable/Type/WildcardSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/Saturn/Unstable/Type/WildcardSpec.hs @@ -0,0 +1,23 @@ +module Saturn.Unstable.Type.WildcardSpec where + +import qualified Data.Text.Lazy.Builder as Builder +import qualified Heck +import qualified Saturn.Unstable.Type.Wildcard as Wildcard +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck +import qualified Text.Parsec as Parsec + +spec :: Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn.Unstable.Type.Wildcard" $ do + Heck.it t "round trips" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink arbitrary shrink + $ \x -> do + Parsec.parse Wildcard.parsec "" (Builder.toLazyText $ Wildcard.toBuilder x) + `Hspec.shouldBe` Right x + +arbitrary :: QuickCheck.Gen Wildcard.Wildcard +arbitrary = Wildcard.fromUnit <$> QuickCheck.arbitrary + +shrink :: Wildcard.Wildcard -> [Wildcard.Wildcard] +shrink = fmap Wildcard.fromUnit . QuickCheck.shrink . Wildcard.toUnit diff --git a/source/library/SaturnSpec.hs b/source/library/SaturnSpec.hs new file mode 100644 --- /dev/null +++ b/source/library/SaturnSpec.hs @@ -0,0 +1,29 @@ +module SaturnSpec where + +import qualified Heck +import qualified Saturn.Unstable.Parse as Parse +import qualified Saturn.Unstable.Render as Render +import qualified Saturn.Unstable.Type.ScheduleSpec as ScheduleSpec +import qualified Test.Hspec as Hspec +import qualified Test.QuickCheck as QuickCheck + +spec :: (Monad n) => Heck.Test IO n -> n () +spec t = Heck.describe t "Saturn" $ do + Heck.describe t "round trips" $ do + Heck.it t "through string" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink ScheduleSpec.arbitrary ScheduleSpec.shrink + $ \schedule -> + Parse.fromString (Render.toString schedule) `Hspec.shouldBe` Right schedule + + Heck.it t "through strict text" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink ScheduleSpec.arbitrary ScheduleSpec.shrink + $ \schedule -> + Parse.fromText (Render.toText schedule) `Hspec.shouldBe` Right schedule + + Heck.it t "through lazy text" + . QuickCheck.quickCheck + . QuickCheck.forAllShrink ScheduleSpec.arbitrary ScheduleSpec.shrink + $ \schedule -> + Parse.fromLazyText (Render.toLazyText schedule) `Hspec.shouldBe` Right schedule diff --git a/source/test-suite/Main.hs b/source/test-suite/Main.hs --- a/source/test-suite/Main.hs +++ b/source/test-suite/Main.hs @@ -1,3 +1,4 @@ +import qualified Heck import qualified Saturn.Unstable.ConstantSpec import qualified Saturn.Unstable.Extra.IntSpec import qualified Saturn.Unstable.Extra.OrdSpec @@ -20,27 +21,36 @@ import qualified Saturn.Unstable.Type.WildcardSpec import qualified SaturnSpec import qualified Test.Hspec as Hspec +import qualified Test.Hspec.Core.Spec as Hspec main :: IO () main = Hspec.hspec . Hspec.parallel $ do - Saturn.Unstable.ConstantSpec.spec - Saturn.Unstable.Extra.IntSpec.spec - Saturn.Unstable.Extra.OrdSpec.spec - Saturn.Unstable.Extra.ParsecSpec.spec - Saturn.Unstable.Extra.TimeSpec.spec - Saturn.Unstable.Extra.TupleSpec.spec - Saturn.Unstable.MatchSpec.spec - Saturn.Unstable.ParseSpec.spec - Saturn.Unstable.RenderSpec.spec - Saturn.Unstable.Type.DaySpec.spec - Saturn.Unstable.Type.ElementSpec.spec - Saturn.Unstable.Type.FieldSpec.spec - Saturn.Unstable.Type.HourSpec.spec - Saturn.Unstable.Type.MinuteSpec.spec - Saturn.Unstable.Type.MonthSpec.spec - Saturn.Unstable.Type.NumberSpec.spec - Saturn.Unstable.Type.RangeSpec.spec - Saturn.Unstable.Type.ScheduleSpec.spec - Saturn.Unstable.Type.WeekdaySpec.spec - Saturn.Unstable.Type.WildcardSpec.spec - SaturnSpec.spec + Saturn.Unstable.ConstantSpec.spec heck + Saturn.Unstable.Extra.IntSpec.spec heck + Saturn.Unstable.Extra.OrdSpec.spec heck + Saturn.Unstable.Extra.ParsecSpec.spec heck + Saturn.Unstable.Extra.TimeSpec.spec heck + Saturn.Unstable.Extra.TupleSpec.spec heck + Saturn.Unstable.MatchSpec.spec heck + Saturn.Unstable.ParseSpec.spec heck + Saturn.Unstable.RenderSpec.spec heck + Saturn.Unstable.Type.DaySpec.spec heck + Saturn.Unstable.Type.ElementSpec.spec heck + Saturn.Unstable.Type.FieldSpec.spec heck + Saturn.Unstable.Type.HourSpec.spec heck + Saturn.Unstable.Type.MinuteSpec.spec heck + Saturn.Unstable.Type.MonthSpec.spec heck + Saturn.Unstable.Type.NumberSpec.spec heck + Saturn.Unstable.Type.RangeSpec.spec heck + Saturn.Unstable.Type.ScheduleSpec.spec heck + Saturn.Unstable.Type.WeekdaySpec.spec heck + Saturn.Unstable.Type.WildcardSpec.spec heck + SaturnSpec.spec heck + +heck :: Heck.Test IO (Hspec.SpecM ()) +heck = + Heck.MkTest + { Heck.assertFailure = fmap (\() -> error "impossible") . Hspec.expectationFailure, + Heck.describe = Hspec.describe, + Heck.it = Hspec.it + }