ENH use better algorithm for cronpatterns

app/Main.hs

@@ -158,7 +158,10 @@ runSync :: MonadUnliftIO m => FilePath -> m ()
 runSync c = do
   config <- readConfig c
   handle err $ migrate_ (sqlConfig config) $ do
-    s <- getDBState config
+    res <- getDBState config
+    case res of
+      Left es -> throwIO $ InsertException es
+      Right s -> do
         flip runReaderT (s $ takeDirectory c) $ do
           es1 <- insertBudget $ budget config
           es2 <- insertStatements config

dhall/Types.dhall

@@ -14,7 +14,7 @@ let Gregorian = { gYear : Natural, gMonth : Natural, gDay : Natural }
 
 let GregorianM = { gmYear : Natural, gmMonth : Natural }
 
-let Interval = { intStart : Optional Gregorian, intEnd : Optional Gregorian }
+let Interval = { intStart : Gregorian, intEnd : Optional Gregorian }
 
 let Global = { budgetInterval : Interval, statementInterval : Interval }
 

dhall/common.dhall

@@ -4,7 +4,7 @@ let List/map =
 
 let T =
       ./Types.dhall
-        sha256:8aa818fc10bf9468f39cb4fdfc9e05d37fa7ffb6060b1c6e1f420ba61f113a1e
+        sha256:49fae993de77c82248b3a53a7237ee06542331e969b185cc943a56746247d4e1
 
 let nullSplit =
       \(a : T.SplitAcnt) ->

lib/Internal/Database/Model.hs

@@ -80,8 +80,8 @@ type CurrencyMap = M.Map CurID CurrencyRId
 data DBState = DBState
   { kmCurrency :: !CurrencyMap
   , kmAccount :: !AccountMap
-  , kmBudgetInterval :: !MaybeBounds
+  , kmBudgetInterval :: !Bounds
-  , kmStatementInterval :: !MaybeBounds
+  , kmStatementInterval :: !Bounds
   , kmNewCommits :: ![Int]
   , kmConfigDir :: !FilePath
   , kmBoundsCache :: !(MVar (M.Map (Bounds, DatePat) [Day]))

lib/Internal/Database/Ops.hs

@@ -308,7 +308,7 @@ indexAcntRoot r =
 getDBState
   :: MonadUnliftIO m
   => Config
-  -> SqlPersistT m (FilePath -> DBState)
+  -> SqlPersistT m (EitherErrs (FilePath -> DBState))
 getDBState c = do
   am <- updateAccounts $ accounts c
   cm <- updateCurrencies $ currencies c
@@ -316,13 +316,16 @@ getDBState c = do
   v <- newMVar M.empty
   -- TODO not sure how I feel about this, probably will change this struct alot
   -- in the future so whatever...for now
-  return $ \f ->
+  return $ concatEither2 bi si $ \b s f ->
     DBState
       { kmCurrency = cm
       , kmAccount = am
-      , kmBudgetInterval = intervalMaybeBounds $ budgetInterval $ global c
+      , kmBudgetInterval = b
-      , kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c
+      , kmStatementInterval = s
       , kmNewCommits = hs
       , kmConfigDir = f
       , kmBoundsCache = v
       }
+  where
+    bi = resolveBounds $ budgetInterval $ global c
+    si = resolveBounds $ statementInterval $ global c

lib/Internal/Insert.hs

@@ -17,42 +17,23 @@ import Internal.Statement
 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
 
 --------------------------------------------------------------------------------
 -- intervals
 
--- expandDatePat :: MonadUnliftIO m => Bounds -> DatePat -> MappingT m [Day]
+expandDatePat :: Bounds -> DatePat -> EitherErrs [Day]
--- expandDatePat d p = do
---   -- TODO crude memoization
---   v <- asks kmBoundsCache
---   modifyMVar v $ \m -> case M.lookup (d, p) m of
---     Just ds -> return (m, ds)
---     Nothing -> do
---       let res = expandDatePat_ d p
---       return (M.insert (d, p) res m, res)
-
-expandDatePat :: Bounds -> DatePat -> [Day]
 expandDatePat b (Cron cp) = expandCronPat b cp
--- expandDatePat (a, b) (Cron cp) =
+expandDatePat i (Mod mp) = Right $ expandModPat mp i
---   fmap xGregToDay $
---     filter (cronPatternMatches cp) $
---       take (fromIntegral $ diffDays b a) $
---         gregorians a
-expandDatePat i (Mod mp) = expandModPat mp i
 
 expandModPat :: ModPat -> Bounds -> [Day]
-expandModPat
+expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
-  ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r}
-  (lower, upper) =
   takeWhile (<= upper) $
     (`addFun` start) . (* b')
       <$> maybe id (take . fromIntegral) r [0 ..]
   where
+    (lower, upper) = expandBounds bs
     start = maybe lower fromGregorian' s
     b' = fromIntegral b
     addFun = case u of
@@ -61,162 +42,62 @@ expandModPat
       Month -> addGregorianMonthsClip
       Year -> addGregorianYearsClip
 
--- nextXGreg_ :: CronPat -> XGregorian -> XGregorian
+expandCronPat :: Bounds -> CronPat -> EitherErrs [Day]
--- nextXGreg_ c XGregorian {xgYear = y, xgMonth = m, xgDay = d, xgDayOfWeek = w}
+expandCronPat b CronPat {..} = concatEither3 yRes mRes dRes $ \ys ms ds ->
---   | m == 12 && d == 31 = XGregorian (y + 1) 1 1 w_
+  filter validWeekday $
---   | (m == 2 && (not leap && d == 28 || (leap && d == 29)))
+    mapMaybe (uncurry3 toDay) $
---       || (m `elem` [4, 6, 9, 11] && d == 30)
+      takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $
---       || (d == 31) =
+        dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $
---       XGregorian y (m + 1) 1 w_
+          [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds]
---   | 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 {..} =
---   testYMD xgYear cronYear
---     && testYMD xgMonth cronMonth
---     && testYMD xgDay cronDay
---     && 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
-    (y0, m0, d0) = toGregorian x
+    yRes = case cronYear of
-    (y1, m1, d1) = toGregorian y
+      Nothing -> return [yb0 .. yb1]
-    y0_ = fromIntegral y0
+      Just pat -> do
-    y1_ = fromIntegral y1
+        ys <- expandMDYPat (fromIntegral yb1) pat
-    compileDY def k = shiftZipperWhile (< k) . initZipper . maybe def compileMDY_
+        return $ dropWhile (< yb0) $ fromIntegral <$> ys
-    compileMDY_ (Single z) = [fromIntegral z]
+    mRes = expandMD 12 cronMonth
-    compileMDY_ (Multi zs) = fromIntegral <$> zs
+    dRes = expandMD 31 cronDay
-    compileMDY_ (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = rs}) =
+    (s, e) = expandBounds b
-      -- TODO minor perf improvement, filter the repeats before filterng <=31
+    (yb0, mb0, db0) = toGregorian s
-      let b' = fromIntegral b
+    (yb1, mb1, db1) = toGregorian $ addDays (-1) e
-          xs = takeWhile (<= 31) $ L.iterate (+ b') $ fromIntegral s
+    expandMD lim = fmap (fromIntegral <$>) . maybe (return [1 .. lim]) (expandMDYPat lim)
-       in maybe xs (\r -> take (fromIntegral r) xs) rs
+    expandW (OnDay x) = [fromEnum x]
+    expandW (OnDays xs) = fromEnum <$> xs
+    ws = maybe [] expandW cronWeekly
+    validWeekday = if null ws then const True else \day -> dayToWeekday day `elem` ws
+    toDay (y, leap) m d
+      | m == 2 && (not leap && d > 28 || leap && d > 29) = Nothing
+      | m `elem` [4, 6, 9, 11] && d > 30 = Nothing
+      | otherwise = Just $ fromGregorian y m d
 
-    compileW (OnDay w) = [fromEnum w]
+expandMDYPat :: Natural -> MDYPat -> EitherErr [Natural]
-    compileW (OnDays ws) = fromEnum <$> ws
+expandMDYPat _ (Single x) = Right [x]
-
+expandMDYPat _ (Multi xs) = Right xs
-nextCronPat :: CompiledCronPat -> Maybe (Day, CompiledCronPat)
+expandMDYPat lim (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
-nextCronPat CompiledCronPat {ccpYear = []} = Nothing
+  | b < 1 = Left $ PatternError s b r ZeroLength
-nextCronPat c@(CompiledCronPat {..}) =
+  | otherwise = do
-  case zipperCurrent ccpMonth of
+      k <- limit r
-    Left mz -> nextCronPat $ c {ccpYear = ys, ccpMonth = mz, ccpDay = resetZipper ccpDay}
+      return $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
-    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
+    limit Nothing = Right lim
-    -- TODO not the most efficient way to check weekdays (most likely) since
+    limit (Just n)
-    -- I have to go through all the trouble of converting to a day and then
+      -- this guard not only produces the error for the user but also protects
-    -- doing some complex math to figure out which day of the week it is
+      -- from an underflow below it
-    validWeekday day =
+      | n < 1 = Left $ PatternError s b r ZeroRepeats
-      null ccpWeekly
+      | otherwise = Right $ min (s + b * (n - 1)) lim
-        || (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
 
 dayToWeekday :: Day -> Int
 dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
 
--- -- TODO could clean this up by making an enum instance for Weekday
--- dayOfWeek_ :: Int -> Weekday
--- 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
   => DatePat
   -> (Day -> MappingT m a)
-  -> MappingT m [a]
+  -> MappingT m (EitherErrs [a])
 withDates dp f = do
-  bounds <- askBounds
+  bounds <- asks kmBudgetInterval
   let days = expandDatePat bounds dp
-  mapM f days
+  mapM (mapM f) days
-
-askBounds :: MonadUnliftIO m => MappingT m Bounds
-askBounds = (liftIO . resolveBounds) =<< asks kmBudgetInterval
 
 --------------------------------------------------------------------------------
 -- budget
@@ -263,8 +144,8 @@ data BudgetTx = BudgetTx
 insertIncome :: MonadUnliftIO m => Income -> MappingT m [InsertError]
 insertIncome i@Income {..} =
   whenHash CTIncome i [] $ \c ->
-    unlessLeft (balanceIncome i) $ \balance ->
+    unlessLeft (balanceIncome i) $ \balance -> do
-      fmap concat $ withDates incWhen $ \day -> do
+      res <- withDates incWhen $ \day -> do
         let meta = BudgetMeta c day incCurrency
         let fromAllos b = concatMap (fromAllo meta incFrom (Just b))
         let pre = fromAllos PreTax incPretax
@@ -279,6 +160,7 @@ insertIncome i@Income {..} =
                 , btDesc = "balance after deductions"
                 }
         fmap concat $ mapM insertBudgetTx $ bal : (pre ++ tax ++ post)
+      unlessLefts res $ return . concat
 
 fromAllo
   :: BudgetMeta
@@ -329,9 +211,10 @@ sumTaxes = sum . fmap (dec2Rat . taxValue)
 
 insertTransfer :: MonadUnliftIO m => Transfer -> MappingT m [InsertError]
 insertTransfer t@Transfer {..} =
-  fmap (concat . concat) $ whenHash CTExpense t [] $ \key -> do
+  fmap concat $ whenHash CTExpense t [] $ \key -> do
-    forM transAmounts $ \(TimeAmount amt pat) ->
+    forM transAmounts $ \(TimeAmount amt pat) -> do
-      withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
+      res <- withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key
+      unlessLefts res $ return . concat
   where
     meta d c = BudgetMeta {bmWhen = d, bmCur = transCurrency, bmCommit = c}
     budgetTx (Amount desc v) d c =
@@ -399,10 +282,12 @@ insertManual
     , manualDesc = e
     } = do
     whenHash CTManual m [] $ \c -> do
-      bounds <- (liftIO . resolveBounds) =<< asks kmStatementInterval
+      bounds <- asks kmStatementInterval
-      let days = expandDatePat bounds dp
+      -- let days = expandDatePat bounds dp
-      res <- mapM tx days
+      let dayRes = expandDatePat bounds dp
-      unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
+      unlessLefts dayRes $ \days -> do
+        txRes <- mapM tx days
+        unlessLefts_ (concatEithersL txRes) $ lift . mapM_ (insertTx c)
     where
       tx day = txPair day from to u (dec2Rat v) e
 
@@ -411,8 +296,8 @@ insertImport i = whenHash CTImport i [] $ \c -> do
   -- TODO this isn't efficient, the whole file will be read and maybe no
   -- transactions will be desired
   recoverIO (readImport i) $ \r -> unlessLefts r $ \bs -> do
-    bounds <- asks kmStatementInterval
+    bounds <- expandBounds <$> asks kmStatementInterval
-    res <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs
+    res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs
     unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c)
   where
     recoverIO x rest = do

