ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

FIX date errors (off-by-2000 and field ordering from dhall)

This commit is contained in:
Nathan Dwarshuis 2022-12-19 23:13:05 -05:00
parent 1450124e90
commit 6f38362d76
3 changed files with 82 additions and 59 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
lib/Internal/Insert.hs
View File

@ -1,6 +1,5 @@
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-} {-# LANGUAGE TupleSections #-}
module Internal.Insert module Internal.Insert
@ -70,30 +69,30 @@ expandModPat ModPat { mpStart = s
$ (`addFun` start) . (* b') $ (`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0..] <$> maybe id (take . fromIntegral) r [0..]
where where
start = maybe lower fromGregorian_ s start = maybe lower fromGregorian' s
b' = fromIntegral b b' = fromIntegral b
fromGregorian_ (Gregorian {..}) = fromGregorian
(fromIntegral $ gYear + 2000)
(fromIntegral gMonth)
(fromIntegral gDay)
addFun = case u of addFun = case u of
Day -> addDays Day -> addDays
Week -> addDays . (* 7) Week -> addDays . (* 7)
Month -> addGregorianMonthsClip Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip 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 -> Day -> Bool
cronPatternMatches CronPat { cronWeekly = w cronPatternMatches CronPat { cronWeekly = w
, cronYear = y , cronYear = y
, cronMonth = m , cronMonth = m
, cronDay = d , cronDay = d
} x = } 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 where
testMaybe = maybe True 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) wdMaybe z = testMaybe (`weekdayPatternMatches` z)
(y', m', d') = toGregorian x (y', m', d') = toGregorian x
testYear z = if z > 99 then Just "year must be 2 digits" else Nothing
dayOfWeek_ :: Day -> Weekday dayOfWeek_ :: Day -> Weekday
dayOfWeek_ d = case dayOfWeek d of dayOfWeek_ d = case dayOfWeek d of
@ -109,14 +108,16 @@ weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool
weekdayPatternMatches (OnDay x) = (== x) weekdayPatternMatches (OnDay x) = (== x)
weekdayPatternMatches (OnDays xs) = (`elem` xs) weekdayPatternMatches (OnDays xs) = (`elem` xs)
mdyPatternMatches :: MDYPat -> Natural -> Bool mdyPatternMatches :: (Natural -> Maybe String) -> Natural -> MDYPat -> Bool
mdyPatternMatches (Single y) = (== y) mdyPatternMatches check x p = case p of
mdyPatternMatches (Multi xs) = (`elem` xs) Single y -> errMaybe (check y) $ x == y
mdyPatternMatches (Repeat p) = repeatPatternMatches p Multi xs -> errMaybe (msum $ check <$> xs) $ x `elem` xs
Repeat (RepeatPat { rpStart = s, rpBy = b, rpRepeats = r }) ->
repeatPatternMatches :: RepeatPat -> Natural -> Bool errMaybe (check s)
repeatPatternMatches RepeatPat { rpStart = s, rpBy = b, rpRepeats = r } x = $ s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
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 -- budget

42
lib/Internal/Types.hs
View File

@ -7,6 +7,7 @@
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-} {-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
@ -35,7 +36,7 @@ import Text.Read
-- | YAML CONFIG -- | YAML CONFIG
------------------------------------------------------------------------------- -------------------------------------------------------------------------------
makeHaskellTypes makeHaskellTypesWith (defaultGenerateOptions { generateToDhallInstance = False })
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig" [ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
, MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit" , MultipleConstructors "TimeUnit" "(./dhall/Types.dhall).TimeUnit"
, MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday" , MultipleConstructors "Weekday" "(./dhall/Types.dhall).Weekday"
@ -147,22 +148,35 @@ deriving instance Hashable Weekday
deriving instance Eq WeekdayPat deriving instance Eq WeekdayPat
deriving instance Hashable WeekdayPat deriving instance Hashable WeekdayPat
deriving instance Show RepeatPat
deriving instance Eq RepeatPat deriving instance Eq RepeatPat
deriving instance Hashable RepeatPat deriving instance Hashable RepeatPat
deriving instance Show MDYPat
deriving instance Eq MDYPat deriving instance Eq MDYPat
deriving instance Hashable MDYPat deriving instance Hashable MDYPat
deriving instance Eq Gregorian deriving instance Eq Gregorian
deriving instance Ord Gregorian
deriving instance Show Gregorian deriving instance Show Gregorian
deriving instance Hashable Gregorian deriving instance Hashable Gregorian
deriving instance Eq GregorianM deriving instance Eq GregorianM
deriving instance Ord GregorianM
deriving instance Show GregorianM deriving instance Show GregorianM
deriving instance Hashable 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 Eq ModPat
deriving instance Hashable 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 -- TODO this just looks silly...but not sure how to simplify it
instance Ord MatchYMD where instance Ord MatchYMD where
compare (Y y) (Y y') = compare y y' compare (Y y) (Y y') = compare y y'
compare (YM g) (YM g') = compare g g' compare (YM g) (YM g') = compare g g'
compare (YMD g) (YMD 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) (YM g) = compare y (gmYear g) <> LT
compare (Y y) (YMD g) = compare y (gYear g) <> LT compare (Y y) (YMD g) = compare y (gYear g) <> LT
compare (YM g) (Y y') = compare (gmYear g) y' <> GT compare (YM g) (Y y') = compare (gmYear g) y' <> GT
compare (YMD g) (Y y') = compare (gYear 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 (YM g) (YMD g') = compare g (gregM g') <> LT
compare (YMD (Gregorian y m _)) (YM (GregorianM y' m')) = compare (y, m) (y', m') <> GT 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 instance Ord MatchDate where
compare (On d) (On d') = compare d d' compare (On d) (On d') = compare d d'

66
lib/Internal/Utils.hs
View File

@ -27,47 +27,51 @@ descMatches (Exact t) = (== t)
thrice :: (a -> d) -> (b -> e) -> (c -> f) -> (a, b, c) -> (d, e, f) 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) thrice f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
toGregorianI :: (Integral a, Integral b, Integral c) => Day -> (a, b, c) gregTup :: Gregorian -> (Integer, Int, Int)
toGregorianI = thrice fromIntegral fromIntegral fromIntegral . toGregorian 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 gregMTup :: GregorianM -> (Integer, Int)
fromGregorianI y m d = gregMTup g@GregorianM {..}
fromGregorian (fromIntegral y) (fromIntegral m) (fromIntegral d) | gmYear > 99 = error $ show g ++ ": year must only be two digits"
| otherwise = ( fromIntegral gmYear + 2000
, fromIntegral gmMonth)
toModifiedJulianDayI :: Day -> Natural data MDY_ = Y_ Integer | YM_ Integer Int | YMD_ Integer Int Int
toModifiedJulianDayI = fromIntegral . toModifiedJulianDay
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 :: MatchDate -> Day -> Ordering
compareDate (On md) x = case md of compareDate (On md) x = case fromMatchYMD md of
Y y' -> compare sY y' Y_ y' -> compare y y'
YM (GregorianM y' m') -> compare (sY, m) (y', m') YM_ y' m' -> compare (y, m) (y', m')
YMD (Gregorian y' m' d') -> compare (sY, m, d) (y', m', d') YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
where where
-- TODO make this actually give a real gregorian type, which will clean (y, m, d) = toGregorian x
-- this up compareDate (In md offset) x = case fromMatchYMD md of
(y, m, d) = toGregorianI x Y_ y' -> compareRange y' y
sY = y2k y YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
compareDate (In md o) x = case md of YMD_ y' m' d' -> let s = toModifiedJulianDay $ fromGregorian y' m' d'
Y y' -> compareRange y' o sY in compareRange s $ toModifiedJulianDay x
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
where where
(y, m, _) = toGregorianI x :: (Natural, Natural, Natural) (y, m, _) = toGregorian x
sY = y2k y compareRange start z
compareRange start offset z
| z < start = LT | z < start = LT
| otherwise = if (start + offset) < z then GT else EQ | otherwise = if (start + fromIntegral offset) < z then GT else EQ
toMonth year month = (year * 12) + month toMonth year month = (year * 12) + fromIntegral month
dateMatches :: MatchDate -> Day -> Bool dateMatches :: MatchDate -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md 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 -> Rational -> Bool
valMatches MatchVal {..} x = checkMaybe (s ==) mvSign valMatches MatchVal {..} x = checkMaybe (s ==) mvSign
&& checkMaybe (n ==) mvNum && checkMaybe (n ==) mvNum
@ -199,7 +203,7 @@ boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds
boundsFromGregorian = bimap fromGregorian' fromGregorian' boundsFromGregorian = bimap fromGregorian' fromGregorian'
fromGregorian' :: Gregorian -> Day fromGregorian' :: Gregorian -> Day
fromGregorian' (Gregorian y m d) = fromGregorianI y m d fromGregorian' = uncurry3 fromGregorian . gregTup
inBounds :: Bounds -> Day -> Bool inBounds :: Bounds -> Day -> Bool
inBounds (d0, d1) x = d0 <= x && x <= d1 inBounds (d0, d1) x = d0 <= x && x <= d1