diff --git a/app/Main.hs b/app/Main.hs index 2cdd5f0..09c3fdf 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -158,12 +158,15 @@ runSync :: MonadUnliftIO m => FilePath -> m () runSync c = do config <- readConfig c handle err $ migrate_ (sqlConfig config) $ do - s <- getDBState config - flip runReaderT (s $ takeDirectory c) $ do - es1 <- insertBudget $ budget config - es2 <- insertStatements config - let es = es1 ++ es2 - unless (null es) $ throwIO $ InsertException es + 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 + let es = es1 ++ es2 + unless (null es) $ throwIO $ InsertException es where err (InsertException es) = do liftIO $ mapM_ TI.putStrLn $ concatMap showError es diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 24c803b..01c562f 100644 --- a/dhall/Types.dhall +++ b/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 } diff --git a/dhall/common.dhall b/dhall/common.dhall index 233c308..053a84e 100644 --- a/dhall/common.dhall +++ b/dhall/common.dhall @@ -4,7 +4,7 @@ let List/map = let T = ./Types.dhall - sha256:8aa818fc10bf9468f39cb4fdfc9e05d37fa7ffb6060b1c6e1f420ba61f113a1e + sha256:49fae993de77c82248b3a53a7237ee06542331e969b185cc943a56746247d4e1 let nullSplit = \(a : T.SplitAcnt) -> diff --git a/lib/Internal/Database/Model.hs b/lib/Internal/Database/Model.hs index 1731145..be731e8 100644 --- a/lib/Internal/Database/Model.hs +++ b/lib/Internal/Database/Model.hs @@ -80,8 +80,8 @@ type CurrencyMap = M.Map CurID CurrencyRId data DBState = DBState { kmCurrency :: !CurrencyMap , kmAccount :: !AccountMap - , kmBudgetInterval :: !MaybeBounds - , kmStatementInterval :: !MaybeBounds + , kmBudgetInterval :: !Bounds + , kmStatementInterval :: !Bounds , kmNewCommits :: ![Int] , kmConfigDir :: !FilePath , kmBoundsCache :: !(MVar (M.Map (Bounds, DatePat) [Day])) diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index c2627cd..6433f58 100644 --- a/lib/Internal/Database/Ops.hs +++ b/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 - , kmStatementInterval = intervalMaybeBounds $ statementInterval $ global c + , kmBudgetInterval = b + , kmStatementInterval = s , kmNewCommits = hs , kmConfigDir = f , kmBoundsCache = v } + where + bi = resolveBounds $ budgetInterval $ global c + si = resolveBounds $ statementInterval $ global c diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index dbe07d9..622ac2d 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -17,206 +17,87 @@ 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 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 :: Bounds -> DatePat -> EitherErrs [Day] expandDatePat b (Cron cp) = expandCronPat b cp --- expandDatePat (a, b) (Cron cp) = --- fmap xGregToDay $ --- filter (cronPatternMatches cp) $ --- take (fromIntegral $ diffDays b a) $ --- gregorians a -expandDatePat i (Mod mp) = expandModPat mp i +expandDatePat i (Mod mp) = Right $ expandModPat mp i expandModPat :: ModPat -> Bounds -> [Day] -expandModPat - ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} - (lower, upper) = - takeWhile (<= upper) $ - (`addFun` start) . (* b') - <$> maybe id (take . fromIntegral) r [0 ..] - where - start = maybe lower fromGregorian' s - b' = fromIntegral b - addFun = case u of - Day -> addDays - Week -> addDays . (* 7) - 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 {..} = --- 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 - } +expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs = + takeWhile (<= upper) $ + (`addFun` start) . (* b') + <$> maybe id (take . fromIntegral) r [0 ..] where - (y0, m0, d0) = toGregorian x - (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 + (lower, upper) = expandBounds bs + start = maybe lower fromGregorian' s + b' = fromIntegral b + addFun = case u of + Day -> addDays + Week -> addDays . (* 7) + Month -> addGregorianMonthsClip + Year -> addGregorianYearsClip - compileW (OnDay w) = [fromEnum w] - compileW (OnDays ws) = fromEnum <$> ws - -nextCronPat :: CompiledCronPat -> Maybe (Day, CompiledCronPat) -nextCronPat CompiledCronPat {ccpYear = []} = Nothing -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}) +expandCronPat :: Bounds -> CronPat -> EitherErrs [Day] +expandCronPat b CronPat {..} = concatEither3 yRes mRes dRes $ \ys ms ds -> + filter validWeekday $ + mapMaybe (uncurry3 toDay) $ + takeWhile (\((y, _), m, d) -> (y, m, d) <= (yb1, mb1, db1)) $ + dropWhile (\((y, _), m, d) -> (y, m, d) < (yb0, mb0, db0)) $ + [(y, m, d) | y <- (\y -> (y, isLeapYear y)) <$> ys, m <- ms, d <- ds] 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 + yRes = case cronYear of + Nothing -> return [yb0 .. yb1] + Just pat -> do + ys <- expandMDYPat (fromIntegral yb1) pat + return $ dropWhile (< yb0) $ fromIntegral <$> ys + mRes = expandMD 12 cronMonth + dRes = expandMD 31 cronDay + (s, e) = expandBounds b + (yb0, mb0, db0) = toGregorian s + (yb1, mb1, db1) = toGregorian $ addDays (-1) e + expandMD lim = fmap (fromIntegral <$>) . maybe (return [1 .. lim]) (expandMDYPat lim) + 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 + +expandMDYPat :: Natural -> MDYPat -> EitherErr [Natural] +expandMDYPat _ (Single x) = Right [x] +expandMDYPat _ (Multi xs) = Right xs +expandMDYPat lim (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r}) + | b < 1 = Left $ PatternError s b r ZeroLength + | otherwise = do + k <- limit r + return $ takeWhile (<= k) [s + i * b | i <- [0 ..]] + where + limit Nothing = Right lim + limit (Just n) + -- this guard not only produces the error for the user but also protects + -- from an underflow below it + | n < 1 = Left $ PatternError s b r ZeroRepeats + | otherwise = Right $ min (s + b * (n - 1)) lim 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 - -askBounds :: MonadUnliftIO m => MappingT m Bounds -askBounds = (liftIO . resolveBounds) =<< asks kmBudgetInterval + mapM (mapM f) days -------------------------------------------------------------------------------- -- 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 -> - fmap concat $ withDates incWhen $ \day -> do + unlessLeft (balanceIncome i) $ \balance -> 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 - forM transAmounts $ \(TimeAmount amt pat) -> - withDates pat $ \day -> insertBudgetTx $ budgetTx amt day key + fmap concat $ whenHash CTExpense t [] $ \key -> do + forM transAmounts $ \(TimeAmount amt pat) -> do + 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 - let days = expandDatePat bounds dp - res <- mapM tx days - unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c) + bounds <- asks kmStatementInterval + -- let days = expandDatePat bounds dp + let dayRes = expandDatePat bounds dp + 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 - res <- mapM resolveTx $ filter (inMaybeBounds bounds . txDate) bs + bounds <- expandBounds <$> asks kmStatementInterval + res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs unlessLefts_ (concatEithersL res) $ lift . mapM_ (insertTx c) where recoverIO x rest = do diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 9bc2daf..f566297 100644 --- a/lib/Internal/Types.hs +++ b/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) diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index a97acba..bb1ae93 100644 --- a/lib/Internal/Utils.hs +++ b/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 --- inBounds (d0, d1) x = d0 <= x && x <= d1 +-- TODO misleading name +inBounds :: (Day, Day) -> Day -> Bool +inBounds (d0, d1) x = d0 <= x && x < d1 -inMaybeBounds :: MaybeBounds -> Day -> Bool -inMaybeBounds (d0, d1) x = maybe True (x >=) d0 && maybe True (x <=) d1 - -intervalMaybeBounds :: Interval -> MaybeBounds -intervalMaybeBounds Interval {intStart = s, intEnd = e} = - (fmap fromGregorian' s, fmap fromGregorian' 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') +resolveBounds :: Interval -> EitherErr Bounds +resolveBounds Interval {intStart = s, intEnd = e} = + case fromGregorian' <$> e of + Nothing -> Right $ toBounds $ fromGregorian' $ s {gYear = gYear s + 50} + Just e_ + | s_ < e_ -> Right $ toBounds e_ + | otherwise -> Left $ BoundsError 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: " $