lib/Internal/Types.hs

@@ -520,9 +520,9 @@ data TxRecord = TxRecord
   }
   deriving (Show, Eq, Ord)
 
-type Bounds = (Day, Day)
+type Bounds = (Day, Natural)
 
-type MaybeBounds = (Maybe Day, Maybe Day)
+-- type MaybeBounds = (Maybe Day, Maybe Day)
 
 data Keyed a = Keyed
   { kKey :: !Int64
@@ -576,6 +576,8 @@ data AllocationSuberr
   | TooManyBlanks
   deriving (Show)
 
+data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
+
 data InsertError
   = RegexError !T.Text
   | MatchValPrecisionError !Natural !Natural
@@ -585,6 +587,8 @@ data InsertError
   | LookupError !LookupSuberr !T.Text
   | BalanceError !BalanceType !CurID ![RawSplit]
   | IncomeError !DatePat
+  | PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
+  | BoundsError !Gregorian !(Maybe Gregorian)
   | StatementError ![TxRecord] ![MatchRe]
   deriving (Show)
 

lib/Internal/Utils.hs

@@ -5,7 +5,9 @@
 
 module Internal.Utils
   ( compareDate
-  , intervalMaybeBounds
+  -- , intervalMaybeBounds
+  , inBounds
+  , expandBounds
   , fmtRational
   , matches
   , fromGregorian'
@@ -23,7 +25,7 @@ module Internal.Utils
   , unlessLefts_
   , unlessLeft
   , unlessLefts
-  , inMaybeBounds
+  -- , inMaybeBounds
   , acntPath2Text
   , showT
   , lookupErr
@@ -119,29 +121,26 @@ compareDate (In md offset) x = do
       | otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
     toMonth year month = (year * 12) + fromIntegral month
 
--- boundsFromGregorian :: (Gregorian, Gregorian) -> Bounds
--- boundsFromGregorian (a, b) = (fromGregorian' a, fromGregorian' b)
-
 fromGregorian' :: Gregorian -> Day
 fromGregorian' = uncurry3 fromGregorian . gregTup
 
--- inBounds :: Bounds -> Day -> Bool
+-- TODO misleading name
--- inBounds (d0, d1) x = d0 <= x && x <= d1
+inBounds :: (Day, Day) -> Day -> Bool
+inBounds (d0, d1) x = d0 <= x && x < d1
 
-inMaybeBounds :: MaybeBounds -> Day -> Bool
+resolveBounds :: Interval -> EitherErr Bounds
-inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1
+resolveBounds Interval {intStart = s, intEnd = e} =
-
+  case fromGregorian' <$> e of
-intervalMaybeBounds :: Interval -> MaybeBounds
+    Nothing -> Right $ toBounds $ fromGregorian' $ s {gYear = gYear s + 50}
-intervalMaybeBounds Interval {intStart = s, intEnd = e} =
+    Just e_
-  (fmap fromGregorian' s, fmap fromGregorian' e)
+      | s_ < e_ -> Right $ toBounds e_
-
+      | otherwise -> Left $ BoundsError s e
-resolveBounds :: MonadUnliftIO m => MaybeBounds -> m Bounds
-resolveBounds (s, e) = do
-  s' <- maybe getDay return s
-  e' <- maybe (addGregorianYearsClip 50 <$> getDay) return e
-  return (s', e')
   where
-    getDay = utctDay <$> getCurrentTime
+    s_ = fromGregorian' s
+    toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
+
+expandBounds :: Bounds -> (Day, Day)
+expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
 
 --------------------------------------------------------------------------------
 -- matching
@@ -319,6 +318,25 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
 showError :: InsertError -> [T.Text]
 showError (StatementError ts ms) = (showTx <$> ts) ++ (showMatch <$> ms)
 showError other = (: []) $ case other of
+  (BoundsError a b) ->
+    T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]
+    where
+      showGreg (Just g) = showGregorian_ g
+      showGreg Nothing = "Inf"
+  (PatternError s b r p) -> T.unwords [msg, "in pattern: ", pat]
+    where
+      pat =
+        keyVals $
+          [ (k, v)
+          | (k, Just v) <-
+              [ ("start", Just $ showT s)
+              , ("by", Just $ showT b)
+              , ("repeats", showT <$> r)
+              ]
+          ]
+      msg = case p of
+        ZeroLength -> "Zero repeat length"
+        ZeroRepeats -> "Zero repeats"
   (RegexError re) -> T.append "could not make regex from pattern: " re
   (ConversionError x) -> T.append "Could not convert to rational number: " x
   (InsertIOError msg) -> T.append "IO Error: " msg
@@ -353,6 +371,9 @@ showError other = (: []) $ case other of
         NotOneBlank -> "Exactly one split must be blank"
       splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
 
+showGregorian_ :: Gregorian -> T.Text
+showGregorian_ Gregorian {..} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
+
 showTx :: TxRecord -> T.Text
 showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
   T.append "Unmatched transaction: " $