FIX date errors (off-by-2000 and field ordering from dhall)
This commit is contained in:
parent
1450124e90
commit
6f38362d76
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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'
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue