fuzzy-time-gen (empty) → 0.0.0.0
raw patch · 9 files changed
+828/−0 lines, 9 filesdep +QuickCheckdep +basedep +containerssetup-changed
Dependencies added: QuickCheck, base, containers, criterion, fuzzy-time, fuzzy-time-gen, genvalidity, genvalidity-criterion, genvalidity-hspec, genvalidity-text, genvalidity-time, hspec, megaparsec, text, time
Files
- LICENSE +21/−0
- Setup.hs +3/−0
- bench/Bench.hs +20/−0
- fuzzy-time-gen.cabal +80/−0
- src/Data/FuzzyTime/Types/Gen.hs +78/−0
- test/Data/FuzzyTime/ParserSpec.hs +319/−0
- test/Data/FuzzyTime/ResolveSpec.hs +280/−0
- test/Data/FuzzyTime/TypesSpec.hs +26/−0
- test/Spec.hs +1/−0
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017-2020 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+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple++main = defaultMain
+ bench/Bench.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE TypeApplications #-}++module Main where++import Criterion.Main as Criterion++import Data.GenValidity.Criterion++import Data.FuzzyTime+import Data.FuzzyTime.Types.Gen ()++main :: IO ()+main =+ Criterion.defaultMain+ [ genValidBench @FuzzyLocalTime+ , genValidBench @FuzzyTimeOfDay+ , genValidBench @FuzzyDay+ , genValidBench @DayOfTheWeek+ , genValidBench @Month+ ]
+ fuzzy-time-gen.cabal view
@@ -0,0 +1,80 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.33.0.+--+-- see: https://github.com/sol/hpack+--+-- hash: 76078bb82707ef2022f531cb640a19b0dea27cd42d2104810cc583840f923325++name: fuzzy-time-gen+version: 0.0.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+license: MIT+license-file: LICENSE+build-type: Simple++library+ exposed-modules:+ Data.FuzzyTime.Types.Gen+ other-modules:+ Paths_fuzzy_time_gen+ hs-source-dirs:+ src/+ ghc-options: -Wall+ build-depends:+ QuickCheck+ , base >=4.9 && <=5+ , containers+ , fuzzy-time+ , genvalidity+ , genvalidity-time+ , megaparsec+ , time+ default-language: Haskell2010++test-suite fuzzy-time-test+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ Data.FuzzyTime.ParserSpec+ Data.FuzzyTime.ResolveSpec+ Data.FuzzyTime.TypesSpec+ Paths_fuzzy_time_gen+ hs-source-dirs:+ test/+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ QuickCheck+ , base >=4.9 && <=5+ , fuzzy-time+ , fuzzy-time-gen+ , genvalidity+ , genvalidity-hspec+ , genvalidity-text+ , genvalidity-time+ , hspec+ , megaparsec+ , text+ , time+ default-language: Haskell2010++benchmark fuzzy-time-bench+ type: exitcode-stdio-1.0+ main-is: Bench.hs+ other-modules:+ Paths_fuzzy_time_gen+ hs-source-dirs:+ bench/+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends:+ base >=4.9 && <=5+ , criterion+ , fuzzy-time+ , fuzzy-time-gen+ , genvalidity-criterion+ default-language: Haskell2010
+ src/Data/FuzzyTime/Types/Gen.hs view
@@ -0,0 +1,78 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Data.FuzzyTime.Types.Gen where++import Test.QuickCheck++import Data.GenValidity+import Data.GenValidity.Time ()++import Data.FuzzyTime.Types++instance (GenUnchecked a, GenUnchecked b) => GenUnchecked (Some a b)++instance (GenValid a, GenValid b) => GenValid (Some a b) where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance GenUnchecked AmbiguousLocalTime++instance GenValid AmbiguousLocalTime where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance GenUnchecked FuzzyLocalTime++instance GenValid FuzzyLocalTime where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance GenUnchecked FuzzyTimeOfDay++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+ 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 DayOfTheWeek++instance GenValid DayOfTheWeek where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally++instance GenUnchecked Month++instance GenValid Month where+ genValid = genValidStructurally+ shrinkValid = shrinkValidStructurally
+ test/Data/FuzzyTime/ParserSpec.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}++module Data.FuzzyTime.ParserSpec+ ( spec+ ) where++import Data.GenValidity.Text ()+import Data.Int+import Data.List (nub)+import Data.Text (Text)+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 ()++spec :: Spec+spec = do+ describe "fuzzyLocalTimeP" $ do+ parsesValidSpec fuzzyLocalTimeP+ let p = parseJustSpec fuzzyLocalTimeP+ pr = parseJustSpecR fuzzyLocalTimeP+ f = parseNothingSpec fuzzyLocalTimeP+ p "1" (FuzzyLocalTime $ One $ OnlyDay 1)+ p "today" (FuzzyLocalTime $ One Today)+ p "monday" (FuzzyLocalTime $ One $ NextDayOfTheWeek Monday)+ 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 "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 4 "midday" $ FuzzyLocalTime $ Other Noon+ pr 4 "midnight" $ FuzzyLocalTime $ Other Midnight+ pr 3 "morning" $ FuzzyLocalTime $ Other Morning+ 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))+ f "hello"+ f "world"+ describe "twoDigitsSegmentP" $ do+ parsesValidSpec twoDigitsSegmentP+ let p = parseJustSpec twoDigitsSegmentP+ f = parseNothingSpec twoDigitsSegmentP+ p "0" 0+ p "6" 6+ p "01" 1+ p "12" 12+ p "52" 52+ f "152"+ f "6:"+ describe "hourSegmentP" $ do+ parsesValidSpec hourSegmentP+ let p = parseJustSpec hourSegmentP+ f = parseNothingSpec hourSegmentP+ p "0" 0+ p "6" 6+ p "01" 1+ p "12" 12+ f "25"+ f "52"+ f "152"+ f "7:"+ describe "minuteSegmentP" $ do+ parsesValidSpec minuteSegmentP+ let p = parseJustSpec minuteSegmentP+ f = parseNothingSpec minuteSegmentP+ p "0" 0+ p "6" 6+ p "01" 1+ p "12" 12+ p "25" 25+ p "52" 52+ f "152"+ f "8:"+ describe "atHourP" $ do+ parsesValidSpec atHourP+ let p = parseJustSpec atHourP+ f = parseNothingSpec atHourP+ p "0" (AtHour 0)+ p "2" (AtHour 2)+ p "23" (AtHour 23)+ p "08" (AtHour 8)+ p "04" (AtHour 4)+ f "26"+ f "103"+ f "6:"+ f "06:"+ describe "atMinuteP" $ do+ parsesValidSpec atMinuteP+ let p = parseJustSpec atMinuteP+ f = parseNothingSpec atMinuteP+ p "2:52" (AtMinute 2 52)+ p "23:52" (AtMinute 23 52)+ p "08:15" (AtMinute 08 15)+ p "0426" (AtMinute 4 26)+ f "6:"+ f "06:"+ describe "atExactP" $ do+ parsesValidSpec atExactP+ let p = parseJustSpec atExactP+ f = parseNothingSpec atExactP+ p "23:59:22" $ AtExact (TimeOfDay 23 59 22)+ p "5:06:23" $ AtExact (TimeOfDay 5 6 23)+ p "0506:23" $ AtExact (TimeOfDay 5 6 23)+ f "50623"+ f "050623"+ f "05:0623"+ describe "fuzzyTimeOfDayP" $ do+ parsesValidSpec fuzzyTimeOfDayP+ let p = parseJustSpec fuzzyTimeOfDayP+ let pr = parseJustSpecR fuzzyTimeOfDayP+ pr 2 "noon" Noon+ pr 4 "midday" Noon+ pr 4 "midnight" Midnight+ pr 2 "morning" Morning+ pr 1 "evening" Evening+ describe "AtHour" $ do+ p "0" (AtHour 0)+ p "4" (AtHour 4)+ p "05" (AtHour 5)+ describe "AtMinute" $ do+ p "6:07" (AtMinute 6 7)+ p "08:09" (AtMinute 8 9)+ p "1011" (AtMinute 10 11)+ p "0324" (AtMinute 3 24)+ describe "AtExact" $ do+ p "23:59:22" $ AtExact (TimeOfDay 23 59 22)+ p "5:06:23" $ AtExact (TimeOfDay 5 6 23)+ p "0506:23" $ AtExact (TimeOfDay 5 6 23)+ p "05:06:23.1" $ AtExact (TimeOfDay 5 6 23.1)+ p "05:06:23.01" $ AtExact (TimeOfDay 5 6 23.01)+ p "05:06:23.001" $ AtExact (TimeOfDay 5 6 23.001)+ p "05:06:23.0001" $ AtExact (TimeOfDay 5 6 23.0001)+ p "05:06:23.00001" $ AtExact (TimeOfDay 5 6 23.00001)+ p "05:06:23.000001" $ AtExact (TimeOfDay 5 6 23.000001)+ p "05:06:23.0000001" $ AtExact (TimeOfDay 5 6 23.0000001)+ p "05:06:23.00000001" $ AtExact (TimeOfDay 5 6 23.00000001)+ p "05:06:23.000000001" $ AtExact (TimeOfDay 5 6 23.000000001)+ p "05:06:23.0000000001" $ AtExact (TimeOfDay 5 6 23.0000000001)+ p "05:06:23.00000000001" $ AtExact (TimeOfDay 5 6 23.00000000001)+ p "05:06:23.000000000001" $ AtExact (TimeOfDay 5 6 23.000000000001)+ it "can parse whatever is rendered" $+ forAllValid $ \tod ->+ 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+ describe "HoursDiff" $ do+ p "+3" (HoursDiff 3)+ p "-4" (HoursDiff (-4))+ p "+5h" (HoursDiff 5)+ p "-6h" (HoursDiff (-6))+ describe "MinutesDiff" $ do+ p "+7m" (MinutesDiff 7)+ p "-8m" (MinutesDiff (-8))+ describe "SecondsDiff" $ do+ p "+9s" (SecondsDiff 9)+ p "-10s" (SecondsDiff (-10))+ describe "fuzzyDayP" $ do+ parsesValidSpec fuzzyDayP+ let fd = parseJustSpecR fuzzyDayP+ fd 1 "yesterday" Yesterday+ fd 3 "today" Today+ fd 3 "tomorrow" Tomorrow+ fd 1 "now" Now+ it "parses exact (recent) days with %Y-%m-%d" $+ forAll (ModifiedJulianDay . toInteger <$> (genValid :: Gen Int16)) $ \day ->+ let t = T.pack $ formatTime defaultTimeLocale "%Y-%m-%d" day+ in parseJust fuzzyDayP t $ ExactDay day+ 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)+ 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)+ 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)+ 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)+ 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)+ 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)+ 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" $+ 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" $+ forAll (elements dayOfTheWeekStrings) $ \(dow, i, t) ->+ forAll (elements $ drop i $ T.inits t) $ \t_ ->+ parseJust fuzzyDayP t_ (NextDayOfTheWeek dow)+ describe "fuzzyDayOfTheWeekP" $ do+ parsesValidSpec fuzzyDayOfTheWeekP+ let fd = parseJustSpecR fuzzyDayOfTheWeekP+ forM_ dayOfTheWeekStrings $ \(dow, ix, s) -> fd ix s dow++dayOfTheWeekStrings :: [(DayOfTheWeek, Int, Text)]+dayOfTheWeekStrings =+ [ (Monday, 1, "monday")+ , (Tuesday, 2, "tuesday")+ , (Wednesday, 1, "wednesday")+ , (Thursday, 2, "thursday")+ , (Friday, 1, "friday")+ , (Saturday, 2, "saturday")+ , (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++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 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++parseJust :: (Show a, Eq a) => Parser a -> Text -> a -> Expectation+parseJust p s res =+ case parseForTest p s of+ Right out -> out `shouldBe` res+ Left err ->+ expectationFailure $+ unlines+ ["Parser failed on input", show s, "with error", errorBundlePretty err]++parseNothing :: (Show a, Eq a) => Parser a -> Text -> Expectation+parseNothing p s =+ case parseForTest p s of+ Left _ -> pure ()+ Right v ->+ expectationFailure $+ 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 =+ case parseForTest p s of+ Left _ -> pure ()+ Right out -> shouldBeValid out++parseForTest :: Parser a -> Text -> Either (ParseErrorBundle Text Void) a+parseForTest p s = parse (p <* eof) "test input" s
+ test/Data/FuzzyTime/ResolveSpec.hs view
@@ -0,0 +1,280 @@+module Data.FuzzyTime.ResolveSpec+ ( spec+ ) where++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 "works the same as resolveLocalTimeOne" $+ 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 $ \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+ describe "normaliseTimeOfDay" $ do+ it "produces valid times of day" $ producesValid normaliseTimeOfDay+ it "works for this example of tomorrow" $+ normaliseTimeOfDay (TimeOfDay 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)+ it "works for this example of tomorrow" $+ normaliseTimeOfDay (TimeOfDay 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)+ it "works for this example of yesterday" $+ normaliseTimeOfDay (TimeOfDay (-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)+ it "works for this example of yesterday" $+ normaliseTimeOfDay (TimeOfDay 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)+ it "works for this example of yesterday" $+ normaliseTimeOfDay (TimeOfDay 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)+ describe "resolveTimeOfDay" $ do+ it "produces valid times of day" $ producesValidsOnValids2 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+ it "works for midnight " $+ forAllValid $ \tod ->+ resolveTimeOfDay tod Midnight `shouldBe` TimeOfDay 0 0 0+ it "works for morning " $+ forAllValid $ \tod ->+ resolveTimeOfDay tod Morning `shouldBe` TimeOfDay 6 0 0+ it "works for evening" $+ 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+ it "works for atMinute" $+ 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+ describe "resolveDay" $ do+ it "produces valid days" $ producesValidsOnValids2 resolveDay+ 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+ it "works for this example for Tomorrow" $+ 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+ 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+ 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+ 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+ 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+ 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
+ test/Data/FuzzyTime/TypesSpec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Data.FuzzyTime.TypesSpec+ ( spec+ ) where++import Test.Hspec+import Test.Validity++import Data.FuzzyTime+import Data.FuzzyTime.Types.Gen ()++spec :: Spec+spec = do+ eqSpecOnValid @FuzzyLocalTime+ genValidSpec @FuzzyLocalTime+ eqSpecOnValid @FuzzyTimeOfDay+ genValidSpec @FuzzyTimeOfDay+ eqSpecOnValid @FuzzyDay+ genValidSpec @FuzzyDay+ eqSpecOnValid @DayOfTheWeek+ genValidSpec @DayOfTheWeek+ eqSpecOnValid @Month+ genValidSpec @Month
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}