fuzzy-time-gen 0.1.0.0 → 0.2.0.0
raw patch · 9 files changed
+335/−365 lines, 9 filesdep ~genvaliditysetup-changed
Dependency ranges changed: genvalidity
Files
- CHANGELOG.md +7/−0
- LICENSE +1/−1
- Setup.hs +0/−3
- bench/Bench.hs +6/−8
- fuzzy-time-gen.cabal +7/−5
- src/Data/FuzzyTime/Types/Gen.hs +34/−54
- test/Data/FuzzyTime/ParserSpec.hs +68/−69
- test/Data/FuzzyTime/ResolveSpec.hs +202/−213
- test/Data/FuzzyTime/TypesSpec.hs +10/−12
+ CHANGELOG.md view
@@ -0,0 +1,7 @@+# Changelog++## [0.2.0.0] - 2021-11-21++### Changed++- Compatibility with `genvalidity >=1.0`
LICENSE view
@@ -1,6 +1,6 @@ MIT License -Copyright (c) 2017-2020 Tom Sydney Kerckhove+Copyright (c) 2017-2021 Tom Sydney Kerckhove Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal
− Setup.hs
@@ -1,3 +0,0 @@-import Distribution.Simple--main = defaultMain
bench/Bench.hs view
@@ -3,18 +3,16 @@ module Main where import Criterion.Main as Criterion--import Data.GenValidity.Criterion- import Data.FuzzyTime import Data.FuzzyTime.Types.Gen ()+import Data.GenValidity.Criterion main :: IO () main = Criterion.defaultMain- [ genValidBench @FuzzyLocalTime- , genValidBench @FuzzyTimeOfDay- , genValidBench @FuzzyDay- , genValidBench @DayOfTheWeek- , genValidBench @Month+ [ genValidBench @FuzzyLocalTime,+ genValidBench @FuzzyTimeOfDay,+ genValidBench @FuzzyDay,+ genValidBench @DayOfTheWeek,+ genValidBench @Month ]
fuzzy-time-gen.cabal view
@@ -1,22 +1,24 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: a789803a4544cb2037b7e586a66defaeb7f689676547db65c867f17217196b96+-- hash: 1e748bc7a30876b6d377b5c436bac4c641bbf45a5acd29c98897ad0e0fb3ad26 name: fuzzy-time-gen-version: 0.1.0.0+version: 0.2.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-2020 Tom Sydney Kerckhove+copyright: Copyright: (c) 2017-2021 Tom Sydney Kerckhove license: MIT license-file: LICENSE build-type: Simple+extra-source-files:+ CHANGELOG.md library exposed-modules:@@ -31,7 +33,7 @@ , base >=4.9 && <=5 , containers , fuzzy-time- , genvalidity+ , genvalidity >=1.0 , genvalidity-time , megaparsec , time
src/Data/FuzzyTime/Types/Gen.hs view
@@ -2,76 +2,56 @@ module Data.FuzzyTime.Types.Gen where -import Test.QuickCheck-+import Data.FuzzyTime.Types import Data.GenValidity import Data.GenValidity.Time ()--import Data.FuzzyTime.Types--instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (Some a b)+import Test.QuickCheck instance (GenValid a, GenValid b) => GenValid (Some a b) where- genValid = genValidStructurally- shrinkValid = shrinkValidStructurally--instance GenUnchecked AmbiguousLocalTime+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering instance GenValid AmbiguousLocalTime where- genValid = genValidStructurally- shrinkValid = shrinkValidStructurally--instance GenUnchecked FuzzyLocalTime+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering instance GenValid FuzzyLocalTime where- genValid = genValidStructurally- shrinkValid = shrinkValidStructurally--instance GenUnchecked FuzzyTimeOfDay+ genValid = genValidStructurallyWithoutExtraChecking+ shrinkValid = shrinkValidStructurallyWithoutExtraFiltering instance GenValid FuzzyTimeOfDay where genValid =- (oneof- [ pure SameTime- , pure Midnight- , pure Morning- , pure Evening- , AtHour <$> choose (0, 23)- , AtMinute <$> choose (0, 23) <*> choose (0, 59)- , AtExact <$> genValid- , HoursDiff <$> choose (-23, 23)- , MinutesDiff <$> choose (-(24 * 60 - 1), (24 * 60 - 1))- , SecondsDiff <$> genValid- ]) `suchThat`- isValid+ oneof+ [ pure SameTime,+ pure Midnight,+ pure Morning,+ pure Evening,+ AtHour <$> choose (0, 23),+ AtMinute <$> choose (0, 23) <*> choose (0, 59),+ AtExact <$> genValid,+ HoursDiff <$> choose (-23, 23),+ MinutesDiff <$> choose (- (24 * 60 - 1), 24 * 60 - 1),+ SecondsDiff <$> genValid+ ]+ `suchThat` isValid shrinkValid = shrinkValidStructurally -instance GenUnchecked FuzzyDay- instance GenValid FuzzyDay where genValid =- (oneof- [ pure Yesterday- , pure Now- , pure Today- , pure Tomorrow- , OnlyDay <$> choose (1, 31)- , DayInMonth <$> choose (1, 31) <*> choose (1, 12)- , DiffDays <$> genValid- , DiffWeeks <$> genValid- , NextDayOfTheWeek <$> genValid- , ExactDay <$> genValid- ]) `suchThat`- isValid- shrinkValid = shrinkValidStructurally--instance GenUnchecked DayOfWeek--instance GenValid DayOfWeek where- genValid = genValidStructurally+ oneof+ [ pure Yesterday,+ pure Now,+ pure Today,+ pure Tomorrow,+ OnlyDay <$> choose (1, 31),+ DayInMonth <$> choose (1, 31) <*> choose (1, 12),+ DiffDays <$> genValid,+ DiffWeeks <$> genValid,+ NextDayOfTheWeek <$> genValid,+ ExactDay <$> genValid+ ]+ `suchThat` isValid shrinkValid = shrinkValidStructurally--instance GenUnchecked Month instance GenValid Month where genValid = genValidStructurally
test/Data/FuzzyTime/ParserSpec.hs view
@@ -2,9 +2,13 @@ {-# LANGUAGE OverloadedStrings #-} module Data.FuzzyTime.ParserSpec- ( spec- ) where+ ( spec,+ )+where +import Control.Monad+import Data.FuzzyTime+import Data.FuzzyTime.Types.Gen () import Data.GenValidity.Text () import Data.Int import Data.List (nub)@@ -12,19 +16,12 @@ import qualified Data.Text as T import Data.Time import Data.Void-import Text.Printf--import Control.Monad--import Text.Megaparsec- import Test.Hspec import Test.Hspec.QuickCheck import Test.QuickCheck import Test.Validity--import Data.FuzzyTime-import Data.FuzzyTime.Types.Gen ()+import Text.Megaparsec+import Text.Printf spec :: Spec spec = do@@ -35,22 +32,30 @@ 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- "tues 5:06"- (FuzzyLocalTime $ Both (NextDayOfTheWeek Tuesday) (AtMinute 5 6))+ 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)@@ -85,10 +90,10 @@ p "6" 6 p "01" 1 p "12" 12+ p "7:" 7 f "25" f "52" f "152"- f "7:" describe "minuteSegmentP" $ do parsesValidSpec minuteSegmentP let p = parseJustSpec minuteSegmentP@@ -110,10 +115,10 @@ p "23" (AtHour 23) p "08" (AtHour 8) p "04" (AtHour 4)+ p "6:" (AtHour 6)+ p "06:" (AtHour 6) f "26" f "103"- f "6:"- f "06:" describe "atMinuteP" $ do parsesValidSpec atMinuteP let p = parseJustSpec atMinuteP@@ -147,6 +152,8 @@ p "0" (AtHour 0) p "4" (AtHour 4) p "05" (AtHour 5)+ p "6:" (AtHour 6)+ p "07:" (AtHour 7) describe "AtMinute" $ do p "6:07" (AtMinute 6 7) p "08:09" (AtMinute 8 9)@@ -199,58 +206,52 @@ 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)+ 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- 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" $+ forAll (elements $ daysInMonth 2004) $ \(month, mds) ->+ let m = monthNum month+ 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+ 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"+ _ -> expectationFailure "fuzzyDayP parsed something other than a day of the week" it "parses the day of the week string as NextDayOfTheWeek" $ forAll (elements dayOfTheWeekStrings) $ \(dow, i, t) -> forAll (elements $ drop i $ T.inits t) $ \t_ ->@@ -262,26 +263,30 @@ dayOfTheWeekStrings :: [(DayOfWeek, Int, Text)] dayOfTheWeekStrings =- [ (Monday, 1, "monday")- , (Tuesday, 2, "tuesday")- , (Wednesday, 1, "wednesday")- , (Thursday, 2, "thursday")- , (Friday, 1, "friday")- , (Saturday, 2, "saturday")- , (Sunday, 2, "sunday")+ [ (Monday, 1, "monday"),+ (Monday, 1, "Monday"),+ (Tuesday, 2, "tuesday"),+ (Tuesday, 2, "Tuesday"),+ (Wednesday, 1, "wednesday"),+ (Wednesday, 1, "Wednesday"),+ (Thursday, 2, "thursday"),+ (Thursday, 2, "Thursday"),+ (Friday, 1, "friday"),+ (Friday, 1, "Friday"),+ (Saturday, 2, "saturday"),+ (Saturday, 2, "Saturday"),+ (Sunday, 2, "sunday"),+ (Sunday, 2, "Sunday") ] parseJustSpecR :: (Show a, Eq a) => Parser a -> Int -> Text -> a -> Spec-parseJustSpecR p i t res =- mapM_ (\s_ -> parseJustSpec p s_ res) $ drop i $ T.inits t+parseJustSpecR p i t res = mapM_ (\s_ -> parseJustSpec p s_ res) $ drop i $ T.inits t 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+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 p s =- it (unwords ["fails to parse", show s]) $ parseNothing p s+parseNothingSpec p s = it (unwords ["fails to parse", show s]) $ parseNothing p s parsesValidSpec :: (Show a, Eq a, Validity a) => Parser a -> Spec parsesValidSpec p = it "only parses valid values" $ forAllValid $ parsesValid p@@ -292,8 +297,7 @@ Right out -> out `shouldBe` res Left err -> expectationFailure $- unlines- ["Parser failed on input", show s, "with error", errorBundlePretty err]+ unlines ["Parser failed on input", show s, "with error", errorBundlePretty err] parseNothing :: (Show a, Eq a) => Parser a -> Text -> Expectation parseNothing p s =@@ -301,13 +305,8 @@ Left _ -> pure () Right v -> expectationFailure $- unlines- [ "Parser succeeded on input"- , show s- , "at parsing"- , show v- , "but it should have failed."- ]+ 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 p s =
test/Data/FuzzyTime/ResolveSpec.hs view
@@ -1,280 +1,269 @@ module Data.FuzzyTime.ResolveSpec- ( spec- ) where+ ( spec,+ )+where +import Data.FuzzyTime.Resolve+import Data.FuzzyTime.Types+import Data.FuzzyTime.Types.Gen () import Data.Time- import Test.Hspec import Test.QuickCheck import Test.Validity -import Data.FuzzyTime.Resolve-import Data.FuzzyTime.Types--import Data.FuzzyTime.Types.Gen ()- spec :: Spec spec = do describe "resolveLocalTime" $ do- it "produces valid local times" $ producesValidsOnValids2 resolveLocalTime+ it "produces valid local times" $ producesValid2 resolveLocalTime it "works the same as resolveLocalTimeOne" $- forAllValid $ \lt ->- forAllValid $ \fd ->- resolveLocalTime lt (FuzzyLocalTime (One fd)) `shouldBe`- OnlyDaySpecified (resolveLocalTimeOne lt fd)+ forAllValid $+ \lt ->+ forAllValid $ \fd ->+ resolveLocalTime lt (FuzzyLocalTime (One fd))+ `shouldBe` OnlyDaySpecified (resolveLocalTimeOne lt fd) it "works the same as resolveLocalTimeOther" $- forAllValid $ \lt ->- forAllValid $ \ftod ->- resolveLocalTime lt (FuzzyLocalTime (Other ftod)) `shouldBe`- BothTimeAndDay (resolveLocalTimeOther lt ftod)- it "works the same as resolveLocalTimeBoth" $- forAllValid $ \lt ->- forAllValid $ \fd ->+ forAllValid $+ \lt -> forAllValid $ \ftod ->- resolveLocalTime lt (FuzzyLocalTime (Both fd ftod)) `shouldBe`- BothTimeAndDay (resolveLocalTimeBoth lt fd ftod)+ resolveLocalTime lt (FuzzyLocalTime (Other ftod))+ `shouldBe` BothTimeAndDay (resolveLocalTimeOther lt ftod)+ it "works the same as resolveLocalTimeBoth" $+ forAllValid $+ \lt ->+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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+ 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)+ 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+ 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+ 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+ 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+ 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)+ 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+ 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+ 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+ 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+ forAllValid $+ \ld ->+ forAllValid $ \tod ->+ resolveLocalTimeBoth (LocalTime ld tod) Tomorrow Evening+ `shouldBe` LocalTime (addDays 1 ld) evening describe "normaliseTimeOfDay" $ do- it "produces valid times of day" $ producesValid normaliseTimeOfDay+ it "produces valid times of day" $ producesValid3 normaliseTimeOfDay it "works for this example of tomorrow" $- normaliseTimeOfDay (TimeOfDay 25 0 0) `shouldBe` (1, TimeOfDay 1 0 0)+ normaliseTimeOfDay 25 0 0 `shouldBe` (1, TimeOfDay 1 0 0) it "works for this example of tomorrow" $- normaliseTimeOfDay (TimeOfDay 23 120 0) `shouldBe` (1, TimeOfDay 1 0 0)+ normaliseTimeOfDay 23 120 0 `shouldBe` (1, TimeOfDay 1 0 0) it "works for this example of tomorrow" $- normaliseTimeOfDay (TimeOfDay 23 0 7200) `shouldBe` (1, TimeOfDay 1 0 0)+ normaliseTimeOfDay 23 0 7200 `shouldBe` (1, TimeOfDay 1 0 0) it "works for this example of tomorrow" $- normaliseTimeOfDay (TimeOfDay 23 120 7200) `shouldBe` (1, TimeOfDay 3 0 0)+ normaliseTimeOfDay 23 120 7200 `shouldBe` (1, TimeOfDay 3 0 0) it "works for this example of yesterday" $- normaliseTimeOfDay (TimeOfDay (-1) 0 0) `shouldBe` (-1, TimeOfDay 23 0 0)+ normaliseTimeOfDay (-1) 0 0 `shouldBe` (-1, TimeOfDay 23 0 0) it "works for this example of yesterday" $- normaliseTimeOfDay (TimeOfDay 0 (-1) 0) `shouldBe` (-1, TimeOfDay 23 59 0)+ normaliseTimeOfDay 0 (-1) 0 `shouldBe` (-1, TimeOfDay 23 59 0) it "works for this example of yesterday" $- normaliseTimeOfDay (TimeOfDay 0 0 (-1)) `shouldBe`- (-1, TimeOfDay 23 59 59)+ normaliseTimeOfDay 0 0 (-1) `shouldBe` (-1, TimeOfDay 23 59 59) it "works for this example of yesterday" $- normaliseTimeOfDay (TimeOfDay 0 0 (-0.01)) `shouldBe`- (-1, TimeOfDay 23 59 59.99)+ normaliseTimeOfDay 0 0 (-0.01) `shouldBe` (-1, TimeOfDay 23 59 59.99) it "works for this example of yesterday" $- normaliseTimeOfDay (TimeOfDay 0 0 (-0.00001)) `shouldBe`- (-1, TimeOfDay 23 59 59.99999)+ normaliseTimeOfDay 0 0 (-0.00001) `shouldBe` (-1, TimeOfDay 23 59 59.99999) it "works for this example of yesterday" $- normaliseTimeOfDay (TimeOfDay 0 0 (-0.00000001)) `shouldBe`- (-1, TimeOfDay 23 59 59.99999999)+ 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" $ producesValidsOnValids2 resolveTimeOfDay- it "works for sametime " $- forAllValid $ \tod -> resolveTimeOfDay tod SameTime `shouldBe` tod+ it "produces valid times of day" $ producesValid2 resolveTimeOfDay+ it "works for sametime " $ forAllValid $ \tod -> resolveTimeOfDay tod SameTime `shouldBe` tod it "works for noon " $- forAllValid $ \tod ->- resolveTimeOfDay tod Noon `shouldBe` TimeOfDay 12 0 0+ forAllValid $+ \tod -> resolveTimeOfDay tod Noon `shouldBe` TimeOfDay 12 0 0 it "works for midnight " $- forAllValid $ \tod ->- resolveTimeOfDay tod Midnight `shouldBe` TimeOfDay 0 0 0+ forAllValid $+ \tod -> resolveTimeOfDay tod Midnight `shouldBe` TimeOfDay 0 0 0 it "works for morning " $- forAllValid $ \tod ->- resolveTimeOfDay tod Morning `shouldBe` TimeOfDay 6 0 0+ forAllValid $+ \tod -> resolveTimeOfDay tod Morning `shouldBe` TimeOfDay 6 0 0 it "works for evening" $- forAllValid $ \tod ->- resolveTimeOfDay tod Evening `shouldBe` TimeOfDay 18 0 0+ forAllValid $+ \tod -> resolveTimeOfDay tod Evening `shouldBe` 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 -> resolveTimeOfDay tod (AtHour h) `shouldBe` 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 -> resolveTimeOfDay tod (AtMinute h m) `shouldBe` TimeOfDay h m 0 it "works for atExact" $- forAllValid $ \tod1 ->- forAllValid $ \tod2 ->- resolveTimeOfDay tod1 (AtExact tod2) `shouldBe` tod2- 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- 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- 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+ forAllValid $+ \tod1 ->+ forAllValid $ \tod2 -> resolveTimeOfDay tod1 (AtExact tod2) `shouldBe` 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+ 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+ 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" $ producesValidsOnValids2 resolveDay+ it "produces valid days" $ producesValid2 resolveDay it "works for this example for Yesterday" $- resolveDay (fromGregorian 2000 6 25) Yesterday `shouldBe`- fromGregorian 2000 6 24+ 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 it "works for this example for Tomorrow" $- resolveDay (fromGregorian 2001 6 23) Tomorrow `shouldBe`- fromGregorian 2001 6 24+ resolveDay (fromGregorian 2001 6 23) Tomorrow `shouldBe` 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- 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- 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- 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- 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+ forAllValid $+ \d ->+ forAllShrink ((OnlyDay <$> genValid) `suchThat` isValid) shrinkValid $ \fd ->+ shouldBeValid $ resolveDay 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+ 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+ 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+ 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 it "produces valid values when given 'DayInMonth' values" $- forAllValid $ \d ->- forAllShrink- (((\(mi, di) -> DayInMonth mi di) <$> genValid) `suchThat` isValid)- shrinkValid $ \fd -> shouldBeValid $ resolveDay 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- 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+ 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+ 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+ 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 it "works for DayInMonth for this example accross years" $- resolveDay (fromGregorian 2001 1 30) (DayInMonth 1 5) `shouldBe`- fromGregorian 2002 1 5+ 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+ resolveDay (fromGregorian 2001 1 30) (DayInMonth 2 29) `shouldBe` fromGregorian 2004 2 29 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 ((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 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 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 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 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
test/Data/FuzzyTime/TypesSpec.hs view
@@ -1,26 +1,24 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module Data.FuzzyTime.TypesSpec- ( spec- ) where--import Test.Hspec-import Test.Validity+ ( spec,+ )+where import Data.FuzzyTime import Data.FuzzyTime.Types.Gen ()+import Test.Hspec+import Test.Validity spec :: Spec spec = do- eqSpecOnValid @FuzzyLocalTime+ eqSpec @FuzzyLocalTime genValidSpec @FuzzyLocalTime- eqSpecOnValid @FuzzyTimeOfDay+ eqSpec @FuzzyTimeOfDay genValidSpec @FuzzyTimeOfDay- eqSpecOnValid @FuzzyDay+ eqSpec @FuzzyDay genValidSpec @FuzzyDay- eqSpecOnValid @DayOfWeek+ eqSpec @DayOfWeek genValidSpec @DayOfWeek- eqSpecOnValid @Month+ eqSpec @Month genValidSpec @Month