WIP make cron pattern faster

lib/Internal/Insert.hs

@@ -18,6 +18,8 @@ import Internal.Types hiding (sign)
 import Internal.Utils
 import RIO hiding (to)
 -- import qualified RIO.Map as M
+
+import qualified RIO.List as L
 import qualified RIO.Text as T
 import RIO.Time
 
@@ -35,12 +37,12 @@ import RIO.Time
 --       return (M.insert (d, p) res m, res)
 
 expandDatePat :: Bounds -> DatePat -> [Day]
--- TODO what happens when I only have one date that matches? total waste...
+expandDatePat b (Cron cp) = expandCronPat b cp
-expandDatePat (a, b) (Cron cp) =
+-- expandDatePat (a, b) (Cron cp) =
-  fmap xGregToDay $
+--   fmap xGregToDay $
-    filter (cronPatternMatches cp) $
+--     filter (cronPatternMatches cp) $
-      take (fromIntegral $ diffDays b a) $
+--       take (fromIntegral $ diffDays b a) $
-        gregorians a
+--         gregorians a
 expandDatePat i (Mod mp) = expandModPat mp i
 
 expandModPat :: ModPat -> Bounds -> [Day]
@@ -59,39 +61,149 @@ expandModPat
         Month -> addGregorianMonthsClip
         Year -> addGregorianYearsClip
 
+-- nextXGreg_ :: CronPat -> XGregorian -> XGregorian
+-- nextXGreg_ c XGregorian {xgYear = y, xgMonth = m, xgDay = d, xgDayOfWeek = w}
+--   | m == 12 && d == 31 = XGregorian (y + 1) 1 1 w_
+--   | (m == 2 && (not leap && d == 28 || (leap && d == 29)))
+--       || (m `elem` [4, 6, 9, 11] && d == 30)
+--       || (d == 31) =
+--       XGregorian y (m + 1) 1 w_
+--   | otherwise = XGregorian y m (d + 1) w_
+--   where
+--     -- don't use DayOfWeek from Data.Time since this uses mod (which uses a
+--     -- division opcode) and thus will be slower than just checking for equality
+--     -- and adding
+--     w_ = if w == 6 then 0 else w + 1
+--     leap = isLeapYear $ fromIntegral y
+
+monthLength :: (Integral a, Integral b, Integral c) => a -> b -> c
+monthLength y m
+  | m == 2 && isLeapYear (fromIntegral y) = 29
+  | m == 2 = 28
+  | m `elem` [4, 6, 9, 11] = 30
+  | otherwise = 31
+
 -- TODO this can be optimized to prevent filtering a bunch of dates for
 -- one/a few cron patterns
-cronPatternMatches :: CronPat -> XGregorian -> Bool
+-- cronPatternMatches :: CronPat -> XGregorian -> Bool
-cronPatternMatches CronPat {..} XGregorian {..} =
+-- cronPatternMatches CronPat {..} XGregorian {..} =
-  testYMD xgYear cronYear
+--   testYMD xgYear cronYear
-    && testYMD xgMonth cronMonth
+--     && testYMD xgMonth cronMonth
-    && testYMD xgDay cronDay
+--     && testYMD xgDay cronDay
-    && testW (dayOfWeek_ xgDayOfWeek) cronWeekly
+--     && testW (dayOfWeek_ xgDayOfWeek) cronWeekly
+--   where
+--     testYMD z = maybe True (mdyPatternMatches (fromIntegral z))
+--     testW z = maybe True (`weekdayPatternMatches` z)
+
+expandCronPat :: Bounds -> CronPat -> [Day]
+expandCronPat b = L.unfoldr nextCronPat . compileCronPat b
+
+data CompiledCronPat = CompiledCronPat
+  { ccpYear :: ![Int]
+  , ccpMonth :: !(Zipper Int)
+  , ccpDay :: !(Zipper Int)
+  , ccpWeekly :: ![Int]
+  , ccpMonthEnd :: !Int
+  , ccpDayEnd :: !Int
+  }
+  deriving (Show)
+
+data Zipper a = Zipper ![a] ![a] deriving (Show)
+
+initZipper :: [a] -> Zipper a
+initZipper = Zipper []
+
+resetZipper :: Zipper a -> Zipper a
+resetZipper (Zipper bs as) = initZipper $ reverse bs ++ as
+
+shiftZipperWhile :: (a -> Bool) -> Zipper a -> Zipper a
+shiftZipperWhile f z@(Zipper bs as) = case as of
+  [] -> z
+  x : xs
+    | f x -> shiftZipperWhile f $ Zipper (x : bs) xs
+    | otherwise -> z
+
+zipperCurrent :: Zipper a -> Either (Zipper a) (a, Zipper a)
+zipperCurrent z@(Zipper _ []) = Left $ resetZipper z
+zipperCurrent (Zipper bs (a : as)) = Right (a, Zipper (a : bs) as)
+
+compileCronPat :: Bounds -> CronPat -> CompiledCronPat
+compileCronPat (x, y) CronPat {..} =
+  CompiledCronPat
+    { ccpYear = maybe [y0_ .. y1_] compileMDY_ cronYear
+    , ccpMonth = compileDY [1 .. 12] m0 cronMonth
+    , ccpDay = compileDY [1 .. 31] d0 cronDay
+    , ccpWeekly = maybe [] compileW cronWeekly
+    , ccpMonthEnd = m1
+    , ccpDayEnd = d1
+    }
   where
