ENH use better algorithm for cronpatterns
This commit is contained in:
parent
56a14e5e9e
commit
dae132c8b9
15
app/Main.hs
15
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
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ let List/map =
|
|||
|
||||
let T =
|
||||
./Types.dhall
|
||||
sha256:8aa818fc10bf9468f39cb4fdfc9e05d37fa7ffb6060b1c6e1f420ba61f113a1e
|
||||
sha256:49fae993de77c82248b3a53a7237ee06542331e969b185cc943a56746247d4e1
|
||||
|
||||
let nullSplit =
|
||||
\(a : T.SplitAcnt) ->
|
||||
|
|
|
|||
|
|
@ -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]))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
|
|
@ -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: " $
|
||||
|
|
|
|||
Loading…
Reference in New Issue