fuzzy-time 0.2.0.3 → 0.3.0.0

raw patch · 5 files changed

+287/−226 lines, 5 filesdep ~timePVP ok

version bump matches the API change (PVP)

Dependency ranges changed: time

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• fuzzy-time.cabal +3/−3
• src/Data/FuzzyTime/Parser.hs +56/−32
• src/Data/FuzzyTime/Resolve.hs +204/−106
• src/Data/FuzzyTime/Types.hs +16/−85

@@ -1,5 +1,13 @@ # Changelog +## [0.3.0.0] - 2023-05-18++### Added++* Allowed for backwards resolution+* Allow parsing named months+* Allow parsing day of week with an extra diff of weeks+ ## [0.2.0.3] - 2022-09-25  ### Changed

@@ -1,11 +1,11 @@ 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-version:        0.2.0.3+version:        0.3.0.0 description:    Fuzzy time types, parsing and resolution category:       Time homepage:       https://github.com/NorfairKing/fuzzy-time@@ -35,7 +35,7 @@     , deepseq     , megaparsec     , text-    , time >=1.9+    , time >=1.11     , validity     , validity-time >=0.5   default-language: Haskell2010

@@ -4,8 +4,7 @@ {-# LANGUAGE TypeFamilies #-}  module Data.FuzzyTime.Parser-  ( fuzzyZonedTimeP,-    fuzzyLocalTimeP,+  ( fuzzyLocalTimeP,     fuzzyTimeOfDayP,     atHourP,     atMinuteP,@@ -22,38 +21,33 @@ import Control.Monad (guard, msum, void) import Data.Char as Char (toLower) import Data.Fixed (Pico)-import Data.FuzzyTime.Types (DayOfWeek (Friday, Monday, Saturday, Sunday, Thursday, Tuesday, Wednesday), FuzzyDay (DayInMonth, DiffDays, DiffMonths, DiffWeeks, ExactDay, NextDayOfTheWeek, Now, OnlyDay, Today, Tomorrow, Yesterday), FuzzyLocalTime (FuzzyLocalTime), FuzzyTimeOfDay (AtExact, AtHour, AtMinute, Evening, HoursDiff, Midnight, MinutesDiff, Morning, Noon, SecondsDiff), FuzzyZonedTime (ZonedNow), Some (Both, One, Other))-import Data.List (elemIndex, find)+import Data.FuzzyTime.Types (FuzzyDay (..), FuzzyLocalTime (..), FuzzyTimeOfDay (AtExact, AtHour, AtMinute, Evening, HoursDiff, Midnight, MinutesDiff, Morning, Noon, SecondsDiff))+import Data.List (find) import Data.Maybe (fromMaybe, maybeToList) import Data.Text (Text)-import Data.Time (TimeOfDay (TimeOfDay), defaultTimeLocale, parseTimeM)+import Data.Time (DayOfWeek (..), TimeOfDay (TimeOfDay), defaultTimeLocale, parseTimeM) import Data.Tree (Forest, Tree (Node), rootLabel, subForest) import Data.Validity (isValid) import Data.Void (Void)+import Data.Word (Word8) import Text.Megaparsec (Parsec, empty, eof, label, oneOf, optional, some, try, (<|>)) import Text.Megaparsec.Char as Char (char, digitChar, letterChar, space1, string) import Text.Megaparsec.Char.Lexer as Lexer (decimal)+import Text.Read (readMaybe)  type Parser = Parsec Void Text -fuzzyZonedTimeP :: Parser FuzzyZonedTime-fuzzyZonedTimeP = pure ZonedNow- fuzzyLocalTimeP :: Parser FuzzyLocalTime-fuzzyLocalTimeP = label "FuzzyLocalTime" $ FuzzyLocalTime <$> parseSome fuzzyDayP fuzzyTimeOfDayP---- | Note: Not composable-parseSome :: Parser a -> Parser b -> Parser (Some a b)-parseSome pa pb =-  label "Some" $+fuzzyLocalTimeP =+  label "FuzzyLocalTime" $     choice''       [ do-          a <- pa+          a <- fuzzyDayP           space1-          b <- pb-          pure $ Both a b,-        One <$> pa,-        Other <$> pb+          b <- fuzzyTimeOfDayP+          pure $ FuzzyLocalTimeBoth a b,+        FuzzyLocalTimeDay <$> fuzzyDayP,+        FuzzyLocalTimeTimeOfDay <$> fuzzyTimeOfDayP       ]  fuzzyTimeOfDayP :: Parser FuzzyTimeOfDay@@ -135,7 +129,7 @@     guard $ m >= 0 && m < 60     pure m -twoDigitsSegmentP :: Parser Int+twoDigitsSegmentP :: (Num a, Read a) => Parser a twoDigitsSegmentP =   label "two digit segment" $ do     d1 <- digit@@ -145,12 +139,12 @@         Nothing -> d1         Just d2 -> 10 * d1 + d2 -digit :: Parser Int+digit :: (Read a) => Parser a digit =   label "digit" $ do     let l = ['0' .. '9']     c <- oneOf l-    case elemIndex c l of+    case readMaybe [c] of       Nothing -> fail "Shouldn't happen."       Just d -> pure d @@ -172,27 +166,51 @@         fmap ExactDay (some (digitChar <|> char '-') >>= parseTimeM True defaultTimeLocale "%Y-%m-%d"),         dayInMonthP,         dayOfTheMonthP,-        NextDayOfTheWeek <$> fuzzyDayOfTheWeekP,+        fuzzyDayOfTheWeekP,         diffDayP       ]  dayOfTheMonthP :: Parser FuzzyDay dayOfTheMonthP = do-  v <- OnlyDay <$> twoDigitsSegmentP+  dayNo <- twoDigitsSegmentP+  let v = OnlyDay dayNo   guard $ isValid v   pure v  dayInMonthP :: Parser FuzzyDay dayInMonthP = do-  m <- twoDigitsSegmentP-  guard (m >= 1)-  guard (m <= 12)+  m <-+    choice'+      [ do+          m <- twoDigitsSegmentP+          guard (m >= 1)+          guard (m <= 12)+          pure m,+        namedMonthP+      ]   void $ string "-"   d <- twoDigitsSegmentP   let v = DayInMonth m d   guard $ isValid v   pure v +namedMonthP :: Parser Word8+namedMonthP =+  recTreeParser+    [ ("january", 1),+      ("february", 2),+      ("march", 3),+      ("april", 4),+      ("may", 5),+      ("june", 6),+      ("july", 7),+      ("august", 8),+      ("september", 9),+      ("october", 10),+      ("november", 11),+      ("december", 12)+    ]+ diffDayP :: Parser FuzzyDay diffDayP = do   d <- signed' decimal@@ -206,6 +224,12 @@           _ -> DiffDays -- Should not happen.   pure $ f d +fuzzyDayOfTheWeekP :: Parser FuzzyDay+fuzzyDayOfTheWeekP = do+  dow <- dayOfTheWeekP+  mExtraDiff <- optional $ signed' decimal+  pure $ DayOfTheWeek dow (fromMaybe 0 mExtraDiff)+ -- | Can handle: -- -- - monday@@ -217,8 +241,8 @@ -- - sunday -- -- and all non-ambiguous prefixes-fuzzyDayOfTheWeekP :: Parser DayOfWeek-fuzzyDayOfTheWeekP =+dayOfTheWeekP :: Parser DayOfWeek+dayOfTheWeekP =   recTreeParser     [ ("monday", Monday),       ("tuesday", Tuesday),@@ -253,10 +277,10 @@               _ -> gof cs subForest             else Nothing -makeParseForest :: Eq c => [([c], a)] -> Forest (c, Maybe a)+makeParseForest :: (Eq c) => [([c], a)] -> Forest (c, Maybe a) makeParseForest = foldl insertf []   where-    insertf :: Eq c => Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a)+    insertf :: (Eq c) => Forest (c, Maybe a) -> ([c], a) -> Forest (c, Maybe a)     insertf for ([], _) = for     insertf for (c : cs, a) =       case find ((== c) . fst . rootLabel) for of@@ -273,7 +297,7 @@                   then n {rootLabel = (tc, Nothing), subForest = insertf (subForest n) (cs, a)}                   else t -signed' :: Num a => Parser a -> Parser a+signed' :: (Num a) => Parser a -> Parser a signed' p = sign <*> p   where     sign = (id <$ char '+') <|> (negate <$ char '-')

@@ -1,70 +1,93 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE PatternSynonyms #-}+ module Data.FuzzyTime.Resolve-  ( resolveZonedTime,-    resolveLocalTime,-    resolveLocalTimeOne,-    resolveLocalTimeOther,-    resolveLocalTimeBoth,+  ( -- * Local time+    resolveLocalTimeForwards,+    resolveLocalTimeBackwards,++    -- * Time Of Day+    resolveTimeOfDayForwards,+    resolveTimeOfDayBackwards,+    normaliseTimeOfDay,     morning,     evening,-    resolveTimeOfDay,-    resolveTimeOfDayWithDiff,-    normaliseTimeOfDay,-    resolveDay,++    -- * Day+    resolveDayForwards,+    resolveDayBackwards,++    -- ** Resolution helpers+    nextDayOfMonth,+    previousDayOfMonth,+    nextDayOfMonthOfYear,+    previousDayOfMonthOfYear,+    nextDayOfWeek,+    previousDayOfWeek,   ) where  import Data.Fixed (Pico, mod')-import Data.FuzzyTime.Types (AmbiguousLocalTime (BothTimeAndDay, OnlyDaySpecified), FuzzyDay (DayInMonth, DiffDays, DiffMonths, DiffWeeks, ExactDay, NextDayOfTheWeek, Now, OnlyDay, Today, Tomorrow, Yesterday), FuzzyLocalTime (FuzzyLocalTime), FuzzyTimeOfDay (AtExact, AtHour, AtMinute, Evening, HoursDiff, Midnight, MinutesDiff, Morning, Noon, SameTime, SecondsDiff), FuzzyZonedTime (ZonedNow), Month, Some (Both, One, Other), dayOfTheWeekNum, daysInMonth, monthNum, numMonth)-import Data.Maybe (fromJust)-import Data.Time (Day, DayOfWeek, LocalTime (LocalTime), TimeOfDay (TimeOfDay), ZonedTime, addDays, fromGregorian, midday, midnight, toGregorian)-import Data.Time.Calendar.WeekDate (toWeekDate)--resolveZonedTime :: ZonedTime -> FuzzyZonedTime -> ZonedTime-resolveZonedTime zt ZonedNow = zt--resolveLocalTime :: LocalTime -> FuzzyLocalTime -> AmbiguousLocalTime-resolveLocalTime lt (FuzzyLocalTime sft) =-  case sft of-    One fd -> OnlyDaySpecified $ resolveLocalTimeOne lt fd-    Other ftod -> BothTimeAndDay $ resolveLocalTimeOther lt ftod-    Both fd ftod -> BothTimeAndDay $ resolveLocalTimeBoth lt fd ftod+import Data.FuzzyTime.Types (AmbiguousLocalTime (BothTimeAndDay, OnlyDaySpecified), FuzzyDay (..), FuzzyLocalTime (..), FuzzyTimeOfDay (AtExact, AtHour, AtMinute, Evening, HoursDiff, Midnight, MinutesDiff, Morning, Noon, SameTime, SecondsDiff))+import Data.Time (Day, DayOfWeek, LocalTime (LocalTime), TimeOfDay (TimeOfDay), addDays, midday, midnight, toGregorian)+import Data.Time.Calendar.Month (Month, fromMonthDayValid, fromYearMonthValid, pattern MonthDay)+import Data.Time.Calendar.WeekDate (fromWeekDate, toWeekDate)+import Data.Word (Word8) -resolveLocalTimeOne :: LocalTime -> FuzzyDay -> Day-resolveLocalTimeOne (LocalTime ld _) fd = resolveDay ld fd+resolveLocalTimeForwards :: LocalTime -> FuzzyLocalTime -> Maybe AmbiguousLocalTime+resolveLocalTimeForwards (LocalTime ld ltod) = \case+  FuzzyLocalTimeDay fd -> OnlyDaySpecified <$> resolveDayForwards ld fd+  FuzzyLocalTimeTimeOfDay ftod -> do+    (d, tod) <- resolveTimeOfDayForwardsWithDiff ltod ftod+    pure $ BothTimeAndDay $ LocalTime (addDays d ld) tod+  FuzzyLocalTimeBoth fd ftod -> do+    let withDiff = resolveTimeOfDayForwardsWithDiff ltod ftod+        withoutDiff = (,) 0 <$> resolveTimeOfDayForwards ltod ftod+    (d, tod) <-+      case fd of+        Now -> withDiff+        Today -> withDiff+        _ -> withoutDiff+    day <- addDays d <$> resolveDayForwards ld fd+    pure $ BothTimeAndDay $ LocalTime day tod -resolveLocalTimeOther :: LocalTime -> FuzzyTimeOfDay -> LocalTime-resolveLocalTimeOther (LocalTime ld ltod) ftod =-  let (d, tod) = resolveTimeOfDayWithDiff ltod ftod-   in LocalTime (addDays d ld) tod+resolveLocalTimeBackwards :: LocalTime -> FuzzyLocalTime -> Maybe AmbiguousLocalTime+resolveLocalTimeBackwards (LocalTime ld ltod) = \case+  FuzzyLocalTimeDay fd -> OnlyDaySpecified <$> resolveDayBackwards ld fd+  FuzzyLocalTimeTimeOfDay ftod -> do+    (d, tod) <- resolveTimeOfDayBackwardsWithDiff ltod ftod+    pure $ BothTimeAndDay $ LocalTime (addDays d ld) tod+  FuzzyLocalTimeBoth fd ftod -> do+    let withDiff = resolveTimeOfDayBackwardsWithDiff ltod ftod+        withoutDiff = (,) 0 <$> resolveTimeOfDayBackwards ltod ftod+    (d, tod) <-+      case fd of+        Now -> withDiff+        Today -> withDiff+        _ -> withoutDiff+    day <- addDays d <$> resolveDayBackwards ld fd+    pure $ BothTimeAndDay $ LocalTime day tod -resolveLocalTimeBoth :: LocalTime -> FuzzyDay -> FuzzyTimeOfDay -> LocalTime-resolveLocalTimeBoth (LocalTime ld ltod) fd ftod =-  let withDiff = resolveTimeOfDayWithDiff ltod ftod-      withoutDiff = (0, resolveTimeOfDay ltod ftod)-      (d, tod) =-        case fd of-          Now -> withDiff-          Today -> withDiff-          _ -> withoutDiff-   in LocalTime (addDays d $ resolveDay ld fd) tod+resolveTimeOfDayForwards :: TimeOfDay -> FuzzyTimeOfDay -> Maybe TimeOfDay+resolveTimeOfDayForwards tod ftod = snd <$> resolveTimeOfDayForwardsWithDiff tod ftod -resolveTimeOfDay :: TimeOfDay -> FuzzyTimeOfDay -> TimeOfDay-resolveTimeOfDay tod ftod = snd $ resolveTimeOfDayWithDiff tod ftod+resolveTimeOfDayBackwards :: TimeOfDay -> FuzzyTimeOfDay -> Maybe TimeOfDay+resolveTimeOfDayBackwards tod ftod = snd <$> resolveTimeOfDayBackwardsWithDiff tod ftod -resolveTimeOfDayWithDiff :: TimeOfDay -> FuzzyTimeOfDay -> (Integer, TimeOfDay)-resolveTimeOfDayWithDiff tod@(TimeOfDay h m s) ftod =+resolveTimeOfDayForwardsWithDiff :: TimeOfDay -> FuzzyTimeOfDay -> Maybe (Integer, TimeOfDay)+resolveTimeOfDayForwardsWithDiff tod@(TimeOfDay h m s) ftod =   case ftod of-    SameTime -> (0, tod)-    Noon -> next midday-    Midnight -> next midnight-    Morning -> next morning-    Evening -> next evening-    AtHour h_ -> next $ TimeOfDay h_ 0 0-    AtMinute h_ m_ -> next $ TimeOfDay h_ m_ 0-    AtExact tod_ -> next tod_-    HoursDiff hd -> normaliseTimeOfDay (h + fromIntegral hd) m s-    MinutesDiff md -> normaliseTimeOfDay h (m + fromIntegral md) s-    SecondsDiff sd -> normaliseTimeOfDay h m (s + sd)+    SameTime -> Just (0, tod)+    Noon -> Just $ next midday+    Midnight -> Just $ next midnight+    Morning -> Just $ next morning+    Evening -> Just $ next evening+    AtHour h_ -> Just $ next $ TimeOfDay h_ 0 0+    AtMinute h_ m_ -> Just $ next $ TimeOfDay h_ m_ 0+    AtExact tod_ -> Just $ next tod_+    HoursDiff hd -> Just $ normaliseTimeOfDay (h + hd) m s+    MinutesDiff md -> Just $ normaliseTimeOfDay h (m + md) s+    SecondsDiff sd -> Just $ normaliseTimeOfDay h m (s + sd)   where     next tod_ = (skipIf (>= tod_), tod_)     skipIf p =@@ -72,6 +95,27 @@         then 1         else 0 +resolveTimeOfDayBackwardsWithDiff :: TimeOfDay -> FuzzyTimeOfDay -> Maybe (Integer, TimeOfDay)+resolveTimeOfDayBackwardsWithDiff tod@(TimeOfDay h m s) ftod =+  case ftod of+    SameTime -> Just (0, tod)+    Noon -> Just $ previous midday+    Midnight -> Just $ previous midnight+    Morning -> Just $ previous morning+    Evening -> Just $ previous evening+    AtHour h_ -> Just $ previous $ TimeOfDay h_ 0 0+    AtMinute h_ m_ -> Just $ previous $ TimeOfDay h_ m_ 0+    AtExact tod_ -> Just $ previous tod_+    HoursDiff hd -> Just $ normaliseTimeOfDay (h + hd) m s+    MinutesDiff md -> Just $ normaliseTimeOfDay h (m + md) s+    SecondsDiff sd -> Just $ normaliseTimeOfDay h m (s + sd)+  where+    previous tod_ = (skipIf (<= tod_), tod_)+    skipIf p =+      if p tod+        then (-1)+        else 0+ normaliseTimeOfDay :: Int -> Int -> Pico -> (Integer, TimeOfDay) normaliseTimeOfDay h m s =   let s' = s `mod'` 60@@ -88,59 +132,113 @@ evening :: TimeOfDay evening = TimeOfDay 18 0 0 -resolveDay :: Day -> FuzzyDay -> Day-resolveDay d fd =+resolveDayForwards :: Day -> FuzzyDay -> Maybe Day+resolveDayForwards d fd =   case fd of-    Yesterday -> addDays (-1) d-    Now -> d-    Today -> d-    Tomorrow -> addDays 1 d-    OnlyDay di -> nextDayOnDay d di-    DayInMonth mi di -> nextDayOndayInMonth d mi di-    DiffDays ds -> addDays (fromIntegral ds) d-    DiffWeeks ws -> addDays (7 * fromIntegral ws) d-    DiffMonths ms -> addDays (30 * fromIntegral ms) d-    NextDayOfTheWeek dow -> nextDayOfTheWeek d dow-    ExactDay d_ -> d_+    Yesterday -> Just $ addDays (-1) d+    Now -> Just d+    Today -> Just d+    Tomorrow -> Just $ addDays 1 d+    OnlyDay di -> nextDayOfMonth d di+    DayInMonth mi di -> nextDayOfMonthOfYear d mi di+    DiffDays ds -> Just $ addDays (fromIntegral ds) d+    DiffWeeks ws -> Just $ addDays (7 * fromIntegral ws) d+    DiffMonths ms -> Just $ addDays (30 * fromIntegral ms) d+    DayOfTheWeek dow diff -> Just $ addDays (7 * fromIntegral diff) (nextDayOfWeek d dow)+    ExactDay d_ -> Just d_ -nextDayOnDay :: Day -> Int -> Day-nextDayOnDay d di =-  let (y_, m_, _) = toGregorian d-      go :: Integer -> [(Month, Int)] -> Day-      go y [] =-        let y' = y + 1-         in go y' (daysInMonth y')-      go y ((month, mds) : rest) =-        if mds >= di-          then-            let d' = fromGregorian y (monthNum month) di-             in if d' >= d-                  then d'-                  else go y rest-          else go y rest-   in go y_ (drop (m_ - 1) $ daysInMonth y_)+resolveDayBackwards :: Day -> FuzzyDay -> Maybe Day+resolveDayBackwards d fd =+  case fd of+    Yesterday -> Just $ addDays (-1) d+    Now -> Just d+    Today -> Just d+    Tomorrow -> Just $ addDays 1 d+    OnlyDay di -> previousDayOfMonth d di+    DayInMonth mi di -> previousDayOfMonthOfYear d mi di+    DiffDays ds -> Just $ addDays (fromIntegral ds) d+    DiffWeeks ws -> Just $ addDays (7 * fromIntegral ws) d+    DiffMonths ms -> Just $ addDays (30 * fromIntegral ms) d+    DayOfTheWeek dow diff -> Just $ addDays (7 * fromIntegral diff) (previousDayOfWeek d dow)+    ExactDay d_ -> Just d_ -nextDayOndayInMonth :: Day -> Int -> Int -> Day-nextDayOndayInMonth d mi di =-  let (y_, _, _) = toGregorian d-      go y =-        let mds = fromJust $ lookup (numMonth mi) (daysInMonth y)-         in if mds >= di-              then-                let d' = fromGregorian y mi di-                 in if d' >= d-                      then d'-                      else go (y + 1)-              else go (y + 1)-   in go y_+nextDayOfMonth :: Day -> Word8 -> Maybe Day+nextDayOfMonth = dayOfMonthHelper nextAfterDay succ -nextDayOfTheWeek :: Day -> DayOfWeek -> Day-nextDayOfTheWeek d dow =-  let (_, _, i_) = toWeekDate d-      down = dayOfTheWeekNum dow-      diff = fromIntegral $ down - i_-      diff' =-        if diff <= 0-          then diff + 7-          else diff-   in addDays diff' d+previousDayOfMonth :: Day -> Word8 -> Maybe Day+previousDayOfMonth = dayOfMonthHelper previousBeforeDay pred++dayOfMonthHelper ::+  (Day -> Maybe Day -> Maybe Day -> Maybe Day) ->+  (Month -> Month) ->+  Day ->+  Word8 ->+  Maybe Day+dayOfMonthHelper chooser changer d wi =+  let di :: Int+      di = fromIntegral wi+      MonthDay thisMonth _ = d+      guessThisMonth = fromMonthDayValid thisMonth (fromIntegral wi)+      guessOtherMonth = fromMonthDayValid (changer thisMonth) di+   in chooser d guessThisMonth guessOtherMonth++nextDayOfMonthOfYear :: Day -> Word8 -> Word8 -> Maybe Day+nextDayOfMonthOfYear = dayOfMonthOfYearHelper nextAfterDay succ++previousDayOfMonthOfYear :: Day -> Word8 -> Word8 -> Maybe Day+previousDayOfMonthOfYear = dayOfMonthOfYearHelper previousBeforeDay pred++dayOfMonthOfYearHelper ::+  (Day -> Maybe Day -> Maybe Day -> Maybe Day) ->+  (Integer -> Integer) ->+  Day ->+  Word8 ->+  Word8 ->+  Maybe Day+dayOfMonthOfYearHelper chooser changer d mw dw =+  let mi = fromIntegral mw+      di = fromIntegral dw+      (y, _, _) = toGregorian d+      current =+        fromYearMonthValid y mi >>= \m ->+          fromMonthDayValid m di+      other =+        fromYearMonthValid (changer y) mi >>= \m ->+          fromMonthDayValid m di+   in chooser d current other++nextDayOfWeek :: Day -> DayOfWeek -> Day+nextDayOfWeek = dayOfWeekHelper (\d current after -> if current > d then current else after) (addDays 7)++previousDayOfWeek :: Day -> DayOfWeek -> Day+previousDayOfWeek = dayOfWeekHelper (\d current before -> if current < d then current else before) (addDays (-7))++dayOfWeekHelper ::+  (Day -> Day -> Day -> Day) ->+  (Day -> Day) ->+  Day ->+  DayOfWeek ->+  Day+dayOfWeekHelper chooser changer day dow =+  let (y, woy, _) = toWeekDate day+      currentGuess = fromWeekDate y woy (fromEnum dow)+      otherGuess = changer currentGuess+   in chooser day currentGuess otherGuess++nextAfterDay :: Day -> Maybe Day -> Maybe Day -> Maybe Day+nextAfterDay today beforeGuess afterGuess =+  case beforeGuess of+    Just d ->+      if d > today+        then beforeGuess+        else afterGuess+    Nothing -> afterGuess++previousBeforeDay :: Day -> Maybe Day -> Maybe Day -> Maybe Day+previousBeforeDay today afterGuess beforeGuess =+  case afterGuess of+    Just d ->+      if d < today+        then afterGuess+        else beforeGuess+    Nothing -> beforeGuess

@@ -12,47 +12,31 @@ import Control.DeepSeq (NFData) import Data.Fixed (Pico) import Data.Int (Int16)-import Data.Time (Day, DayOfWeek (Friday, Monday, Saturday, Sunday, Thursday, Tuesday, Wednesday), LocalTime, TimeOfDay, isLeapYear)+import Data.Time (Day, DayOfWeek (Friday, Monday, Saturday, Sunday, Thursday, Tuesday, Wednesday), LocalTime, TimeOfDay) import Data.Validity (Validity (validate), declare, decorate, genericValidate, valid) import Data.Validity.Time ()+import Data.Word (Word8) import GHC.Generics (Generic) -data FuzzyZonedTime-  = ZonedNow-  deriving (Show, Eq, Generic)--instance Validity FuzzyZonedTime--instance NFData FuzzyZonedTime- data AmbiguousLocalTime-  = OnlyDaySpecified Day-  | BothTimeAndDay LocalTime+  = OnlyDaySpecified !Day+  | BothTimeAndDay !LocalTime   deriving (Show, Eq, Generic)  instance Validity AmbiguousLocalTime  instance NFData AmbiguousLocalTime -newtype FuzzyLocalTime = FuzzyLocalTime-  { unFuzzyLocalTime :: Some FuzzyDay FuzzyTimeOfDay-  }+data FuzzyLocalTime+  = FuzzyLocalTimeDay !FuzzyDay+  | FuzzyLocalTimeTimeOfDay !FuzzyTimeOfDay+  | FuzzyLocalTimeBoth !FuzzyDay !FuzzyTimeOfDay   deriving (Show, Eq, Generic)  instance Validity FuzzyLocalTime  instance NFData FuzzyLocalTime -data Some a b-  = One a-  | Other b-  | Both a b-  deriving (Show, Eq, Generic)--instance (Validity a, Validity b) => Validity (Some a b)--instance (NFData a, NFData b) => NFData (Some a b)- data FuzzyTimeOfDay   = SameTime   | Noon@@ -107,13 +91,13 @@   | Now   | Today   | Tomorrow-  | OnlyDay Int-  | DayInMonth Int Int-  | DiffDays Int16-  | DiffWeeks Int16-  | DiffMonths Int16-  | NextDayOfTheWeek DayOfWeek-  | ExactDay Day+  | OnlyDay !Word8+  | DayInMonth !Word8 !Word8+  | DiffDays !Int16+  | DiffWeeks !Int16+  | DiffMonths !Int16+  | DayOfTheWeek !DayOfWeek !Int16 -- Extra diff weeks+  | ExactDay !Day   deriving (Show, Eq, Generic)  instance Validity FuzzyDay where@@ -133,9 +117,7 @@                 [ declare "The day is strictly positive" $ di >= 1,                   declare "The day is less than or equal to 31" $ di <= 31,                   declare "The month is strictly positive" $ mi >= 1,-                  declare "The month is less than or equal to 12" $ mi <= 12,-                  declare "The number of days makes sense for the month" $-                    maybe False (>= di) $ lookup (numMonth mi) (daysInMonth 2004)+                  declare "The month is less than or equal to 12" $ mi <= 12                 ]           _ -> valid       ]@@ -147,54 +129,3 @@ #if !MIN_VERSION_time(1,11,1) instance NFData DayOfWeek #endif--dayOfTheWeekNum :: DayOfWeek -> Int-dayOfTheWeekNum = fromEnum--numDayOfTheWeek :: Int -> DayOfWeek-numDayOfTheWeek = toEnum--data Month-  = January-  | February-  | March-  | April-  | May-  | June-  | July-  | August-  | September-  | October-  | November-  | December-  deriving (Show, Eq, Generic, Enum, Bounded)--instance Validity Month--instance NFData Month--daysInMonth :: Integer -> [(Month, Int)]-daysInMonth y =-  [ (January, 31),-    ( February,-      if isLeapYear y-        then 29-        else 28-    ),-    (March, 31),-    (April, 30),-    (May, 31),-    (June, 30),-    (July, 31),-    (August, 31),-    (September, 30),-    (October, 31),-    (November, 30),-    (December, 31)-  ]--monthNum :: Month -> Int-monthNum = (+ 1) . fromEnum--numMonth :: Int -> Month-numMonth = toEnum . (\x -> x - 1)