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

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 :: (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

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
 
@@ -288,8 +302,12 @@ instance Ord MatchYMD where
   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 (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
   compare (On d) (On d')      = compare d d'

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)
+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 (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
-    -- 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
-    (y, m, _) = toGregorianI x :: (Natural, Natural, Natural)
+    (y, m, _) = toGregorian x
-    sY = y2k y
+    compareRange start z
-    compareRange start offset z
       | 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 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