-    testYMD z = maybe True (mdyPatternMatches (fromIntegral z))
+    (y0, m0, d0) = toGregorian x
-    testW z = maybe True (`weekdayPatternMatches` z)
+    (y1, m1, d1) = toGregorian y
+    y0_ = fromIntegral y0
+    y1_ = fromIntegral y1
+    compileDY def k = shiftZipperWhile (< k) . initZipper . maybe def compileMDY_
+    compileMDY_ (Single z) = [fromIntegral z]
+    compileMDY_ (Multi zs) = fromIntegral <$> zs
+    compileMDY_ (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = rs}) =
+      -- TODO minor perf improvement, filter the repeats before filterng <=31
+      let b' = fromIntegral b
+          xs = takeWhile (<= 31) $ L.iterate (+ b') $ fromIntegral s
+       in maybe xs (\r -> take (fromIntegral r) xs) rs
 
--- TODO could clean this up by making an enum instance for Weekday
+    compileW (OnDay w) = [fromEnum w]
-dayOfWeek_ :: Int -> Weekday
+    compileW (OnDays ws) = fromEnum <$> ws
-dayOfWeek_ d = case d of
-  0 -> Sun
-  1 -> Mon
-  2 -> Tue
-  3 -> Wed
-  4 -> Thu
-  5 -> Fri
-  _ -> Sat
 
-weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool
+nextCronPat :: CompiledCronPat -> Maybe (Day, CompiledCronPat)
-weekdayPatternMatches (OnDay x) = (== x)
+nextCronPat CompiledCronPat {ccpYear = []} = Nothing
-weekdayPatternMatches (OnDays xs) = (`elem` xs)
+nextCronPat c@(CompiledCronPat {..}) =
+  case zipperCurrent ccpMonth of
+    Left mz -> nextCronPat $ c {ccpYear = ys, ccpMonth = mz, ccpDay = resetZipper ccpDay}
+    Right (m, mz) -> case zipperCurrent ccpDay of
+      Left dz -> nextCronPat $ c {ccpMonth = mz, ccpDay = dz}
+      Right (d, dz)
+        | null ys && m >= ccpMonthEnd && d >= ccpDayEnd -> Nothing
+        | otherwise -> case dayMaybe m d of
+            Nothing -> nextCronPat $ c {ccpMonth = mz, ccpDay = resetZipper dz}
+            Just day -> Just (day, c {ccpDay = dz})
+  where
+    y : ys = ccpYear
+    -- TODO not the most efficient way to check weekdays (most likely) since
+    -- I have to go through all the trouble of converting to a day and then
+    -- doing some complex math to figure out which day of the week it is
+    validWeekday day =
+      null ccpWeekly
+        || (not (null ccpWeekly) && dayToWeekday day `elem` ccpWeekly)
+    dayMaybe m d
+      | d > monthLength y m = Nothing
+      | otherwise =
+          let day = fromGregorian (fromIntegral y) m d
+           in if validWeekday day then Just day else Nothing
 
-mdyPatternMatches :: Natural -> MDYPat -> Bool
+dayToWeekday :: Day -> Int
-mdyPatternMatches x p = case p of
+dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
-  Single y -> x == y
+
-  Multi xs -> x `elem` xs
+-- -- TODO could clean this up by making an enum instance for Weekday
-  Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
+-- dayOfWeek_ :: Int -> Weekday
-    s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
+-- dayOfWeek_ d = case d of
+--   0 -> Sun
+--   1 -> Mon
+--   2 -> Tue
+--   3 -> Wed
+--   4 -> Thu
+--   5 -> Fri
+--   _ -> Sat
+
+-- weekdayPatternMatches :: WeekdayPat -> Weekday -> Bool
+-- weekdayPatternMatches (OnDay x) = (== x)
+-- weekdayPatternMatches (OnDays xs) = (`elem` xs)
+
+-- mdyPatternMatches :: Natural -> MDYPat -> Bool
+-- mdyPatternMatches x p = case p of
+--   Single y -> x == y
+--   Multi xs -> x `elem` xs
+--   Repeat (RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) ->
+--     s >= x && mod x b == 0 && maybe True (\y -> x <= s + b * y) r
 
 withDates
   :: MonadUnliftIO m

lib/Internal/Types.hs

@@ -162,6 +162,8 @@ deriving instance Show Weekday
 
 deriving instance Hashable Weekday
 
+deriving instance Enum Weekday
+
 deriving instance Eq WeekdayPat
 
 deriving instance Ord WeekdayPat