From 6f38362d76800ec0bae783299a1971d00448efec Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Mon, 19 Dec 2022 23:13:05 -0500 Subject: [PATCH] FIX date errors (off-by-2000 and field ordering from dhall) --- lib/Internal/Insert.hs | 33 +++++++++++---------- lib/Internal/Types.hs | 42 +++++++++++++++++++-------- lib/Internal/Utils.hs | 66 ++++++++++++++++++++++-------------------- 3 files changed, 82 insertions(+), 59 deletions(-) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index a9f98a6..2a391d0 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Internal.Insert @@ -70,30 +69,30 @@ expandModPat ModPat { mpStart = s $ (`addFun` start) . (* b') <$> maybe id (take . fromIntegral) r [0..] where - start = maybe lower fromGregorian_ s + start = maybe lower fromGregorian' s b' = fromIntegral b - fromGregorian_ (Gregorian {..}) = fromGregorian - (fromIntegral $ gYear + 2000) - (fromIntegral gMonth) - (fromIntegral gDay) addFun = case u of Day -> addDays Week -> addDays . (* 7) Month -> addGregorianMonthsClip Year -> addGregorianYearsClip +-- TODO this can be optimized to prevent filtering a bunch of dates for +-- one/a few cron patterns cronPatternMatches :: CronPat -> Day -> Bool cronPatternMatches CronPat { cronWeekly = w , cronYear = y , cronMonth = m , cronDay = d } x = - mdyMaybe (y' - 2000) y && mdyMaybe m' m && mdyMaybe d' d && wdMaybe (dayOfWeek_ x) w + yMaybe (y' - 2000) y && mdMaybe m' m && mdMaybe d' d && wdMaybe (dayOfWeek_ x) w where testMaybe = maybe True - mdyMaybe z = testMaybe (`mdyPatternMatches` fromIntegral z) + yMaybe z = testMaybe (mdyPatternMatches testYear (fromIntegral z)) + mdMaybe z = testMaybe (mdyPatternMatches (const Nothing) (fromIntegral z)) wdMaybe z = testMaybe (`weekdayPatternMatches` z) (y', m', d') = toGregorian x + testYear z = if z > 99 then Just "year must be 2 digits" else Nothing dayOfWeek_ :: Day -> Weekday dayOfWeek_ d = case dayOfWeek d of @@ -109,14 +108,16 @@ weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool weekdayPatternMatches (OnDay x) = (== x) weekdayPatternMatches (OnDays xs) = (`elem` xs) -mdyPatternMatches :: MDYPat -> Natural -> Bool -mdyPatternMatches (Single y) = (== y) -mdyPatternMatches (Multi xs) = (`elem` xs) -mdyPatternMatches (Repeat p) = repeatPatternMatches p - -repeatPatternMatches :: RepeatPat -> Natural -> Bool -repeatPatternMatches RepeatPat { rpStart = s, rpBy = b, rpRepeats = r } x = - s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r +mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool +mdyPatternMatches check x p = case p of + Single y -> errMaybe (check y) $ x == y + Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs + Repeat (RepeatPat { rpStart = s, rpBy = b, rpRepeats = r }) -> + errMaybe (check s) + $ s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r + where + errMaybe test rest = maybe rest err test + err msg = error $ show p ++ ": " ++ msg -------------------------------------------------------------------------------- -- budget diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 96afeee..98a9cba 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -7,6 +7,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -35,7 +36,7 @@ import Text.Read -- | YAML CONFIG ------------------------------------------------------------------------------- -makeHaskellTypes +makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False }) [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" @@ -147,22 +148,35 @@ deriving instance Hashable Weekday deriving instance Eq WeekdayPat deriving instance Hashable WeekdayPat +deriving instance Show RepeatPat deriving instance Eq RepeatPat deriving instance Hashable RepeatPat +deriving instance Show MDYPat deriving instance Eq MDYPat deriving instance Hashable MDYPat deriving instance Eq Gregorian -deriving instance Ord Gregorian deriving instance Show Gregorian deriving instance Hashable Gregorian deriving instance Eq GregorianM -deriving instance Ord GregorianM deriving instance Show GregorianM deriving instance Hashable GregorianM +-- Dhall.TH rearranges my fields :( +instance Ord Gregorian where + compare + Gregorian { gYear = y, gMonth = m, gDay = d} + Gregorian { gYear = y', gMonth = m', gDay = d'} = compare y y' + <> compare m m' + <> compare d d' + +instance Ord GregorianM where + compare + GregorianM { gmYear = y, gmMonth = m} + GregorianM { gmYear = y', gmMonth = m'} = compare y y' <> compare m m' + deriving instance Eq ModPat deriving instance Hashable ModPat @@ -281,15 +295,19 @@ deriving instance Show MatchDate -- TODO this just looks silly...but not sure how to simplify it instance Ord MatchYMD where - compare (Y y) (Y y') = compare y y' - compare (YM g) (YM g') = compare g g' - compare (YMD g) (YMD g') = compare g g' - compare (Y y) (YM g) = compare y (gmYear g) <> LT - compare (Y y) (YMD g) = compare y (gYear g) <> LT - compare (YM g) (Y y') = compare (gmYear g) y' <> GT - compare (YMD g) (Y y') = compare (gYear g) y' <> GT - compare (YM (GregorianM y m)) (YMD (Gregorian y' m' _)) = compare (y, m) (y', m') <> LT - compare (YMD (Gregorian y m _)) (YM (GregorianM y' m')) = compare (y, m) (y', m') <> GT + compare (Y y) (Y y') = compare y y' + compare (YM g) (YM g') = compare g g' + compare (YMD g) (YMD g') = compare g g' + compare (Y y) (YM g) = compare y (gmYear g) <> LT + compare (Y y) (YMD g) = compare y (gYear g) <> LT + compare (YM g) (Y y') = compare (gmYear g) y' <> GT + compare (YMD g) (Y y') = compare (gYear g) y' <> GT + compare (YM g) (YMD g') = compare g (gregM g') <> LT + compare (YMD g) (YM g') = compare (gregM g) g' <> GT + +gregM :: Gregorian -> GregorianM +gregM Gregorian { gYear = y, gMonth = m} + = GregorianM { gmYear = y, gmMonth = m} instance Ord MatchDate where compare (On d) (On d') = compare d d' diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index 521aa9b..618f348 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -27,47 +27,51 @@ descMatches (Exact t) = (== t) thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f) thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) -toGregorianI :: (Integral a, Integral b, Integral c) => Day -> (a, b, c) -toGregorianI = thrice fromIntegral fromIntegral fromIntegral . toGregorian +gregTup :: Gregorian -> (Integer, Int, Int) +gregTup g@Gregorian {..} + | gYear > 99 = error $ show g ++ ": year must only be two digits" + | otherwise = ( fromIntegral gYear + 2000 + , fromIntegral gMonth + , fromIntegral gDay) -fromGregorianI :: Natural -> Natural -> Natural -> Day -fromGregorianI y m d = - fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d) +gregMTup :: GregorianM -> (Integer, Int) +gregMTup g@GregorianM {..} + | gmYear > 99 = error $ show g ++ ": year must only be two digits" + | otherwise = ( fromIntegral gmYear + 2000 + , fromIntegral gmMonth) -toModifiedJulianDayI :: Day -> Natural -toModifiedJulianDayI = fromIntegral . toModifiedJulianDay +data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int + +fromMatchYMD :: MatchYMD -> MDY_ +fromMatchYMD m = case m of + Y y + | y > 99 -> error $ show m ++ ": year must only be two digits" + | otherwise -> Y_ $ fromIntegral y + 2000 + YM g -> uncurry YM_ $ gregMTup g + YMD g -> uncurry3 YMD_ $ gregTup g compareDate :: MatchDate -> Day -> Ordering -compareDate (On md) x = case md of - Y y' -> compare sY y' - YM (GregorianM y' m') -> compare (sY, m) (y', m') - YMD (Gregorian y' m' d') -> compare (sY, m, d) (y', m', d') +compareDate (On md) x = case fromMatchYMD md of + Y_ y' -> compare y y' + YM_ y' m' -> compare (y, m) (y', m') + YMD_ y' m' d' -> compare (y, m, d) (y', m', d') where - -- TODO make this actually give a real gregorian type, which will clean - -- this up - (y, m, d) = toGregorianI x - sY = y2k y -compareDate (In md o) x = case md of - Y y' -> compareRange y' o sY - YM (GregorianM y' m') -> let s = toMonth y' m' in compareRange s o $ toMonth sY m - YMD (Gregorian y' m' d') -> - let s = toModifiedJulianDayI $ fromGregorianI (y' + 2000) m' d' - in compareRange s o $ toModifiedJulianDayI x + (y, m, d) = toGregorian x +compareDate (In md offset) x = case fromMatchYMD md of + Y_ y' -> compareRange y' y + YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m + YMD_ y' m' d' -> let s = toModifiedJulianDay $ fromGregorian y' m' d' + in compareRange s $ toModifiedJulianDay x where - (y, m, _) = toGregorianI x :: (Natural, Natural, Natural) - sY = y2k y - compareRange start offset z + (y, m, _) = toGregorian x + compareRange start z | z < start = LT - | otherwise = if (start + offset) < z then GT else EQ - toMonth year month = (year * 12) + month + | otherwise = if (start + fromIntegral offset) < z then GT else EQ + toMonth year month = (year * 12) + fromIntegral month dateMatches :: MatchDate -> Day -> Bool dateMatches md = (EQ ==) . compareDate md --- this apparently can't be eta reduced without triggering an underflow -y2k :: Natural -> Natural -y2k x = x - 2000 - valMatches :: MatchVal -> Rational -> Bool valMatches MatchVal {..} x = checkMaybe (s ==) mvSign && checkMaybe (n ==) mvNum @@ -199,7 +203,7 @@ boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds boundsFromGregorian = bimap fromGregorian' fromGregorian' fromGregorian' :: Gregorian -> Day -fromGregorian' (Gregorian y m d) = fromGregorianI y m d +fromGregorian' = uncurry3 fromGregorian . gregTup inBounds :: Bounds -> Day -> Bool inBounds (d0, d1) x = d0 <= x && x <= d1