diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,3 +1,5 @@ +# 0.6.2 +* Updates to allow GHC 8.8 # 0.6.1 * Add support for day and month literals, Ahti Katiska (@HariGyogu). # 0.6.0 diff --git a/cron.cabal b/cron.cabal --- a/cron.cabal +++ b/cron.cabal @@ -1,5 +1,5 @@ Name: cron -Version: 0.6.1 +Version: 0.6.2 Description: Cron data structure and Attoparsec parser. The idea is to embed it in larger systems which want to roll their own scheduled tasks in a format that people @@ -20,10 +20,9 @@ Maintainer: Michael Xavier Build-Type: Simple Stability: experimental -Tested-With: GHC == 7.4.1 - , GHC == 7.6.3 - , GHC == 7.8.3 - , GHC == 7.10.1 +Tested-With: GHC == 8.4.4 + , GHC == 8.6.5 + , GHC == 8.8.1 Cabal-Version: >= 1.10 Extra-Source-Files: README.md @@ -85,14 +84,13 @@ , cron , tasty , tasty-hunit - , tasty-quickcheck + , tasty-hedgehog + , hedgehog , attoparsec , text , time , transformers-compat , semigroups - , quickcheck-instances - , generics-sop >= 0.2 if flag(lib-Werror) ghc-options: -Werror diff --git a/src/System/Cron/Internal/Check.hs b/src/System/Cron/Internal/Check.hs --- a/src/System/Cron/Internal/Check.hs +++ b/src/System/Cron/Internal/Check.hs @@ -9,11 +9,13 @@ import qualified Data.List.NonEmpty as NE import Data.Maybe import Data.Semigroup (sconcat) -import Data.Time +import Data.Time (Day, DiffTime, UTCTime (..), + addUTCTime, fromGregorianValid, + toGregorian) import Data.Time.Calendar.WeekDate import qualified Data.Traversable as FT ------------------------------------------------------------------------------- -import System.Cron.Types +import System.Cron.Types as CT ------------------------------------------------------------------------------- @@ -41,7 +43,7 @@ domStarSpec <- mkDayOfMonthSpec (Field Star) dowStarSpec <- mkDayOfWeekSpec (Field Star) let domStarResult = nextMatch cs { dayOfMonth = domStarSpec } now - let dowStarResult = nextMatch cs { dayOfWeek = dowStarSpec} now + let dowStarResult = nextMatch cs { CT.dayOfWeek = dowStarSpec} now listToMaybe (sort (catMaybes [domStarResult, dowStarResult])) | otherwise = do expanded@Expanded {..} <- expand cs diff --git a/src/System/Cron/Internal/Describe/Options.hs b/src/System/Cron/Internal/Describe/Options.hs --- a/src/System/Cron/Internal/Describe/Options.hs +++ b/src/System/Cron/Internal/Describe/Options.hs @@ -13,7 +13,7 @@ ------------------------------------------------------------------------------- import Data.Default.Class -import Data.Semigroup +import Data.Semigroup as Semigroup ------------------------------------------------------------------------------- import System.Cron.Internal.Describe.Types ------------------------------------------------------------------------------- @@ -77,7 +77,7 @@ instance Default Options where def = Opts {timeFormat = Hour12, verbosity = NotVerbose} -instance Semigroup OptionBuilder where +instance Semigroup.Semigroup OptionBuilder where (Builder f) <> (Builder a) = Builder (a . f) instance Monoid OptionBuilder where diff --git a/src/System/Cron/Parser.hs b/src/System/Cron/Parser.hs --- a/src/System/Cron/Parser.hs +++ b/src/System/Cron/Parser.hs @@ -34,6 +34,7 @@ ------------------------------------------------------------------------------- import Control.Applicative as Ap +import Control.Monad.Fail as F import Data.Attoparsec.Combinator (choice) import Data.Attoparsec.Text (Parser) import qualified Data.Attoparsec.Text as A @@ -160,8 +161,8 @@ neListP :: Parser a -> Parser (NonEmpty a) neListP p = coerceNE =<< A.sepBy1 p (A.char ',') where - coerceNE [] = fail "expected non-empty list" - coerceNE [_] = fail "invalid singleton list" + coerceNE [] = F.fail "expected non-empty list" + coerceNE [_] = F.fail "invalid singleton list" coerceNE (x:xs) = return $ x :| xs @@ -298,5 +299,5 @@ , "dec"] ------------------------------------------------------------------------------- -mParse :: (Monad m) => (a -> Maybe b) -> String -> a -> m b -mParse f msg = maybe (fail msg) return . f +mParse :: (Monad m, MonadFail m) => (a -> Maybe b) -> String -> a -> m b +mParse f msg = maybe (F.fail msg) return . f diff --git a/src/System/Cron/Types.hs b/src/System/Cron/Types.hs --- a/src/System/Cron/Types.hs +++ b/src/System/Cron/Types.hs @@ -55,11 +55,12 @@ ------------------------------------------------------------------------------- import Control.Applicative as A +import Data.Data (Data) import qualified Data.Foldable as FT import Data.Ix import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NE -import Data.Monoid +import Data.Monoid as Monoid import Data.Text (Text) import qualified Data.Text as T import Data.Typeable (Typeable) @@ -132,11 +133,11 @@ , dayOfMonth :: DayOfMonthSpec -- ^ Which days of the month to run. Third field in a cron specification. , month :: MonthSpec -- ^ Which months to run. Fourth field in a cron specification. , dayOfWeek :: DayOfWeekSpec -- ^ Which days of the week to run. Fifth field in a cron specification. - } deriving (Eq, Generic, Typeable) + } deriving (Eq, Generic, Data, Typeable) instance Show CronSchedule where - show cs = "CronSchedule " <> T.unpack (showT cs) + show cs = "CronSchedule " Monoid.<> T.unpack (showT cs) instance ShowT CronSchedule where @@ -155,7 +156,7 @@ -- | Crontab file, omitting comments. newtype Crontab = Crontab { crontabEntries :: [CrontabEntry] - } deriving (Eq, Generic, Typeable) + } deriving (Eq, Generic, Data, Typeable) instance ShowT Crontab where @@ -173,7 +174,7 @@ ------------------------------------------------------------------------------- newtype CronCommand = CronCommand { cronCommand :: Text - } deriving (Show, Eq, Ord, ShowT, Generic, Typeable) + } deriving (Show, Eq, Ord, ShowT, Generic, Data, Typeable) ------------------------------------------------------------------------------- @@ -181,7 +182,7 @@ -- command after it or setting an environment variable (e.g. FOO=BAR) data CrontabEntry = CommandEntry CronSchedule CronCommand | EnvVariable Text Text - deriving (Eq, Generic, Typeable) + deriving (Eq, Generic, Data, Typeable) instance ShowT CrontabEntry where @@ -196,7 +197,7 @@ -- | Minutes field of a cron expression newtype MinuteSpec = Minutes { minuteSpec :: CronField - } deriving (Eq, ShowT, Generic, Typeable) + } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show MinuteSpec where @@ -214,7 +215,7 @@ -- | Hours field of a cron expression newtype HourSpec = Hours { hourSpec :: CronField - } deriving (Eq, ShowT, Generic, Typeable) + } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show HourSpec where @@ -231,7 +232,7 @@ -- | Day of month field of a cron expression newtype DayOfMonthSpec = DaysOfMonth { dayOfMonthSpec :: CronField - } deriving (Eq, ShowT, Generic, Typeable) + } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show DayOfMonthSpec where @@ -248,7 +249,7 @@ -- | Month field of a cron expression newtype MonthSpec = Months { monthSpec :: CronField - } deriving (Eq, ShowT, Generic, Typeable) + } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show MonthSpec where @@ -265,7 +266,7 @@ -- | Day of week field of a cron expression newtype DayOfWeekSpec = DaysOfWeek { dayOfWeekSpec :: CronField - } deriving (Eq, ShowT, Generic, Typeable) + } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show DayOfWeekSpec where @@ -312,7 +313,7 @@ data BaseField = Star -- ^ Matches anything | SpecificField' SpecificField -- ^ Matches a specific value (e.g. 1) | RangeField' RangeField -- ^ Matches a range of values (e.g. 1-3) - deriving (Eq, Generic, Typeable) + deriving (Eq, Generic, Data, Typeable) instance ShowT BaseField where @@ -328,7 +329,7 @@ ------------------------------------------------------------------------------- newtype SpecificField = SpecificField { specificField :: Int - } deriving (Eq, ShowT, Generic, Typeable) + } deriving (Eq, ShowT, Generic, Data, Typeable) instance Show SpecificField where @@ -345,7 +346,7 @@ data RangeField = RangeField { rfBegin :: Int , rfEnd :: Int - } deriving (Eq, Generic, Typeable) + } deriving (Eq, Generic, Data, Typeable) instance ShowT RangeField where @@ -367,7 +368,7 @@ data CronField = Field BaseField | ListField (NonEmpty BaseField) -- ^ Matches a list of expressions. | StepField' StepField -- ^ Matches a stepped expression, e.g. (*/2). - deriving (Generic) + deriving (Generic, Data, Typeable) instance Eq CronField where @@ -392,7 +393,7 @@ ------------------------------------------------------------------------------- data StepField = StepField { sfField :: BaseField , sfStepping :: Int - } deriving (Eq, Generic) + } deriving (Eq, Generic, Data, Typeable) instance ShowT StepField where diff --git a/test/SpecHelper.hs b/test/SpecHelper.hs --- a/test/SpecHelper.hs +++ b/test/SpecHelper.hs @@ -1,6 +1,8 @@ {-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} {-# LANGUAGE TemplateHaskell #-} module SpecHelper @@ -10,117 +12,110 @@ ------------------------------------------------------------------------------- -import Control.Applicative as X -import Data.Attoparsec.Text as X (Parser, parseOnly) -import qualified Data.List.NonEmpty as NE -import Data.Maybe as X -import Data.Monoid as X -import Data.Proxy (Proxy (..)) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Time.Calendar as X -import Data.Time.Clock as X -import Data.Time.LocalTime as X -import Debug.Trace as X -import qualified Generics.SOP as SOP -import qualified Generics.SOP.Constraint as SOP -import qualified Generics.SOP.GGP as SOP -import GHC.Generics (Generic) -import Test.QuickCheck.Instances () -import Test.Tasty as X -import Test.Tasty.HUnit as X -import Test.Tasty.QuickCheck as X +import Control.Applicative as X +import Data.Attoparsec.Text as X (Parser, parseOnly) +import qualified Data.List.NonEmpty as NE +import Data.Maybe as X +import Data.Monoid as X +import Data.Text (Text) +import Data.Time.Calendar as X (fromGregorian, toGregorian) +import Data.Time.Clock as X (DiffTime, UTCTime (..), addUTCTime, + secondsToDiffTime) +import qualified Data.Time.Clock.POSIX as POSIX +import Data.Time.LocalTime as X +import Debug.Trace as X +import GHC.Generics (Generic) +import qualified GHC.Generics as G +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty as X +import Test.Tasty.Hedgehog as X +import Test.Tasty.HUnit as X ------------------------------------------------------------------------------- -import System.Cron as X +import System.Cron as X ------------------------------------------------------------------------------- --- this workaround is in place until we successfully beat down the --- doors of castle QuickCheck and get generic deriving through. See --- -sopArbitrary :: (SOP.GTo b, SOP.SListI (SOP.GCode b), Generic b, SOP.AllF (SOP.All Arbitrary) (SOP.GCode b), SOP.AllF SOP.SListI (SOP.GCode b)) => Gen b -sopArbitrary = fmap SOP.gto sopArbitrary' - - -sopArbitrary' :: (SOP.SListI xss, SOP.AllF SOP.SListI xss, SOP.AllF (SOP.All Arbitrary) xss) => Gen (SOP.SOP SOP.I xss) -sopArbitrary' = oneof (map SOP.hsequence $ SOP.apInjs_POP $ SOP.hcpure p arbitrary) - where - p :: Proxy Arbitrary - p = Proxy - - -instance Arbitrary BaseField where - arbitrary = sopArbitrary - shrink = genericShrink - - -instance Arbitrary CronField where - arbitrary = oneof [ Field <$> arbitrary - , ListField . NE.fromList . getNonEmpty <$> arbitrary - , StepField' <$> arbitrary - ] - - -instance Arbitrary CronSchedule where - arbitrary = sopArbitrary - shrink = genericShrink - - -instance Arbitrary Crontab where - arbitrary = Crontab <$> resize 20 arbitrary - - -instance Arbitrary CronCommand where - arbitrary = CronCommand <$> alphaGen - - -instance Arbitrary CrontabEntry where - arbitrary = oneof [ CommandEntry <$> arbitrary <*> arbitrary - , EnvVariable <$> alphaGen <*> alphaGen - ] +-- | A necessary evil for generators that can generically make sure +-- all constructors of your sum type are covered. The tradeoff is that +-- you have no control over the range at the per-test level, so use +-- this sparingly where full coverage is more valuable than +-- fine-tuning generators. +class HasGen a where + gen :: Gen a + default gen :: (Generic a, GHasGen (G.Rep a)) => Gen a + gen = Gen.choice (fmap G.to <$> ggen) -alphaGen :: Gen Text -alphaGen = T.pack <$> listOf1 gen - where - gen = elements (['a'..'z'] <> ['A'..'Z']) - -instance Arbitrary MinuteSpec where - arbitrary = arbitraryMaybe mkMinuteSpec - +class GHasGen f where + ggen :: [Gen (f a)] -instance Arbitrary HourSpec where - arbitrary = arbitraryMaybe mkHourSpec +instance GHasGen G.U1 where + ggen = [pure G.U1] +instance (HasGen a) => GHasGen (G.K1 i a) where + ggen = [G.K1 <$> gen] -instance Arbitrary DayOfMonthSpec where - arbitrary = arbitraryMaybe mkDayOfMonthSpec +instance (GHasGen a, GHasGen b) => GHasGen (a G.:*: b) where + ggen = [ (G.:*:) <$> f <*> g | f <- ggen, g <- ggen] +instance (GHasGen a, GHasGen b) => GHasGen (a G.:+: b) where + ggen = (fmap G.L1 <$> ggen) <> (fmap G.R1 <$> ggen) -instance Arbitrary MonthSpec where - arbitrary = arbitraryMaybe mkMonthSpec +-- we don't care about metadata, lift over it +instance (GHasGen c) => GHasGen (G.M1 _a _b c) where + ggen = fmap G.M1 <$> ggen -instance Arbitrary DayOfWeekSpec where - arbitrary = arbitraryMaybe mkDayOfWeekSpec - +instance HasGen BaseField +instance HasGen SpecificField +instance HasGen RangeField +instance HasGen Int where + gen = Gen.int Range.linearBounded +instance HasGen Text where + gen = genAlpha +instance HasGen CronField +instance HasGen a => HasGen (NE.NonEmpty a) where + gen = Gen.nonEmpty (Range.linear 1 50) gen +instance HasGen a => HasGen [a] where + gen = Gen.list (Range.linear 0 50) gen +instance HasGen StepField where + gen = Gen.just (mkStepField <$> gen <*> gen) +instance HasGen CronSchedule +instance HasGen Crontab +instance HasGen CronCommand where + gen = CronCommand <$> genAlpha +instance HasGen CrontabEntry +instance HasGen MinuteSpec where + gen = Gen.just (mkMinuteSpec <$> gen) +instance HasGen HourSpec where + gen = Gen.just (mkHourSpec <$> gen) +instance HasGen DayOfMonthSpec where + gen = Gen.just (mkDayOfMonthSpec <$> gen) +instance HasGen DayOfWeekSpec where + gen = Gen.just (mkDayOfWeekSpec <$> gen) +instance HasGen MonthSpec where + gen = Gen.just (mkMonthSpec <$> gen) +instance HasGen UTCTime where + gen = genUTCTime -instance Arbitrary SpecificField where - arbitrary = arbitraryMaybe mkSpecificField +genAlpha :: Gen Text +genAlpha = Gen.text (Range.linear 1 50) Gen.alpha -instance Arbitrary RangeField where - arbitrary = arbitraryMaybe (uncurry mkRangeField) +genUTCTime :: Gen UTCTime +genUTCTime = genUTCTime' (Range.linear 0 maxBound) -instance Arbitrary StepField where - arbitrary = arbitraryMaybe (uncurry mkStepField) +-- | genUTCTime with a range of posix seconds +genUTCTime' :: Range.Range Int -> Gen UTCTime +genUTCTime' = fmap POSIX.posixSecondsToUTCTime . genPOSIXTime -arbitraryMaybe :: Arbitrary a => (a -> Maybe b) -> Gen b -arbitraryMaybe f = do - a <- arbitrary `suchThat` (isJust . f) - return (fromJust (f a)) +genPOSIXTime :: Range.Range Int -> Gen POSIX.POSIXTime +genPOSIXTime rnge = do + fromInteger . toInteger <$> Gen.int rnge mkMinuteSpec' :: CronField -> MinuteSpec diff --git a/test/System/Test/Cron.hs b/test/System/Test/Cron.hs --- a/test/System/Test/Cron.hs +++ b/test/System/Test/Cron.hs @@ -2,9 +2,13 @@ module System.Test.Cron (tests) where ------------------------------------------------------------------------------- -import Data.List (find) -import Data.List.NonEmpty (NonEmpty (..)) +import Control.Monad +import Data.List (find) +import Data.List.NonEmpty (NonEmpty (..)) import Data.Time.Clock.POSIX +import Hedgehog as HH +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range ------------------------------------------------------------------------------- import SpecHelper ------------------------------------------------------------------------------- @@ -107,51 +111,59 @@ scheduleMatches evenMinute t1 @?= False scheduleMatches evenMinute t2 @?= True - , testProperty "star matches everything" $ \t -> - scheduleMatches stars t + , testProperty "star matches everything" $ property $ do + t <- forAll gen + HH.assert (scheduleMatches stars t) - , testProperty "exact time matches" $ \t -> - let (_, m, d, h, mn) = timeComponents t - sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn)))) - (mkHourSpec' (Field (SpecificField' (mkSpecificField' h)))) - (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d)))) - (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m)))) - (mkDayOfWeekSpec' (Field Star)) - in scheduleMatches sched t + , testProperty "exact time matches" $ property $ do + t <- forAll gen + let (_, m, d, h, mn) = timeComponents t + sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn)))) + (mkHourSpec' (Field (SpecificField' (mkSpecificField' h)))) + (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d)))) + (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m)))) + (mkDayOfWeekSpec' (Field Star)) + HH.assert (scheduleMatches sched t) - , testProperty "any time with the same minute as n * * * * matches" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))) } - t = day' y m d h mn - in scheduleMatches sched t + , testProperty "any time with the same minute as n * * * * matches" $ property $ do + (y, m, d, h, mn) <- forAll genTimeFields + let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn))) } + t = day' y m d h mn + HH.assert (scheduleMatches sched t) - , testProperty "any time with the diff minute as n * * * * does not match" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' (stepMax 59 mn)))) } - t = day' y m d h mn - in not $ scheduleMatches sched t + , testProperty "any time with the diff minute as n * * * * does not match" $ property $ do + (y, m, d, h, mn) <- forAll genTimeFields + let sched = stars { minute = mkMinuteSpec' (Field (SpecificField' (mkSpecificField' (stepMax 59 mn)))) } + t = day' y m d h mn + HH.assert (not (scheduleMatches sched t)) - , testProperty "any time with the same hour as * n * * * matches" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' h))) } - t = day' y m d h mn - in scheduleMatches sched t + , testProperty "any time with the same hour as * n * * * matches" $ property $ do + (y, m, d, h, mn) <- forAll genTimeFields + let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' h))) } + t = day' y m d h mn + HH.assert (scheduleMatches sched t) - , testProperty "any time with the diff hour as * n * * * does not match" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' (stepMax 23 h)))) } - t = day' y m d h mn - in not $ scheduleMatches sched t + , testProperty "any time with the diff hour as * n * * * does not match" $ property $ do + (y, m, d, h, mn) <- forAll genTimeFields + let sched = stars { hour = mkHourSpec' (Field (SpecificField' (mkSpecificField' (stepMax 23 h)))) } + t = day' y m d h mn + HH.assert (not (scheduleMatches sched t)) - , testProperty "any time with the same day as * * n * * matches" $ \t -> - let (_, m, d, h, mn) = timeComponents t - sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn)))) - (mkHourSpec' (Field (SpecificField' (mkSpecificField' h)))) - (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d)))) - (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m)))) - (mkDayOfWeekSpec' (Field Star)) - in scheduleMatches sched t + , testProperty "any time with the same day as * * n * * matches" $ property $ do + t <- forAll gen + let (_, m, d, h, mn) = timeComponents t + sched = CronSchedule (mkMinuteSpec' (Field (SpecificField' (mkSpecificField' mn)))) + (mkHourSpec' (Field (SpecificField' (mkSpecificField' h)))) + (mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' d)))) + (mkMonthSpec' (Field (SpecificField' (mkSpecificField' m)))) + (mkDayOfWeekSpec' (Field Star)) + HH.assert (scheduleMatches sched t) - , testProperty "any time with the diff day as * * n * * does not match" $ arbitraryTimeFields $ \y m d h mn -> - let sched = stars { dayOfMonth = mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' (stepMax 31 d)))) } - t = day' y m d h mn - in not $ scheduleMatches sched t + , testProperty "any time with the diff day as * * n * * does not match" $ property $ do + (y, m, d, h, mn) <- forAll genTimeFields + let sched = stars { dayOfMonth = mkDayOfMonthSpec' (Field (SpecificField' (mkSpecificField' (stepMax 31 d)))) } + t = day' y m d h mn + HH.assert (not (scheduleMatches sched t)) ] @@ -159,29 +171,18 @@ day' y m d h mn = UTCTime (fromGregorian y m d) (diffTime h mn) diffTime h mn = timeOfDayToTime $ TimeOfDay h mn 1 -arbitraryTimeFields - :: (Num r - , Num r1 - , Num r2 - , Num r3 - , Ord r - , Ord r1 - , Ord r2 - , Ord r3 - ) - => (a -> r -> r1 -> r2 -> r3 -> t) - -> Positive a - -> Positive r - -> Positive r1 - -> Positive r2 - -> Positive r3 - -> t -arbitraryTimeFields f y m d h mn = f (getPositive y) - (min 12 $ getPositive m) - (min 28 $ getPositive d) - (min 23 $ getPositive h) - (min 59 $ getPositive mn) +genTimeFields + :: Gen (Integer, Int, Int, Int, Int) +genTimeFields = do + y <- Gen.integral (Range.linear 0 9999) + m <- Gen.int (Range.linear 1 12) + d <- Gen.int (Range.linear 1 28) + h <- Gen.int (Range.linear 1 23) + mn <- Gen.int (Range.linear 1 59) + pure (y, m, d, h, mn) + + hoursMins :: DiffTime -> (Int, Int) hoursMins uTime = (hr, mn) where @@ -255,32 +256,49 @@ describeNextMatch :: TestTree describeNextMatch = testGroup "nextMatch" - [ testProperty "is always in the future (at least 1 minute advanced)" $ \cs t -> + [ testProperty "is always in the future (at least 1 minute advanced)" $ property $ do + cs <- forAll gen + t <- forAll gen let tSecs = floor (utcTimeToPOSIXSeconds t) :: Integer minT2 = posixSecondsToUTCTime (fromInteger ((tSecs `div` 60) + 1) * 60) - in case nextMatch cs t of - Just t2 -> t2 >= minT2 - Nothing -> True - , testProperty "always produces a time that will match the schedule" $ \cs t -> case nextMatch cs t of - Just t2 -> counterexample (show t2 <> " does not match " <> show cs) (scheduleMatches cs t2) - Nothing -> property True + Just t2 -> HH.assert (t2 >= minT2) + Nothing -> success + , testProperty "always produces a time that will match the schedule" $ property $ do + cs <- forAll gen + t <- forAll gen + case nextMatch cs t of + Just t2 -> do + unless (scheduleMatches cs t2) $ do + annotate (show t2 <> " does not match " <> show cs) + failure + Nothing -> success -- , testCase "special case" $ do -- let Right cs = parseOnly cronSchedule "* * * * *" -- t = mkTime 1858 11 20 0 0 1 -- nextMatch cs t @?= Just (mkTime 1858 11 20 0 1 0) -- this test has a really variable workload but is usually quite slow because it has to walk minute by minute until it finds the test case, so we'll set an upper bound here - , localOption (QuickCheckTests 20) $ testProperty "returns the first minute in the future that matches" $ \cs t -> + --TODO: resize 20? + , testProperty "returns the first minute in the future that matches" $ property $ do + cs <- forAll gen + t <- forAll gen case nextMatch cs t of Just res -> let mactual = find (scheduleMatches cs) ((takeWhile (<= res) (nextMinutes t))) in case mactual of Just actual -> res `sameMinute` actual - Nothing -> counterexample ("Could not find a next minute match for " <> show t <> ", expected " <> show res) False - Nothing -> property True - , testProperty "a schedule that produces Just for one t will produce it for any t" $ \cs t1 t2 -> isJust (nextMatch cs t1) ==> - counterexample ("nextMatch produced Just for " <> show t1 <> " but not " <> show t2) - (isJust (nextMatch cs t2) == True) + Nothing -> do + annotate ("Could not find a next minute match for " <> show t <> ", expected " <> show res) + failure + Nothing -> success + , testProperty "a schedule that produces Just for one t will produce it for any t" $ property $ do + cs <- forAll gen + t1 <- forAll (Gen.filter (isJust . nextMatch cs) gen) + t2 <- forAll gen + unless (isJust (nextMatch cs t2) == True) $ do + annotate ("nextMatch produced Just for " <> show t1 <> " but not " <> show t2) + failure + , testCase "does not match impossible dates (restricted dow/dom bug)" $ do let t = posixSecondsToUTCTime 0 let cs = stars { month = mkMonthSpec' (Field (SpecificField' (mkSpecificField' 9))) @@ -291,7 +309,7 @@ ] -sameMinute :: UTCTime -> UTCTime -> Property +sameMinute :: (MonadTest m) => UTCTime -> UTCTime -> m () sameMinute t1 t2 = t1' === t2' where t1' = t1 { utctDayTime = roundToMinute (utctDayTime t1)} diff --git a/test/System/Test/Cron/Parser.hs b/test/System/Test/Cron/Parser.hs --- a/test/System/Test/Cron/Parser.hs +++ b/test/System/Test/Cron/Parser.hs @@ -4,6 +4,7 @@ ------------------------------------------------------------------------------- import Data.List.NonEmpty (NonEmpty (..)) import Data.Text (Text) +import Hedgehog ------------------------------------------------------------------------------- import SpecHelper ------------------------------------------------------------------------------- @@ -175,7 +176,8 @@ describeSerializeParseCronSchedule :: TestTree describeSerializeParseCronSchedule = testGroup "serialize/parse CronSchedule" [ - testProperty "roundtrips" $ \cs -> do + testProperty "roundtrips" $ property $ do + cs <- forAll gen parseCronSchedule (serializeCronSchedule cs) === Right cs ] @@ -184,7 +186,8 @@ describeSerializeParseCrontab :: TestTree describeSerializeParseCrontab = testGroup "serialize/parse Crontab" [ - testProperty "roundtrips" $ \ct -> do + testProperty "roundtrips" $ property $ do + ct <- forAll gen parseCrontab (serializeCrontab ct) === Right ct ]