fuzzy-time-gen 0.2.0.1 → 0.3.0.0
raw patch · 7 files changed
+723/−295 lines, 7 filesdep −containersdep ~fuzzy-timedep ~genvalidity
Dependencies removed: containers
Dependency ranges changed: fuzzy-time, genvalidity
Files
- CHANGELOG.md +6/−0
- bench/Bench.hs +1/−2
- fuzzy-time-gen.cabal +4/−9
- src/Data/FuzzyTime/Types/Gen.hs +1/−9
- test/Data/FuzzyTime/ParserSpec.hs +78/−67
- test/Data/FuzzyTime/ResolveSpec.hs +633/−202
- test/Data/FuzzyTime/TypesSpec.hs +0/−6
CHANGELOG.md view
@@ -1,5 +1,11 @@ # Changelog +## [0.3.0.0] - 2023-05-18++### Added++* Compatibility with `fuzzy-time >=0.3`+ ## [0.2.0.1] - 2022-09-24 ### Changed
bench/Bench.hs view
@@ -12,6 +12,5 @@ Criterion.defaultMain [ genValidBench @FuzzyLocalTime, genValidBench @FuzzyTimeOfDay,- genValidBench @FuzzyDay,- genValidBench @Month+ genValidBench @FuzzyDay ]
fuzzy-time-gen.cabal view
@@ -1,17 +1,17 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.7.+-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack name: fuzzy-time-gen-version: 0.2.0.1+version: 0.3.0.0 description: Generators for fuzzy-time types category: Time homepage: https://github.com/NorfairKing/fuzzy-time author: Tom Sydney Kerckhove maintainer: syd@cs-syd.eu-copyright: Copyright: (c) 2017-2021 Tom Sydney Kerckhove+copyright: Copyright: (c) 2017-2022 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple@@ -29,12 +29,9 @@ build-depends: QuickCheck , base >=4.9 && <=5- , containers- , fuzzy-time+ , fuzzy-time >=0.3 , genvalidity >=1.0 , genvalidity-time- , megaparsec- , time default-language: Haskell2010 test-suite fuzzy-time-test@@ -53,10 +50,8 @@ , base >=4.9 && <=5 , fuzzy-time , fuzzy-time-gen- , genvalidity , genvalidity-hspec , genvalidity-text- , genvalidity-time , hspec , megaparsec , text
src/Data/FuzzyTime/Types/Gen.hs view
@@ -7,10 +7,6 @@ import Data.GenValidity.Time () import Test.QuickCheck -instance (GenValid a, GenValid b) => GenValid (Some a b) where- genValid = genValidStructurallyWithoutExtraChecking- shrinkValid = shrinkValidStructurallyWithoutExtraFiltering- instance GenValid AmbiguousLocalTime where genValid = genValidStructurallyWithoutExtraChecking shrinkValid = shrinkValidStructurallyWithoutExtraFiltering@@ -47,12 +43,8 @@ DayInMonth <$> choose (1, 31) <*> choose (1, 12), DiffDays <$> genValid, DiffWeeks <$> genValid,- NextDayOfTheWeek <$> genValid,+ DayOfTheWeek <$> genValid <*> genValid, ExactDay <$> genValid ] `suchThat` isValid- shrinkValid = shrinkValidStructurally--instance GenValid Month where- genValid = genValidStructurally shrinkValid = shrinkValidStructurally
test/Data/FuzzyTime/ParserSpec.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-} module Data.FuzzyTime.ParserSpec ( spec,@@ -15,6 +16,7 @@ import Data.Text (Text) import qualified Data.Text as T import Data.Time+import Data.Time.Calendar.MonthDay (monthLength) import Data.Void import Test.Hspec import Test.Hspec.QuickCheck@@ -30,51 +32,57 @@ let p = parseJustSpec fuzzyLocalTimeP pr = parseJustSpecR fuzzyLocalTimeP f = parseNothingSpec fuzzyLocalTimeP- p "1" (FuzzyLocalTime $ One $ OnlyDay 1)- p "today" (FuzzyLocalTime $ One Today)- p "Today" (FuzzyLocalTime $ One Today)- p "TodAY" (FuzzyLocalTime $ One Today)- p "monday" (FuzzyLocalTime $ One $ NextDayOfTheWeek Monday)- p "Monday" (FuzzyLocalTime $ One $ NextDayOfTheWeek Monday)- p "MoNDay" (FuzzyLocalTime $ One $ NextDayOfTheWeek Monday)- p "8:" (FuzzyLocalTime $ Other $ AtHour 8)- p "09:" (FuzzyLocalTime $ Other $ AtHour 9)- p "05:06" (FuzzyLocalTime $ Other $ AtMinute 5 6)- p "evening" (FuzzyLocalTime $ Other Evening)- p "tues 05:06" (FuzzyLocalTime $ Both (NextDayOfTheWeek Tuesday) (AtMinute 5 6))- p "wed 5:06" (FuzzyLocalTime $ Both (NextDayOfTheWeek Wednesday) (AtMinute 5 6))- p "thu 11:" (FuzzyLocalTime $ Both (NextDayOfTheWeek Thursday) (AtHour 11))- p "8 05:06" (FuzzyLocalTime $ Both (OnlyDay 8) (AtMinute 5 6))- p "02-07 05:06" (FuzzyLocalTime $ Both (DayInMonth 2 7) (AtMinute 5 6))- pr 3 "noon" $ FuzzyLocalTime $ Other Noon- pr 3 "Noon" $ FuzzyLocalTime $ Other Noon- pr 4 "midday" $ FuzzyLocalTime $ Other Noon- pr 4 "Midday" $ FuzzyLocalTime $ Other Noon- pr 4 "midnight" $ FuzzyLocalTime $ Other Midnight- pr 4 "Midnight" $ FuzzyLocalTime $ Other Midnight- pr 3 "morning" $ FuzzyLocalTime $ Other Morning- pr 3 "Morning" $ FuzzyLocalTime $ Other Morning- pr 1 "evening" $ FuzzyLocalTime $ Other Evening- pr 1 "Evening" $ FuzzyLocalTime $ Other Evening- p "6:07" $ FuzzyLocalTime $ Other (AtMinute 6 7)- p "08:09" $ FuzzyLocalTime $ Other (AtMinute 8 9)- p "1011" $ FuzzyLocalTime $ Other (AtMinute 10 11)- p "0324" $ FuzzyLocalTime $ Other (AtMinute 3 24)- p "23:59:22" $ FuzzyLocalTime $ Other $ AtExact (TimeOfDay 23 59 22)- p "5:06:23" $ FuzzyLocalTime $ Other $ AtExact (TimeOfDay 5 6 23)- p "0506:23" $ FuzzyLocalTime $ Other $ AtExact (TimeOfDay 5 6 23)- p "+5h" $ FuzzyLocalTime $ Other (HoursDiff 5)- p "-6h" $ FuzzyLocalTime $ Other (HoursDiff (-6))- p "+7m" $ FuzzyLocalTime $ One (DiffMonths 7)- p "-8m" $ FuzzyLocalTime $ One (DiffMonths (-8))- p "+9s" $ FuzzyLocalTime $ Other (SecondsDiff 9)- p "-10s" $ FuzzyLocalTime $ Other (SecondsDiff (-10))+ p "1" (FuzzyLocalTimeDay $ OnlyDay 1)+ p "1-1" (FuzzyLocalTimeDay $ DayInMonth 1 1)+ p "01-1" (FuzzyLocalTimeDay $ DayInMonth 1 1)+ p "jan-1" (FuzzyLocalTimeDay $ DayInMonth 1 1)+ p "today" (FuzzyLocalTimeDay Today)+ p "Today" (FuzzyLocalTimeDay Today)+ p "TodAY" (FuzzyLocalTimeDay Today)+ p "monday" (FuzzyLocalTimeDay $ DayOfTheWeek Monday 0)+ p "Monday" (FuzzyLocalTimeDay $ DayOfTheWeek Monday 0)+ p "MoNDay" (FuzzyLocalTimeDay $ DayOfTheWeek Monday 0)+ p "mon+1" (FuzzyLocalTimeDay $ DayOfTheWeek Monday 1)+ p "tues-1" (FuzzyLocalTimeDay $ DayOfTheWeek Tuesday (-1))+ p "wed+20" (FuzzyLocalTimeDay $ DayOfTheWeek Wednesday 20)+ p "8:" (FuzzyLocalTimeTimeOfDay $ AtHour 8)+ p "09:" (FuzzyLocalTimeTimeOfDay $ AtHour 9)+ p "05:06" (FuzzyLocalTimeTimeOfDay $ AtMinute 5 6)+ p "evening" (FuzzyLocalTimeTimeOfDay Evening)+ p "tues 05:06" (FuzzyLocalTimeBoth (DayOfTheWeek Tuesday 0) (AtMinute 5 6))+ p "wed 5:06" (FuzzyLocalTimeBoth (DayOfTheWeek Wednesday 0) (AtMinute 5 6))+ p "thu 11:" (FuzzyLocalTimeBoth (DayOfTheWeek Thursday 0) (AtHour 11))+ p "8 05:06" (FuzzyLocalTimeBoth (OnlyDay 8) (AtMinute 5 6))+ p "02-07 05:06" (FuzzyLocalTimeBoth (DayInMonth 2 7) (AtMinute 5 6))+ pr 3 "noon" $ FuzzyLocalTimeTimeOfDay Noon+ pr 3 "Noon" $ FuzzyLocalTimeTimeOfDay Noon+ pr 4 "midday" $ FuzzyLocalTimeTimeOfDay Noon+ pr 4 "Midday" $ FuzzyLocalTimeTimeOfDay Noon+ pr 4 "midnight" $ FuzzyLocalTimeTimeOfDay Midnight+ pr 4 "Midnight" $ FuzzyLocalTimeTimeOfDay Midnight+ pr 3 "morning" $ FuzzyLocalTimeTimeOfDay Morning+ pr 3 "Morning" $ FuzzyLocalTimeTimeOfDay Morning+ pr 1 "evening" $ FuzzyLocalTimeTimeOfDay Evening+ pr 1 "Evening" $ FuzzyLocalTimeTimeOfDay Evening+ p "6:07" $ FuzzyLocalTimeTimeOfDay (AtMinute 6 7)+ p "08:09" $ FuzzyLocalTimeTimeOfDay (AtMinute 8 9)+ p "1011" $ FuzzyLocalTimeTimeOfDay (AtMinute 10 11)+ p "0324" $ FuzzyLocalTimeTimeOfDay (AtMinute 3 24)+ p "23:59:22" $ FuzzyLocalTimeTimeOfDay $ AtExact (TimeOfDay 23 59 22)+ p "5:06:23" $ FuzzyLocalTimeTimeOfDay $ AtExact (TimeOfDay 5 6 23)+ p "0506:23" $ FuzzyLocalTimeTimeOfDay $ AtExact (TimeOfDay 5 6 23)+ p "+5h" $ FuzzyLocalTimeTimeOfDay (HoursDiff 5)+ p "-6h" $ FuzzyLocalTimeTimeOfDay (HoursDiff (-6))+ p "+7m" $ FuzzyLocalTimeDay (DiffMonths 7)+ p "-8m" $ FuzzyLocalTimeDay (DiffMonths (-8))+ p "+9s" $ FuzzyLocalTimeTimeOfDay (SecondsDiff 9)+ p "-10s" $ FuzzyLocalTimeTimeOfDay (SecondsDiff (-10)) f "hello" f "world" describe "twoDigitsSegmentP" $ do- parsesValidSpec twoDigitsSegmentP- let p = parseJustSpec twoDigitsSegmentP- f = parseNothingSpec twoDigitsSegmentP+ parsesValidSpec (twoDigitsSegmentP @Int)+ let p = parseJustSpec $ twoDigitsSegmentP @Int+ f = parseNothingSpec $ twoDigitsSegmentP @Int p "0" 0 p "6" 6 p "01" 1@@ -180,7 +188,8 @@ let s = formatTime defaultTimeLocale "%T%Q" tod in case parseForTest fuzzyTimeOfDayP (T.pack s) of Left e -> expectationFailure $ errorBundlePretty e- Right r -> resolveTimeOfDay tod r `shouldBe` tod+ Right r -> resolveTimeOfDayForwards tod r `shouldBe` Just tod+ describe "HoursDiff" $ do p "+3" (HoursDiff 3) p "-4" (HoursDiff (-4))@@ -206,60 +215,62 @@ let s = parseJustSpec fuzzyDayP let f = parseNothingSpec fuzzyDayP it "parses x as OnlyDay x for x between 1 and 31" $- forAll (choose (1, 31)) $ \i -> parseJust fuzzyDayP (T.pack (show i)) (OnlyDay i)+ forAll (choose (1, 31)) $ \i ->+ parseJust fuzzyDayP (T.pack (show i)) (OnlyDay i) s "+3" (DiffDays 3) s "-3" (DiffDays $ -3) it "Parses +x as DiffDays x" $- forAllValid $ \i -> parseJust fuzzyDayP (T.pack (printf "%+d" i)) (DiffDays i)+ forAllValid $ \i ->+ parseJust fuzzyDayP (T.pack (printf "%+d" i)) (DiffDays i) s "+4d" (DiffDays 4) s "-4d" (DiffDays $ -4) it "Parses +xd as DiffDays x" $- forAllValid $ \i -> parseJust fuzzyDayP (T.pack (printf "%+dd" i)) (DiffDays i)+ forAllValid $ \i ->+ parseJust fuzzyDayP (T.pack (printf "%+dd" i)) (DiffDays i) s "+5w" (DiffWeeks 5) s "-5w" (DiffWeeks $ -5) it "Parses +xw as DiffWeeks x" $- forAllValid $ \i -> parseJust fuzzyDayP (T.pack (printf "%+dw" i)) (DiffWeeks i)+ forAllValid $ \i ->+ parseJust fuzzyDayP (T.pack (printf "%+dw" i)) (DiffWeeks i) s "+6m" (DiffMonths 6) s "-6m" (DiffMonths $ -6) it "Parses +xw as DiffMonths x" $- forAllValid $ \i -> parseJust fuzzyDayP (T.pack (printf "%+dm" i)) (DiffMonths i)+ forAllValid $ \i ->+ parseJust fuzzyDayP (T.pack (printf "%+dm" i)) (DiffMonths i) f "0-0" s "2-13" (DayInMonth 2 13) s "12-3" (DayInMonth 12 3) s "02-13" (DayInMonth 2 13) s "12-03" (DayInMonth 12 3) s "02-03" (DayInMonth 2 3)+ s "oCT-01" (DayInMonth 10 1)+ s "Nov-02" (DayInMonth 11 2)+ s "dec-03" (DayInMonth 12 3) f "002-03" f "02-003" f "002-003" modifyMaxSuccess (\x -> (x * (365 * 4)) `div` 100) $ it "parses m-d (in any format) as DayInMonth" $- forAll (elements $ daysInMonth 2004) $ \(month, mds) ->- let m = monthNum month+ forAll (choose (1, 12)) $ \m ->+ let mds = fromIntegral $ monthLength False m in forAll (choose (1, mds)) $ \d -> let options = nub $ do ms <- [printf "%d" m, printf "%02d" m] ds <- [printf "%d" d, printf "%02d" d] pure $ T.pack $ concat [ms, "-", ds] :: [Text]- in forAll (elements options) $ \s_ -> parseJust fuzzyDayP s_ (DayInMonth m d)- it "parses whatever the fuzzy day parser parses, as the next day of the week" $- forAllValid $ \t ->- case (,) <$> parse (fuzzyDayOfTheWeekP <* eof) "test input" t- <*> parse (fuzzyDayP <* eof) "test input" t of- Left _ -> pure ()- Right (dow, fd_) ->- case fd_ of- NextDayOfTheWeek dow' -> dow' `shouldBe` dow- _ -> expectationFailure "fuzzyDayP parsed something other than a day of the week"- it "parses the day of the week string as NextDayOfTheWeek" $+ in forAll (elements options) $ \s_ -> parseJust fuzzyDayP s_ (DayInMonth (fromIntegral m) d)++ it "parses the day of the week string as DayOfTheWeek" $ forAll (elements dayOfTheWeekStrings) $ \(dow, i, t) -> forAll (elements $ drop i $ T.inits t) $ \t_ ->- parseJust fuzzyDayP t_ (NextDayOfTheWeek dow)+ parseJust fuzzyDayP t_ (DayOfTheWeek dow 0)+ describe "fuzzyDayOfTheWeekP" $ do parsesValidSpec fuzzyDayOfTheWeekP let fd = parseJustSpecR fuzzyDayOfTheWeekP- forM_ dayOfTheWeekStrings $ \(dow, ix, s) -> fd ix s dow+ forM_ dayOfTheWeekStrings $ \(dow, ix, s) ->+ fd ix s (DayOfTheWeek dow 0) dayOfTheWeekStrings :: [(DayOfWeek, Int, Text)] dayOfTheWeekStrings =@@ -285,10 +296,10 @@ parseJustSpec :: (Show a, Eq a) => Parser a -> Text -> a -> Spec parseJustSpec p s res = it (unwords ["parses", show s, "as", show res]) $ parseJust p s res -parseNothingSpec :: (Show a, Eq a) => Parser a -> Text -> Spec+parseNothingSpec :: (Show a) => Parser a -> Text -> Spec parseNothingSpec p s = it (unwords ["fails to parse", show s]) $ parseNothing p s -parsesValidSpec :: (Show a, Eq a, Validity a) => Parser a -> Spec+parsesValidSpec :: (Show a, Validity a) => Parser a -> Spec parsesValidSpec p = it "only parses valid values" $ forAllValid $ parsesValid p parseJust :: (Show a, Eq a) => Parser a -> Text -> a -> Expectation@@ -299,7 +310,7 @@ expectationFailure $ unlines ["Parser failed on input", show s, "with error", errorBundlePretty err] -parseNothing :: (Show a, Eq a) => Parser a -> Text -> Expectation+parseNothing :: (Show a) => Parser a -> Text -> Expectation parseNothing p s = case parseForTest p s of Left _ -> pure ()@@ -308,7 +319,7 @@ unlines ["Parser succeeded on input", show s, "at parsing", show v, "but it should have failed."] -parsesValid :: (Show a, Eq a, Validity a) => Parser a -> Text -> Expectation+parsesValid :: (Show a, Validity a) => Parser a -> Text -> Expectation parsesValid p s = case parseForTest p s of Left _ -> pure ()
test/Data/FuzzyTime/ResolveSpec.hs view
@@ -13,257 +13,688 @@ spec :: Spec spec = do- describe "resolveLocalTime" $ do- it "produces valid local times" $ producesValid2 resolveLocalTime- it "works the same as resolveLocalTimeOne" $- forAllValid $- \lt ->+ describe "resolveLocalTimeForwards" $ do+ it "produces valid local times" $ producesValid2 resolveLocalTimeForwards++ it "works for unspecified noon, before noon" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (< midday)) $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Noon)+ `shouldBe` Just (BothTimeAndDay (LocalTime ld midday))++ it "works for unspecified noon, after noon" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (>= midday)) $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Noon)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) midday))++ it "works for unspecified midnight" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Midnight)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) midnight))++ it "works for unspecified morning, before morning" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (< morning)) $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Morning)+ `shouldBe` Just (BothTimeAndDay (LocalTime ld morning))++ it "works for unspecified morning, after morning" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (>= morning)) $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Morning)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) morning))++ it "works for unspecified evening, before evening" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (< evening)) $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Evening)+ `shouldBe` Just (BothTimeAndDay (LocalTime ld evening))++ it "works for unspecified evening, after evening" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (>= evening)) $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Evening)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) evening))++ describe "SameTime" $ do+ it "works like resolveDayForwards if the fuzzy time of day is SameTime" $+ forAllValid $ \lt@(LocalTime ld tod) -> forAllValid $ \fd ->- resolveLocalTime lt (FuzzyLocalTime (One fd))- `shouldBe` OnlyDaySpecified (resolveLocalTimeOne lt fd)- it "works the same as resolveLocalTimeOther" $- forAllValid $- \lt ->+ resolveLocalTimeForwards lt (FuzzyLocalTimeBoth fd SameTime)+ `shouldBe` BothTimeAndDay <$> (LocalTime <$> resolveDayForwards ld fd <*> pure tod)++ describe "Yesterday" $ do+ it "works without diff" $+ forAllValid $ \lt@(LocalTime ld ltod) -> forAllValid $ \ftod ->- resolveLocalTime lt (FuzzyLocalTime (Other ftod))- `shouldBe` BothTimeAndDay (resolveLocalTimeOther lt ftod)- it "works the same as resolveLocalTimeBoth" $- forAllValid $- \lt ->+ resolveLocalTimeForwards lt (FuzzyLocalTimeBoth Yesterday ftod)+ `shouldBe` BothTimeAndDay <$> (LocalTime <$> resolveDayForwards ld Yesterday <*> resolveTimeOfDayForwards ltod ftod)++ it "works for noon yesterday" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeBoth Yesterday Noon)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) midday))++ it "works for midnight yesterday" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeBoth Yesterday Midnight)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) midnight))++ it "works for morning yesterday" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeBoth Yesterday Morning)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) morning))++ it "works for evening yesterday" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeBoth Yesterday Evening)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) evening))++ describe "Tomorrow" $ do+ it "works without diff" $+ forAllValid $ \lt@(LocalTime ld ltod) ->+ forAllValid $ \ftod ->+ resolveLocalTimeForwards lt (FuzzyLocalTimeBoth Tomorrow ftod)+ `shouldBe` BothTimeAndDay <$> (LocalTime <$> resolveDayForwards ld Tomorrow <*> resolveTimeOfDayForwards ltod ftod)++ it "works for noon tomorrow" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeBoth Tomorrow Noon)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) midday))++ it "works for midnight tomorrow" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeBoth Tomorrow Midnight)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) midnight))++ it "works for morning tomorrow" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeBoth Tomorrow Morning)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) morning))++ it "works for evening tomorrow" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeForwards (LocalTime ld tod) (FuzzyLocalTimeBoth Tomorrow Evening)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) evening))++ describe "resolveLocalTimeBackwards" $ do+ it "produces valid local times" $ producesValid2 resolveLocalTimeBackwards++ it "works for unspecified noon, before noon" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (< midday)) $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Noon)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) midday))++ it "works for unspecified noon, after noon" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (>= midday)) $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Noon)+ `shouldBe` Just (BothTimeAndDay (LocalTime ld midday))++ it "works for unspecified midnight" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Midnight)+ `shouldBe` Just (BothTimeAndDay (LocalTime ld midnight))++ it "works for unspecified morning, before morning" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (< morning)) $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Morning)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) morning))++ it "works for unspecified morning, after morning" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (>= morning)) $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Morning)+ `shouldBe` Just (BothTimeAndDay (LocalTime ld morning))++ it "works for unspecified evening, before evening" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (< evening)) $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Evening)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) evening))++ it "works for unspecified evening, after evening" $+ forAllValid $ \ld ->+ forAll (genValid `suchThat` (>= evening)) $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeTimeOfDay Evening)+ `shouldBe` Just (BothTimeAndDay (LocalTime ld evening))++ describe "SameTime" $ do+ it "works like resolveDayBackwards if the fuzzy time of day is SameTime" $+ forAllValid $ \lt@(LocalTime ld tod) -> forAllValid $ \fd ->- forAllValid $ \ftod ->- resolveLocalTime lt (FuzzyLocalTime (Both fd ftod))- `shouldBe` BothTimeAndDay (resolveLocalTimeBoth lt fd ftod)- describe "resolveLocalTimeOther" $ do- it "works for unspecified noon, before noon" $- forAllValid $- \ld ->- forAll (genValid `suchThat` (< midday)) $ \tod ->- resolveLocalTimeOther (LocalTime ld tod) Noon `shouldBe` LocalTime ld midday- it "works for unspecified noon, after noon" $- forAllValid $- \ld ->- forAll (genValid `suchThat` (>= midday)) $ \tod ->- resolveLocalTimeOther (LocalTime ld tod) Noon `shouldBe` LocalTime (addDays 1 ld) midday- it "works for unspecified midnight" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeOther (LocalTime ld tod) Midnight- `shouldBe` LocalTime (addDays 1 ld) midnight- it "works for unspecified morning, before morning" $- forAllValid $- \ld ->- forAll (genValid `suchThat` (< morning)) $ \tod ->- resolveLocalTimeOther (LocalTime ld tod) Morning `shouldBe` LocalTime ld morning- it "works for unspecified morning, after morning" $- forAllValid $- \ld ->- forAll (genValid `suchThat` (>= morning)) $ \tod ->- resolveLocalTimeOther (LocalTime ld tod) Morning- `shouldBe` LocalTime (addDays 1 ld) morning- it "works for unspecified evening, before evening" $- forAllValid $- \ld ->- forAll (genValid `suchThat` (< evening)) $ \tod ->- resolveLocalTimeOther (LocalTime ld tod) Evening `shouldBe` LocalTime ld evening- it "works for unspecified evening, after evening" $- forAllValid $- \ld ->- forAll (genValid `suchThat` (>= evening)) $ \tod ->- resolveLocalTimeOther (LocalTime ld tod) Evening- `shouldBe` LocalTime (addDays 1 ld) evening- describe "resolveLocalTimeBoth" $ do- describe "SameTime" $ do- it "works like resolveDay if the fuzzy time of day is SameTime" $- forAllValid $- \lt@(LocalTime ld tod) ->- forAllValid $ \fd ->- resolveLocalTimeBoth lt fd SameTime `shouldBe` LocalTime (resolveDay ld fd) tod- describe "Yesterday" $ do- it "works without diff" $- forAllValid $- \lt@(LocalTime ld ltod) ->- forAllValid $ \ftod ->- resolveLocalTimeBoth lt Yesterday ftod- `shouldBe` LocalTime (resolveDay ld Yesterday) (resolveTimeOfDay ltod ftod)- it "works for noon yesterday" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeBoth (LocalTime ld tod) Yesterday Noon- `shouldBe` LocalTime (addDays (-1) ld) midday- it "works for midnight yesterday" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeBoth (LocalTime ld tod) Yesterday Midnight- `shouldBe` LocalTime (addDays (-1) ld) midnight- it "works for morning yesterday" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeBoth (LocalTime ld tod) Yesterday Morning- `shouldBe` LocalTime (addDays (-1) ld) morning- it "works for evening yesterday" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeBoth (LocalTime ld tod) Yesterday Evening- `shouldBe` LocalTime (addDays (-1) ld) evening- describe "Tomorrow" $ do- it "works without diff" $- forAllValid $- \lt@(LocalTime ld ltod) ->- forAllValid $ \ftod ->- resolveLocalTimeBoth lt Tomorrow ftod- `shouldBe` LocalTime (resolveDay ld Tomorrow) (resolveTimeOfDay ltod ftod)- it "works for noon tomorrow" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeBoth (LocalTime ld tod) Tomorrow Noon- `shouldBe` LocalTime (addDays 1 ld) midday- it "works for midnight tomorrow" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeBoth (LocalTime ld tod) Tomorrow Midnight- `shouldBe` LocalTime (addDays 1 ld) midnight- it "works for morning tomorrow" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeBoth (LocalTime ld tod) Tomorrow Morning- `shouldBe` LocalTime (addDays 1 ld) morning- it "works for evening tomorrow" $- forAllValid $- \ld ->- forAllValid $ \tod ->- resolveLocalTimeBoth (LocalTime ld tod) Tomorrow Evening- `shouldBe` LocalTime (addDays 1 ld) evening+ resolveLocalTimeBackwards lt (FuzzyLocalTimeBoth fd SameTime)+ `shouldBe` BothTimeAndDay <$> (LocalTime <$> resolveDayBackwards ld fd <*> pure tod)++ describe "Yesterday" $ do+ it "works without diff" $+ forAllValid $ \lt@(LocalTime ld ltod) ->+ forAllValid $ \ftod ->+ resolveLocalTimeBackwards lt (FuzzyLocalTimeBoth Yesterday ftod)+ `shouldBe` BothTimeAndDay <$> (LocalTime <$> resolveDayBackwards ld Yesterday <*> resolveTimeOfDayBackwards ltod ftod)++ it "works for noon yesterday" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeBoth Yesterday Noon)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) midday))++ it "works for midnight yesterday" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeBoth Yesterday Midnight)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) midnight))++ it "works for morning yesterday" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeBoth Yesterday Morning)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) morning))++ it "works for evening yesterday" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeBoth Yesterday Evening)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays (-1) ld) evening))++ describe "Tomorrow" $ do+ it "works without diff" $+ forAllValid $ \lt@(LocalTime ld ltod) ->+ forAllValid $ \ftod ->+ resolveLocalTimeBackwards lt (FuzzyLocalTimeBoth Tomorrow ftod)+ `shouldBe` BothTimeAndDay <$> (LocalTime <$> resolveDayBackwards ld Tomorrow <*> resolveTimeOfDayBackwards ltod ftod)++ it "works for noon tomorrow" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeBoth Tomorrow Noon)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) midday))++ it "works for midnight tomorrow" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeBoth Tomorrow Midnight)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) midnight))++ it "works for morning tomorrow" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeBoth Tomorrow Morning)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) morning))++ it "works for evening tomorrow" $+ forAllValid $ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBackwards (LocalTime ld tod) (FuzzyLocalTimeBoth Tomorrow Evening)+ `shouldBe` Just (BothTimeAndDay (LocalTime (addDays 1 ld) evening))+ describe "normaliseTimeOfDay" $ do it "produces valid times of day" $ producesValid3 normaliseTimeOfDay+ it "works for this example of tomorrow" $ normaliseTimeOfDay 25 0 0 `shouldBe` (1, TimeOfDay 1 0 0)+ it "works for this example of tomorrow" $ normaliseTimeOfDay 23 120 0 `shouldBe` (1, TimeOfDay 1 0 0)+ it "works for this example of tomorrow" $ normaliseTimeOfDay 23 0 7200 `shouldBe` (1, TimeOfDay 1 0 0)+ it "works for this example of tomorrow" $ normaliseTimeOfDay 23 120 7200 `shouldBe` (1, TimeOfDay 3 0 0)+ it "works for this example of yesterday" $ normaliseTimeOfDay (-1) 0 0 `shouldBe` (-1, TimeOfDay 23 0 0)+ it "works for this example of yesterday" $ normaliseTimeOfDay 0 (-1) 0 `shouldBe` (-1, TimeOfDay 23 59 0)+ it "works for this example of yesterday" $ normaliseTimeOfDay 0 0 (-1) `shouldBe` (-1, TimeOfDay 23 59 59)+ it "works for this example of yesterday" $ normaliseTimeOfDay 0 0 (-0.01) `shouldBe` (-1, TimeOfDay 23 59 59.99)+ it "works for this example of yesterday" $ normaliseTimeOfDay 0 0 (-0.00001) `shouldBe` (-1, TimeOfDay 23 59 59.99999)+ it "works for this example of yesterday" $ normaliseTimeOfDay 0 0 (-0.00000001) `shouldBe` (-1, TimeOfDay 23 59 59.99999999)+ it "does something sensible with leap seconds" $ normaliseTimeOfDay 23 59 60 `shouldBe` (1, TimeOfDay 0 0 0)- describe "resolveTimeOfDay" $ do- it "produces valid times of day" $ producesValid2 resolveTimeOfDay- it "works for sametime " $ forAllValid $ \tod -> resolveTimeOfDay tod SameTime `shouldBe` tod++ describe "resolveTimeOfDayForwards" $ do+ it "produces valid times of day" $+ producesValid2 resolveTimeOfDayForwards++ it "works for sametime " $+ forAllValid $ \tod ->+ resolveTimeOfDayForwards tod SameTime `shouldBe` Just tod+ it "works for noon " $- forAllValid $- \tod -> resolveTimeOfDay tod Noon `shouldBe` TimeOfDay 12 0 0+ forAllValid $ \tod ->+ resolveTimeOfDayForwards tod Noon `shouldBe` Just (TimeOfDay 12 0 0)+ it "works for midnight " $- forAllValid $- \tod -> resolveTimeOfDay tod Midnight `shouldBe` TimeOfDay 0 0 0+ forAllValid $ \tod ->+ resolveTimeOfDayForwards tod Midnight `shouldBe` Just (TimeOfDay 0 0 0)+ it "works for morning " $- forAllValid $- \tod -> resolveTimeOfDay tod Morning `shouldBe` TimeOfDay 6 0 0+ forAllValid $ \tod ->+ resolveTimeOfDayForwards tod Morning `shouldBe` Just (TimeOfDay 6 0 0)+ it "works for evening" $- forAllValid $- \tod -> resolveTimeOfDay tod Evening `shouldBe` TimeOfDay 18 0 0+ forAllValid $ \tod ->+ resolveTimeOfDayForwards tod Evening `shouldBe` Just (TimeOfDay 18 0 0)+ it "works for atHour" $- forAllValid $- \tod ->- forAllValid $ \h -> resolveTimeOfDay tod (AtHour h) `shouldBe` TimeOfDay h 0 0+ forAllValid $ \tod ->+ forAllValid $ \h ->+ resolveTimeOfDayForwards tod (AtHour h) `shouldBe` Just (TimeOfDay h 0 0)+ it "works for atMinute" $- forAllValid $- \tod ->- forAllValid $ \h ->- forAllValid $ \m -> resolveTimeOfDay tod (AtMinute h m) `shouldBe` TimeOfDay h m 0+ forAllValid $ \tod ->+ forAllValid $ \h ->+ forAllValid $ \m ->+ resolveTimeOfDayForwards tod (AtMinute h m) `shouldBe` Just (TimeOfDay h m 0)+ it "works for atExact" $- forAllValid $- \tod1 ->- forAllValid $ \tod2 -> resolveTimeOfDay tod1 (AtExact tod2) `shouldBe` tod2+ forAllValid $ \tod1 ->+ forAllValid $ \tod2 ->+ resolveTimeOfDayForwards tod1 (AtExact tod2) `shouldBe` Just tod2+ xdescribe "Don't actually hold" $ do it "has an inverse with (small) hoursDiff" $- forAllValid $- \tod ->- forAll (choose (-(24 - 1), 24 - 1)) $ \hd ->- resolveTimeOfDay (resolveTimeOfDay tod (HoursDiff hd)) (HoursDiff (-hd)) `shouldBe` tod+ forAllValid $ \tod ->+ forAll (choose (-(24 - 1), 24 - 1)) $ \hd ->+ ( resolveTimeOfDayForwards tod (HoursDiff hd)+ >>= (\tod' -> resolveTimeOfDayForwards tod' (HoursDiff (-hd)))+ )+ `shouldBe` Just tod+ it "has an inverse with (small) minutesDiff" $- forAllValid $- \tod ->- forAll (choose (-(24 * 60 - 1), 24 * 60 - 1)) $ \md ->- resolveTimeOfDay (resolveTimeOfDay tod (MinutesDiff md)) (MinutesDiff (-md))- `shouldBe` tod+ forAllValid $ \tod ->+ forAll (choose (-(24 * 60 - 1), 24 * 60 - 1)) $ \md ->+ ( resolveTimeOfDayForwards tod (MinutesDiff md)+ >>= (\tod' -> resolveTimeOfDayForwards tod' (MinutesDiff (-md)))+ )+ `shouldBe` Just tod+ it "has an inverse with (small) secondsDiff" $- forAllValid $- \tod ->- forAll (max (-1000) . min 1000 <$> genValid) $ \sd ->- resolveTimeOfDay (resolveTimeOfDay tod (SecondsDiff sd)) (SecondsDiff (-sd))- `shouldBe` tod- describe "resolveDay" $ do- it "produces valid days" $ producesValid2 resolveDay+ forAllValid $ \tod ->+ forAll (max (-1000) . min 1000 <$> genValid) $ \sd ->+ ( resolveTimeOfDayForwards tod (SecondsDiff sd)+ >>= (\tod' -> resolveTimeOfDayForwards tod' (SecondsDiff (-sd)))+ )+ `shouldBe` Just tod++ describe "resolveTimeOfDayBackwards" $ do+ it "produces valid times of day" $+ producesValid2 resolveTimeOfDayBackwards++ it "works for sametime " $+ forAllValid $ \tod ->+ resolveTimeOfDayBackwards tod SameTime `shouldBe` Just tod++ it "works for noon " $+ forAllValid $ \tod ->+ resolveTimeOfDayBackwards tod Noon `shouldBe` Just (TimeOfDay 12 0 0)++ it "works for midnight " $+ forAllValid $ \tod ->+ resolveTimeOfDayBackwards tod Midnight `shouldBe` Just (TimeOfDay 0 0 0)++ it "works for morning " $+ forAllValid $ \tod ->+ resolveTimeOfDayBackwards tod Morning `shouldBe` Just (TimeOfDay 6 0 0)++ it "works for evening" $+ forAllValid $ \tod ->+ resolveTimeOfDayBackwards tod Evening `shouldBe` Just (TimeOfDay 18 0 0)++ it "works for atHour" $+ forAllValid $ \tod ->+ forAllValid $ \h ->+ resolveTimeOfDayBackwards tod (AtHour h) `shouldBe` Just (TimeOfDay h 0 0)++ it "works for atMinute" $+ forAllValid $ \tod ->+ forAllValid $ \h ->+ forAllValid $ \m ->+ resolveTimeOfDayBackwards tod (AtMinute h m) `shouldBe` Just (TimeOfDay h m 0)++ it "works for atExact" $+ forAllValid $ \tod1 ->+ forAllValid $ \tod2 ->+ resolveTimeOfDayBackwards tod1 (AtExact tod2) `shouldBe` Just tod2++ xdescribe "Don't actually hold" $ do+ it "has an inverse with (small) hoursDiff" $+ forAllValid $ \tod ->+ forAll (choose (-(24 - 1), 24 - 1)) $ \hd ->+ ( resolveTimeOfDayBackwards tod (HoursDiff hd)+ >>= (\tod' -> resolveTimeOfDayBackwards tod' (HoursDiff (-hd)))+ )+ `shouldBe` Just tod++ it "has an inverse with (small) minutesDiff" $+ forAllValid $ \tod ->+ forAll (choose (-(24 * 60 - 1), 24 * 60 - 1)) $ \md ->+ ( resolveTimeOfDayBackwards tod (MinutesDiff md)+ >>= (\tod' -> resolveTimeOfDayBackwards tod' (MinutesDiff (-md)))+ )+ `shouldBe` Just tod++ it "has an inverse with (small) secondsDiff" $+ forAllValid $ \tod ->+ forAll (max (-1000) . min 1000 <$> genValid) $ \sd ->+ ( resolveTimeOfDayBackwards tod (SecondsDiff sd)+ >>= (\tod' -> resolveTimeOfDayBackwards tod' (SecondsDiff (-sd)))+ )+ `shouldBe` Just tod++ describe "nextDayOfMonth" $ do+ it "produces valid days" $+ producesValid2 nextDayOfMonth++ it "finds next days" $+ forAllValid $ \d ->+ forAllValid $ \di ->+ case nextDayOfMonth d di of+ Nothing -> pure () -- Fine+ Just d' -> d' `shouldSatisfy` (> d)++ it "finds the next 17th of the month in january" $+ nextDayOfMonth (fromGregorian 2023 02 01) 17+ `shouldBe` Just (fromGregorian 2023 02 17)++ it "finds the next 17th of the month in january" $+ nextDayOfMonth (fromGregorian 2023 02 18) 17+ `shouldBe` Just (fromGregorian 2023 03 17)++ describe "previousDayOfMonth" $ do+ it "produces valid days" $+ producesValid2 previousDayOfMonth++ it "finds previous days" $+ forAllValid $ \d ->+ forAllValid $ \di ->+ case previousDayOfMonth d di of+ Nothing -> pure () -- Fine+ Just d' -> d' `shouldSatisfy` (< d)++ it "finds the previous 17th of the month in january" $+ previousDayOfMonth (fromGregorian 2023 02 01) 17+ `shouldBe` Just (fromGregorian 2023 01 17)++ it "finds the previous 17th of the month in january" $+ previousDayOfMonth (fromGregorian 2023 02 18) 17+ `shouldBe` Just (fromGregorian 2023 02 17)++ describe "nextDayOfMonthOfYear" $ do+ it "produces valid days" $+ producesValid3 nextDayOfMonthOfYear++ it "finds next days" $+ forAllValid $ \d ->+ forAllValid $ \w ->+ forAllValid $ \di ->+ case nextDayOfMonthOfYear d w di of+ Nothing -> pure () -- Fine+ Just d' -> d' `shouldSatisfy` (> d)++ it "finds the next 17th of the month in march" $+ nextDayOfMonthOfYear (fromGregorian 2023 02 01) 03 17+ `shouldBe` Just (fromGregorian 2023 03 17)++ it "finds the next 17th of the month in january" $+ nextDayOfMonthOfYear (fromGregorian 2023 02 18) 01 17+ `shouldBe` Just (fromGregorian 2024 01 17)++ describe "previousDayOfMonthOfYear" $ do+ it "produces valid days" $+ producesValid3 previousDayOfMonthOfYear++ it "finds previous days" $+ forAllValid $ \d ->+ forAllValid $ \w ->+ forAllValid $ \di ->+ case previousDayOfMonthOfYear d w di of+ Nothing -> pure () -- Fine+ Just d' -> d' `shouldSatisfy` (< d)++ it "finds the previous 17th of the month in march" $+ previousDayOfMonthOfYear (fromGregorian 2023 02 01) 03 17+ `shouldBe` Just (fromGregorian 2022 03 17)++ it "finds the previous 17th of the month in january" $+ previousDayOfMonthOfYear (fromGregorian 2023 02 18) 01 17+ `shouldBe` Just (fromGregorian 2023 01 17)++ describe "nextDayOfWeek" $ do+ it "produces valid values" $+ producesValid2 nextDayOfWeek++ it "finds next days" $+ forAllValid $ \d ->+ forAllValid $ \dow ->+ nextDayOfWeek d dow `shouldSatisfy` (> d)++ it "finds the day in this week" $+ nextDayOfWeek (fromGregorian 2024 01 18) Friday+ `shouldBe` fromGregorian 2024 01 19++ it "finds the day in next week" $+ nextDayOfWeek (fromGregorian 2024 01 18) Monday+ `shouldBe` fromGregorian 2024 01 22++ describe "previousDayOfWeek" $ do+ it "produces valid values" $+ producesValid2 previousDayOfWeek++ it "finds previous days" $+ forAllValid $ \d ->+ forAllValid $ \dow ->+ previousDayOfWeek d dow `shouldSatisfy` (< d)++ it "finds the day in this week" $+ previousDayOfWeek (fromGregorian 2024 01 18) Friday+ `shouldBe` fromGregorian 2024 01 12++ it "finds the day in next week" $+ previousDayOfWeek (fromGregorian 2024 01 18) Monday+ `shouldBe` fromGregorian 2024 01 15++ describe "resolveDayForwards" $ do+ it "produces valid days" $ producesValid2 resolveDayForwards+ it "works for this example for Yesterday" $- resolveDay (fromGregorian 2000 6 25) Yesterday `shouldBe` fromGregorian 2000 6 24- it "is id for Now" $ forAllValid $ \d -> resolveDay d Now `shouldBe` d- it "is id for Today" $ forAllValid $ \d -> resolveDay d Today `shouldBe` d+ resolveDayForwards (fromGregorian 2000 6 25) Yesterday+ `shouldBe` Just (fromGregorian 2000 6 24)++ it "is id for Now" $+ forAllValid $ \d ->+ resolveDayForwards d Now `shouldBe` Just d++ it "is id for Today" $+ forAllValid $ \d ->+ resolveDayForwards d Today `shouldBe` Just d+ it "works for this example for Tomorrow" $- resolveDay (fromGregorian 2001 6 23) Tomorrow `shouldBe` fromGregorian 2001 6 24+ resolveDayForwards (fromGregorian 2001 6 23) Tomorrow+ `shouldBe` Just (fromGregorian 2001 6 24)+ it "produces valid values when given 'OnlyDay' values" $- forAllValid $- \d ->- forAllShrink ((OnlyDay <$> genValid) `suchThat` isValid) shrinkValid $ \fd ->- shouldBeValid $ resolveDay d fd+ forAllValid $ \d ->+ forAllShrink ((OnlyDay <$> genValid) `suchThat` isValid) shrinkValid $ \fd ->+ shouldBeValid $ resolveDayForwards d fd+ it "works for OnlyDay for this example where the current date is before the given day" $- resolveDay (fromGregorian 2001 6 23) (OnlyDay 24) `shouldBe` fromGregorian 2001 6 24+ resolveDayForwards (fromGregorian 2001 6 23) (OnlyDay 24)+ `shouldBe` Just (fromGregorian 2001 6 24)+ it "works for OnlyDay for this example where the current date is after the given day" $- resolveDay (fromGregorian 2001 6 23) (OnlyDay 5) `shouldBe` fromGregorian 2001 7 5+ resolveDayForwards (fromGregorian 2001 6 23) (OnlyDay 5)+ `shouldBe` Just (fromGregorian 2001 7 5)+ it "works for OnlyDay for this example where the following given day is not in this month" $- resolveDay (fromGregorian 2001 2 23) (OnlyDay 29) `shouldBe` fromGregorian 2001 3 29- it "works for OnlyDay for this example where the following given day is not in next month" $- resolveDay (fromGregorian 2001 1 30) (OnlyDay 29) `shouldBe` fromGregorian 2001 3 29+ resolveDayForwards (fromGregorian 2001 2 23) (OnlyDay 29)+ `shouldBe` Just (fromGregorian 2001 3 29)++ it "does not work for OnlyDay for this example where the following given day is not in next month" $+ resolveDayForwards (fromGregorian 2001 1 30) (OnlyDay 29)+ `shouldBe` Nothing+ it "works for OnlyDay for this example where the following given day is not in next month" $- resolveDay (fromGregorian 2001 12 30) (OnlyDay 5) `shouldBe` fromGregorian 2002 1 5+ resolveDayForwards (fromGregorian 2001 12 30) (OnlyDay 5)+ `shouldBe` Just (fromGregorian 2002 1 5)+ it "produces valid values when given 'DayInMonth' values" $- forAllValid $- \d ->- forAllShrink (((\(mi, di) -> DayInMonth (max 0 (min 12 mi)) (max 0 (min 31 di))) <$> genValid) `suchThat` isValid) shrinkValid $ \fd ->- shouldBeValid $ resolveDay d fd+ forAllValid $ \d ->+ forAllShrink (((\(mi, di) -> DayInMonth (max 0 (min 12 mi)) (max 0 (min 31 di))) <$> genValid) `suchThat` isValid) shrinkValid $ \fd ->+ shouldBeValid $ resolveDayForwards d fd+ it "works for DayInMonth for this example where the current date is before the given day" $- resolveDay (fromGregorian 2001 6 23) (DayInMonth 6 24) `shouldBe` fromGregorian 2001 6 24+ resolveDayForwards (fromGregorian 2001 6 23) (DayInMonth 6 24)+ `shouldBe` Just (fromGregorian 2001 6 24)+ it "works for DayInMonth for this example where the current date is after the given day" $- resolveDay (fromGregorian 2001 6 23) (DayInMonth 6 5) `shouldBe` fromGregorian 2002 6 5+ resolveDayForwards (fromGregorian 2001 6 23) (DayInMonth 6 5)+ `shouldBe` Just (fromGregorian 2002 6 5)+ it "works for DayInMonth for this example accross years" $- resolveDay (fromGregorian 2001 1 30) (DayInMonth 1 5) `shouldBe` fromGregorian 2002 1 5- it "works for DayInMonth for this example for february 29th" $- resolveDay (fromGregorian 2001 1 30) (DayInMonth 2 29) `shouldBe` fromGregorian 2004 2 29+ resolveDayForwards (fromGregorian 2001 1 30) (DayInMonth 1 5)+ `shouldBe` Just (fromGregorian 2002 1 5)++ it "does not work for DayInMonth for this example for february 29th" $+ resolveDayForwards (fromGregorian 2001 1 30) (DayInMonth 2 29)+ `shouldBe` Nothing++ it "produces valid values when given 'DayOfTheWeek' values" $+ forAllValid $ \d ->+ forAllShrink ((DayOfTheWeek <$> genValid <*> genValid) `suchThat` isValid) shrinkValid $ \fd ->+ shouldBeValid $ resolveDayForwards d fd++ it "works for DayOfTheWeek with a day of the week after today in the current week" $+ resolveDayForwards (fromGregorian 2018 10 9) (DayOfTheWeek Thursday 0)+ `shouldBe` Just (fromGregorian 2018 10 11)++ it "works for DayOfTheWeek with a day of the week after today in the next week" $+ resolveDayForwards (fromGregorian 2018 10 9) (DayOfTheWeek Monday 0)+ `shouldBe` Just (fromGregorian 2018 10 15)+ it+ "works for DayOfTheWeek with a day of the week after today in the current week at the end of the year"+ $ resolveDayForwards (fromGregorian 2020 12 30) (DayOfTheWeek Saturday 0)+ `shouldBe` Just (fromGregorian 2021 01 02)+ it+ "works for DayOfTheWeek with a day of the week after today in the next week at the end of the year"+ $ resolveDayForwards (fromGregorian 2020 12 30) (DayOfTheWeek Tuesday 0)+ `shouldBe` Just (fromGregorian 2021 01 05)++ it "works for DayOfTheWeek with an extra diff" $+ resolveDayForwards (fromGregorian 2018 10 9) (DayOfTheWeek Thursday 2)+ `shouldBe` Just (fromGregorian 2018 10 25)++ describe "resolveDayBackwards" $ do+ it "produces valid days" $ producesValid2 resolveDayBackwards++ it "works for this example for Yesterday" $+ resolveDayBackwards (fromGregorian 2000 6 25) Yesterday+ `shouldBe` Just (fromGregorian 2000 6 24)++ it "is id for Now" $+ forAllValid $ \d ->+ resolveDayBackwards d Now `shouldBe` Just d++ it "is id for Today" $+ forAllValid $ \d ->+ resolveDayBackwards d Today `shouldBe` Just d++ it "works for this example for Tomorrow" $+ resolveDayBackwards (fromGregorian 2001 6 23) Tomorrow+ `shouldBe` Just (fromGregorian 2001 6 24)++ it "produces valid values when given 'OnlyDay' values" $+ forAllValid $ \d ->+ forAllShrink ((OnlyDay <$> genValid) `suchThat` isValid) shrinkValid $ \fd ->+ shouldBeValid $ resolveDayBackwards d fd++ it "works for OnlyDay for this example where the current date is before the given day" $+ resolveDayBackwards (fromGregorian 2001 6 23) (OnlyDay 24)+ `shouldBe` Just (fromGregorian 2001 5 24)++ it "works for OnlyDay for this example where the current date is after the given day" $+ resolveDayBackwards (fromGregorian 2001 6 23) (OnlyDay 5)+ `shouldBe` Just (fromGregorian 2001 6 5)++ it "works for OnlyDay for this example where the following given day is not in this month" $+ resolveDayBackwards (fromGregorian 2001 2 23) (OnlyDay 29)+ `shouldBe` Just (fromGregorian 2001 1 29)++ it "does not work for OnlyDay for this example where the following given day is not in previous month" $+ resolveDayBackwards (fromGregorian 2001 3 25) (OnlyDay 29)+ `shouldBe` Nothing++ it "works for OnlyDay for this example where the following given day is not in previous month" $+ resolveDayBackwards (fromGregorian 2002 01 02) (OnlyDay 5)+ `shouldBe` Just (fromGregorian 2001 12 5)+ it "produces valid values when given 'DayInMonth' values" $- forAllValid $- \d ->- forAllShrink ((NextDayOfTheWeek <$> genValid) `suchThat` isValid) shrinkValid $ \fd ->- shouldBeValid $ resolveDay d fd- it "works for NextDayOfTheWeek with a day of the week after today in the current week" $- resolveDay (fromGregorian 2018 10 9) (NextDayOfTheWeek Thursday)- `shouldBe` fromGregorian 2018 10 11- it "works for NextDayOfTheWeek with a day of the week after today in the next week" $- resolveDay (fromGregorian 2018 10 9) (NextDayOfTheWeek Monday)- `shouldBe` fromGregorian 2018 10 15+ forAllValid $ \d ->+ forAllShrink (((\(mi, di) -> DayInMonth (max 0 (min 12 mi)) (max 0 (min 31 di))) <$> genValid) `suchThat` isValid) shrinkValid $ \fd ->+ shouldBeValid $ resolveDayBackwards d fd++ it "works for DayInMonth for this example where the current date is before the given day" $+ resolveDayBackwards (fromGregorian 2001 6 23) (DayInMonth 6 24)+ `shouldBe` Just (fromGregorian 2000 6 24)++ it "works for DayInMonth for this example where the current date is after the given day" $+ resolveDayBackwards (fromGregorian 2001 6 23) (DayInMonth 6 5)+ `shouldBe` Just (fromGregorian 2001 6 5)++ it "works for DayInMonth for this example accross years" $+ resolveDayBackwards (fromGregorian 2002 1 03) (DayInMonth 1 5)+ `shouldBe` Just (fromGregorian 2001 1 5)++ it "does not work for DayInMonth for this example for february 29th" $+ resolveDayBackwards (fromGregorian 2002 3 20) (DayInMonth 2 29)+ `shouldBe` Nothing++ it "produces valid values when given 'DayInMonth' values" $+ forAllValid $ \d ->+ forAllShrink ((DayOfTheWeek <$> genValid <*> genValid) `suchThat` isValid) shrinkValid $ \fd ->+ shouldBeValid $ resolveDayBackwards d fd++ it "works for DayOfTheWeek with a day of the week after today in the current week" $+ resolveDayBackwards (fromGregorian 2018 10 9) (DayOfTheWeek Thursday 0)+ `shouldBe` Just (fromGregorian 2018 10 04)++ it "works for DayOfTheWeek with a day of the week after today in the previous week" $+ resolveDayBackwards (fromGregorian 2018 10 9) (DayOfTheWeek Monday 0)+ `shouldBe` Just (fromGregorian 2018 10 08) it- "works for NextDayOfTheWeek with a day of the week after today in the current week at the end of the year"- $ resolveDay (fromGregorian 2020 12 30) (NextDayOfTheWeek Saturday)- `shouldBe` fromGregorian 2021 01 02+ "works for DayOfTheWeek with a day of the week after today in the current week at the end of the year"+ $ resolveDayBackwards (fromGregorian 2021 01 02) (DayOfTheWeek Saturday 0)+ `shouldBe` Just (fromGregorian 2020 12 26) it- "works for NextDayOfTheWeek with a day of the week after today in the next week at the end of the year"- $ resolveDay (fromGregorian 2020 12 30) (NextDayOfTheWeek Tuesday)- `shouldBe` fromGregorian 2021 01 05+ "works for DayOfTheWeek with a day of the week after today in the previous week at the end of the year"+ $ resolveDayBackwards (fromGregorian 2021 01 01) (DayOfTheWeek Tuesday 0)+ `shouldBe` Just (fromGregorian 2020 12 29)++ it "works for DayOfTheWeek with a day of the week after today in the current week" $+ resolveDayBackwards (fromGregorian 2018 10 9) (DayOfTheWeek Thursday (-2))+ `shouldBe` Just (fromGregorian 2018 09 20)
test/Data/FuzzyTime/TypesSpec.hs view
@@ -12,13 +12,7 @@ spec :: Spec spec = do- eqSpec @FuzzyLocalTime genValidSpec @FuzzyLocalTime- eqSpec @FuzzyTimeOfDay genValidSpec @FuzzyTimeOfDay- eqSpec @FuzzyDay genValidSpec @FuzzyDay- eqSpec @DayOfWeek genValidSpec @DayOfWeek- eqSpec @Month- genValidSpec @Month