ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
pwncash/lib/Internal/Utils.hs

1040 lines
34 KiB
Haskell
Raw Blame History

module Internal.Utils
( compareDate
, expandDatePat
, askDays
, fromWeekday
, inDaySpan
, fromGregorian'
, resolveDaySpan
, resolveDaySpan_
, intersectDaySpan
, throwAppError
, liftInner
, liftExceptT
, liftExcept
, liftIOExcept
, liftIOExceptT
, combineError
, combineError_
, combineError3
, combineErrors
, mapErrors
, combineErrorM
, combineErrorM3
, combineErrorIO2
, combineErrorIO3
, combineErrorIOM2
, combineErrorIOM3
, collectErrorsIO
, mapErrorsIO
, mapErrorsPooledIO
, showError
, lookupErr
, uncurry3
, dateMatches
, valMatches
, lookupAccount
, lookupAccountKey
, lookupAccountType
, lookupCurrency
, lookupCurrencyKey
, lookupCurrencyPrec
, lookupTag
, mapAdd_
, groupKey
, groupWith
, balanceTxs
, expandTransfers
, expandTransfer
, entryPair
, singleQuote
, keyVals
, realFracToDecimalP
, roundToP
)
where
import Control.Monad.Error.Class
import Control.Monad.Except
import Data.Decimal
import Data.Time.Format.ISO8601
import qualified Database.Esqueleto.Experimental as E
import GHC.Real
import Internal.Types.Main
import RIO
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import RIO.State
import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
--------------------------------------------------------------------------------
-- intervals
expandDatePat :: DaySpan -> DatePat -> AppExcept [Day]
expandDatePat b (Cron cp) = expandCronPat b cp
expandDatePat i (Mod mp) = return $ expandModPat mp i
expandModPat :: ModPat -> DaySpan -> [Day]
expandModPat ModPat {mpStart = s, mpBy = b, mpUnit = u, mpRepeats = r} bs =
takeWhile (<= upper) $
(`addFun` start) . (* b')
<$> maybe id (take . fromIntegral) r [0 ..]
where
(lower, upper) = fromDaySpan bs
start = maybe lower fromGregorian' s
b' = fromIntegral b
addFun = case u of
Day -> addDays
Week -> addDays . (* 7)
Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip
expandCronPat :: DaySpan -> CronPat -> AppExcept [Day]
expandCronPat b CronPat {cpYear, cpMonth, cpDay, cpWeekly} =
combineError3 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
yRes = case cpYear of
Nothing -> return [yb0 .. yb1]
Just pat -> do
ys <- expandMDYPat (fromIntegral yb0) (fromIntegral yb1) pat
return $ dropWhile (< yb0) $ fromIntegral <$> ys
mRes = expandMD 12 cpMonth
dRes = expandMD 31 cpDay
(s, e) = fromDaySpan b
(yb0, mb0, db0) = toGregorian s
(yb1, mb1, db1) = toGregorian $ addDays (-1) e
expandMD lim =
fmap (fromIntegral <$>)
. maybe (return [1 .. lim]) (expandMDYPat 1 lim)
expandW (OnDay x) = [fromEnum x]
expandW (OnDays xs) = fromEnum <$> xs
ws = maybe [] expandW cpWeekly
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 -> Natural -> MDYPat -> AppExcept [Natural]
expandMDYPat lower upper (Single x) = return [x | lower <= x && x <= upper]
expandMDYPat lower upper (Multi xs) = return $ dropWhile (<= lower) $ takeWhile (<= upper) xs
expandMDYPat lower upper (After x) = return [max lower x .. upper]
expandMDYPat lower upper (Before x) = return [lower .. min upper x]
expandMDYPat lower upper (Between x y) = return [max lower x .. min upper y]
expandMDYPat lower upper (Repeat RepeatPat {rpStart = s, rpBy = b, rpRepeats = r})
| b < 1 = throwAppError $ DatePatternError s b r ZeroLength
| otherwise = do
k <- limit r
return $ dropWhile (<= lower) $ takeWhile (<= k) [s + i * b | i <- [0 ..]]
where
limit Nothing = return upper
limit (Just n)
-- this guard not only produces the error for the user but also protects
-- from an underflow below it
| n < 1 = throwAppError $ DatePatternError s b r ZeroRepeats
| otherwise = return $ min (s + b * (n - 1)) upper
dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
askDays
:: (MonadFinance m, MonadAppError m)
=> DatePat
-> Maybe Interval
-> m [Day]
askDays dp i = do
globalSpan <- asks (unBSpan . tsBudgetScope)
case i of
Just i' -> do
localSpan <- liftExcept $ resolveDaySpan i'
maybe (return []) expand $ intersectDaySpan globalSpan localSpan
Nothing -> expand globalSpan
where
expand = liftExcept . (`expandDatePat` dp)
--------------------------------------------------------------------------------
-- dates
-- | Lame weekday converter since day of weeks aren't in dhall (yet)
fromWeekday :: Weekday -> DayOfWeek
fromWeekday Mon = Monday
fromWeekday Tue = Tuesday
fromWeekday Wed = Wednesday
fromWeekday Thu = Thursday
fromWeekday Fri = Friday
fromWeekday Sat = Saturday
fromWeekday Sun = Sunday
gregTup :: Gregorian -> (Integer, Int, Int)
gregTup Gregorian {gYear, gMonth, gDay} =
( fromIntegral gYear
, fromIntegral gMonth
, fromIntegral gDay
)
gregMTup :: GregorianM -> (Integer, Int)
gregMTup GregorianM {gmYear, gmMonth} =
( fromIntegral gmYear
, fromIntegral gmMonth
)
data YMD_ = Y_ !Integer | YM_ !Integer !Int | YMD_ !Integer !Int !Int
fromYMDMatcher :: YMDMatcher -> YMD_
fromYMDMatcher m = case m of
Y y -> Y_ $ fromIntegral y
YM g -> uncurry YM_ $ gregMTup g
YMD g -> uncurry3 YMD_ $ gregTup g
compareDate :: DateMatcher -> Day -> Ordering
compareDate (On md) x =
case fromYMDMatcher md of
Y_ y' -> compare y y'
YM_ y' m' -> compare (y, m) (y', m')
YMD_ y' m' d' -> compare (y, m, d) (y', m', d')
where
(y, m, d) = toGregorian x
compareDate (In md offset) x = do
case fromYMDMatcher md of
Y_ y' -> compareRange y' y
YM_ y' m' -> compareRange (toMonth y' m') $ toMonth y m
YMD_ y' m' d' ->
let s = toModifiedJulianDay $ fromGregorian y' m' d'
in compareRange s $ toModifiedJulianDay x
where
(y, m, _) = toGregorian x
compareRange start z
| z < start = LT
| otherwise = if (start + fromIntegral offset - 1) < z then GT else EQ
toMonth year month = (year * 12) + fromIntegral month
fromGregorian' :: Gregorian -> Day
fromGregorian' = uncurry3 fromGregorian . gregTup
inDaySpan :: DaySpan -> Day -> Bool
inDaySpan bs = withinDays (fromDaySpan bs)
withinDays :: (Day, Day) -> Day -> Bool
withinDays (d0, d1) x = d0 <= x && x < d1
resolveDaySpan :: Interval -> AppExcept DaySpan
resolveDaySpan i@Interval {intStart = s} =
resolveDaySpan_ (s {gYear = gYear s + 50}) i
intersectDaySpan :: DaySpan -> DaySpan -> Maybe DaySpan
intersectDaySpan a b =
if b' > a' then Nothing else Just $ toDaySpan (a', b')
where
(a0, a1) = fromDaySpan a
(b0, b1) = fromDaySpan b
a' = max a0 a1
b' = min b0 b1
resolveDaySpan_ :: Gregorian -> Interval -> AppExcept DaySpan
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
-- TODO the default isn't checked here :/
case fromGregorian' <$> e of
Nothing -> return $ toDaySpan_ $ fromGregorian' def
Just e_
| s_ < e_ -> return $ toDaySpan_ e_
| otherwise -> throwAppError $ DaySpanError s e
where
s_ = fromGregorian' s
toDaySpan_ end = toDaySpan (s_, end)
fromDaySpan :: DaySpan -> (Day, Day)
fromDaySpan (d, n) = (d, addDays (fromIntegral n + 1) d)
-- ASSUME a < b
toDaySpan :: (Day, Day) -> DaySpan
toDaySpan (a, b) = (a, fromIntegral $ diffDays b a - 1)
--------------------------------------------------------------------------------
-- matching
valMatches :: ValMatcher -> Rational -> AppExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
| Just d_ <- vmDen, d_ >= p = throwAppError $ MatchValPrecisionError d_ p
| otherwise =
return $
checkMaybe (s ==) vmSign
&& checkMaybe (n ==) vmNum
&& checkMaybe ((d * fromIntegral p ==) . fromIntegral) vmDen
where
(n, d) = properFraction $ abs x
p = 10 ^ vmPrec
s = signum x >= 0
checkMaybe = maybe True
dateMatches :: DateMatcher -> Day -> Bool
dateMatches md = (EQ ==) . compareDate md
--------------------------------------------------------------------------------
-- error flow control
throwAppError :: MonadAppError m => AppError -> m a
throwAppError e = throwError $ AppException [e]
liftInner :: Monad m => ExceptT e Identity a -> ExceptT e m a
liftInner = mapExceptT (return . runIdentity)
liftExceptT :: MonadError e m => ExceptT e m a -> m a
liftExceptT x = runExceptT x >>= either throwError return
liftExcept :: MonadError e m => Except e a -> m a
liftExcept = either throwError return . runExcept
liftIOExceptT :: MonadIO m => AppExceptT m a -> m a
liftIOExceptT = fromEither <=< runExceptT
liftIOExcept :: MonadIO m => AppExcept a -> m a
liftIOExcept = fromEither . runExcept
combineError :: MonadAppError m => m a -> m b -> (a -> b -> c) -> m c
combineError a b f = combineErrorM a b (\x y -> pure $ f x y)
combineError_ :: MonadAppError m => m a -> m b -> m ()
combineError_ a b = do
_ <- catchError a $ \e ->
throwError =<< catchError (e <$ b) (return . (e <>))
_ <- b
return ()
combineErrorM :: MonadAppError m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorM a b f = do
a' <- catchError a $ \e ->
throwError =<< catchError (e <$ b) (return . (e <>))
f a' =<< b
combineError3 :: MonadAppError m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
combineError3 a b c f =
combineError (combineError a b (,)) c $ \(x, y) z -> f x y z
combineErrorM3 :: MonadAppError m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
combineErrorM3 a b c f = do
combineErrorM (combineErrorM a b (curry return)) c $ \(x, y) z -> f x y z
mapErrors :: (Traversable t, MonadAppError m) => (a -> m b) -> t a -> m (t b)
-- First, record number of each action. Then try each action. On first failure,
-- note it's position in the sequence, skip ahead to the untried actions,
-- collect failures and add to the first failure.
mapErrors f xs = mapM go $ enumTraversable xs
where
go (n, x) = catchError (f x) $ \e -> do
es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
throwError $ foldr (<>) e es
err x = catchError (Nothing <$ x) (pure . Just)
combineErrors :: (Traversable t, MonadAppError m) => t (m a) -> m (t a)
combineErrors = mapErrors id
enumTraversable :: (Num n, Traversable t) => t a -> t (n, a)
enumTraversable = snd . L.mapAccumL go 0
where
go n x = (n + 1, (n, x))
combineErrorIO2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> c) -> m c
combineErrorIO2 a b f = combineErrorIOM2 a b (\x y -> pure $ f x y)
combineErrorIO3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> d) -> m d
combineErrorIO3 a b c f = combineErrorIOM3 a b c (\x y z -> pure $ f x y z)
combineErrorIOM2 :: MonadUnliftIO m => m a -> m b -> (a -> b -> m c) -> m c
combineErrorIOM2 a b f = do
a' <- catch a $ \(AppException es) ->
(throwIO . AppException)
=<< catch (es <$ b) (\(AppException es') -> return (es' ++ es))
f a' =<< b
combineErrorIOM3 :: MonadUnliftIO m => m a -> m b -> m c -> (a -> b -> c -> m d) -> m d
combineErrorIOM3 a b c f =
combineErrorIOM2 (combineErrorIOM2 a b (curry return)) c $ \(x, y) z -> f x y z
mapErrorsPooledIO :: (Traversable t, MonadUnliftIO m) => Int -> (a -> m b) -> t a -> m (t b)
mapErrorsPooledIO t f xs = pooledMapConcurrentlyN t go $ enumTraversable xs
where
go (n, x) = catch (f x) $ \(AppException e) -> do
es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
throwIO $ AppException $ foldr (<>) e es
err x = catch (Nothing <$ x) $ \(AppException es) -> pure $ Just es
mapErrorsIO :: (Traversable t, MonadUnliftIO m) => (a -> m b) -> t a -> m (t b)
mapErrorsIO f xs = mapM go $ enumTraversable xs
where
go (n, x) = catch (f x) $ \(AppException e) -> do
es <- fmap catMaybes $ mapM (err . f) $ drop (n + 1) $ toList xs
throwIO $ AppException $ foldr (<>) e es
err x = catch (Nothing <$ x) $ \(AppException es) -> pure $ Just es
collectErrorsIO :: (Traversable t, MonadUnliftIO m) => t (m a) -> m (t a)
collectErrorsIO = mapErrorsIO id
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> AppExcept v
lookupErr what k m = case M.lookup k m of
Just x -> return x
_ -> throwAppError $ LookupError what $ tshow k
--------------------------------------------------------------------------------
-- error display
showError :: AppError -> [T.Text]
showError other = case other of
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
(DaySpanError a b) ->
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
where
showGreg (Just g) = showGregorian_ g
showGreg Nothing = "Inf"
(AccountTypeError a ts) ->
[ T.unwords
[ "account type of key"
, singleQuote $ unAcntID a
, "is not one of:"
, ts_
]
]
where
ts_ = T.intercalate ", " $ NE.toList $ fmap atName ts
(DatePatternError s b r p) -> [T.unwords [msg, "in pattern: ", pat]]
where
pat =
keyVals $
[ (k, v)
| (k, Just v) <-
[ ("start", Just $ tshow s)
, ("by", Just $ tshow b)
, ("repeats", tshow <$> 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 isDouble) ->
[ T.unwords
[ "Could not convert to"
, if isDouble then "double" else "rational"
, "number: "
, x
]
]
(StatementIOError msg) -> [T.append "IO Error: " msg]
(ParseError msg) -> [T.append "Parse Error: " msg]
(MatchValPrecisionError d p) ->
[T.unwords ["Match denominator", tshow d, "must be less than", tshow p]]
(LookupError t f) ->
[T.unwords ["Could not find field", f, "when resolving", what]]
where
what = case t of
EntryIDField st -> T.unwords ["entry", idName st, "ID"]
EntryValField -> "entry value"
MatchField mt -> T.unwords [matchName mt, "match"]
DBKey st -> T.unwords ["database", idName st, "ID key"]
-- TODO this should be its own function
idName AcntField = "account"
idName CurField = "currency"
idName TagField = "tag"
matchName MatchNumeric = "numeric"
matchName MatchText = "text"
(PeriodError start next) ->
[ T.unwords
[ "First pay period on "
, singleQuote $ tshow start
, "must start before first income payment on "
, singleQuote $ tshow next
]
]
(LinkError i m) ->
[ T.unwords
[ "entry index"
, singleQuote $ tshow i
, "out of range: max index is"
, singleQuote $ tshow m
]
]
(DBError d) -> case d of
DBShouldBeEmpty -> ["database has no rows in 'config_state' but has other data"]
DBMultiScope -> ["database has multiple rows in 'config_state'"]
DBUpdateUnbalanced -> ["update is missing debit or credit entries"]
DBLinkError k l ->
let k' = T.append "in entry key: " $ tshow $ E.fromSqlKey k
in case l of
DBLinkNoScale -> [T.append "no link scale" k']
DBLinkNoValue -> [T.append "no link value" k']
DBLinkInvalidValue v isfixed ->
[ T.unwords
[ if isfixed
then "fixed link should not have value"
else "untyped value is ambiguous"
, singleQuote $ tshow v
, k'
]
]
DBLinkInvalidBalance -> [T.append "no value given for balance link" k']
DBLinkInvalidPercent -> [T.append "no value given for percent link" k']
showGregorian_ :: Gregorian -> T.Text
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ tshow <$> [gYear, gMonth, gDay]
showTx :: TxRecord -> T.Text
showTx TxRecord {trDate = d, trAmount = v, trDesc = e, trFile = f} =
T.append "Unmatched transaction: " $
keyVals
[ ("path", T.pack f)
, ("date", T.pack $ iso8601Show d)
, ("value", tshow v)
, ("description", doubleQuote $ unTxDesc e)
]
showMatch :: MatchRe -> T.Text
showMatch StatementParser {spDate, spVal, spDesc, spOther, spTimes, spPriority} =
T.append "Unused match: " $ keyVals [(x, y) | (x, Just y) <- kvs]
where
kvs =
[ ("date", showDateMatcher <$> spDate)
, ("val", showValMatcher spVal)
, ("desc", fst <$> spDesc)
, ("other", others)
, ("counter", Just $ maybe "Inf" tshow spTimes)
, ("priority", Just $ tshow spPriority)
]
others = case spOther of
[] -> Nothing
xs -> Just $ singleQuote $ T.concat $ showMatchOther <$> xs
-- | Convert match date to text
-- Single date matches will just show the single date, and ranged matches will
-- show an interval like [YY-MM-DD, YY-MM-DD)
showDateMatcher :: DateMatcher -> T.Text
showDateMatcher md = case md of
(On x) -> showYMDMatcher x
(In start n) -> T.concat ["[", showYMDMatcher start, " ", showYMD_ end, ")"]
where
-- TODO not DRY (this shifting thing happens during the comparison
-- function (kinda)
end = case fromYMDMatcher start of
Y_ y -> Y_ $ y + fromIntegral n
YM_ y m ->
let (y_, m_) = divMod (m + fromIntegral n - 1) 12
in YM_ (y + fromIntegral y_) (m + m_ + 1)
YMD_ y m d ->
uncurry3 YMD_ $
toGregorian $
addDays (fromIntegral n) $
fromGregorian y m d
-- | convert YMD match to text
showYMDMatcher :: YMDMatcher -> T.Text
showYMDMatcher = showYMD_ . fromYMDMatcher
showYMD_ :: YMD_ -> T.Text
showYMD_ md =
T.intercalate "-" $ L.take 3 (fmap tshow digits ++ L.repeat "*")
where
digits = case md of
Y_ y -> [fromIntegral y]
YM_ y m -> [fromIntegral y, m]
YMD_ y m d -> [fromIntegral y, m, d]
showValMatcher :: ValMatcher -> Maybe T.Text
showValMatcher ValMatcher {vmSign = Nothing, vmNum = Nothing, vmDen = Nothing} = Nothing
showValMatcher ValMatcher {vmNum, vmDen, vmSign, vmPrec} =
Just $ singleQuote $ keyVals [(k, v) | (k, Just v) <- kvs]
where
kvs =
[ ("sign", (\s -> if s then "+" else "-") <$> vmSign)
, ("numerator", tshow <$> vmNum)
, ("denominator", tshow <$> vmDen)
, ("precision", Just $ tshow vmPrec)
]
showMatchOther :: FieldMatcherRe -> T.Text
showMatchOther (Desc (Field f (re, _))) =
T.unwords ["desc field", singleQuote f, "with re", singleQuote re]
showMatchOther (Val (Field f mv)) =
T.unwords
[ "val field"
, singleQuote f
, "with match value"
, singleQuote $ fromMaybe "*" $ showValMatcher mv
]
singleQuote :: T.Text -> T.Text
singleQuote t = T.concat ["'", t, "'"]
doubleQuote :: T.Text -> T.Text
doubleQuote t = T.concat ["'", t, "'"]
keyVal :: T.Text -> T.Text -> T.Text
keyVal a b = T.concat [a, "=", b]
keyVals :: [(T.Text, T.Text)] -> T.Text
keyVals = T.intercalate "; " . fmap (uncurry keyVal)
--------------------------------------------------------------------------------
-- random functions
groupKey :: Ord c => (a -> c) -> [(a, b)] -> [(a, NonEmpty b)]
groupKey f = fmap go . NE.groupAllWith (f . fst)
where
go xs@((c, _) :| _) = (c, fmap snd xs)
groupWith :: Ord b => (a -> b) -> [a] -> [(b, NonEmpty a)]
groupWith f = fmap go . NE.groupAllWith fst . fmap (\x -> (f x, x))
where
go xs@((c, _) :| _) = (c, fmap snd xs)
mapAdd_ :: (Ord k, Num v) => k -> v -> M.Map k v -> M.Map k v
mapAdd_ k v = M.alter (maybe (Just v) (Just . (+ v))) k
uncurry3 :: (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 f (a, b, c) = f a b c
lookupAccount :: (MonadAppError m, MonadFinance m) => AcntID -> m (AccountRId, AcntType)
lookupAccount = lookupFinance AcntField tsAccountMap
lookupAccountKey :: (MonadAppError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fst . lookupAccount
lookupAccountType :: (MonadAppError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap snd . lookupAccount
lookupCurrency :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyPrec
lookupCurrency = lookupFinance CurField tsCurrencyMap
lookupCurrencyKey :: (MonadAppError m, MonadFinance m) => CurID -> m CurrencyRId
lookupCurrencyKey = fmap cpID . lookupCurrency
lookupCurrencyPrec :: (MonadAppError m, MonadFinance m) => CurID -> m Precision
lookupCurrencyPrec = fmap cpPrec . lookupCurrency
lookupTag :: (MonadAppError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField tsTagMap
lookupFinance
:: (MonadAppError m, MonadFinance m, Ord k, Show k)
=> EntryIDType
-> (TxState -> M.Map k a)
-> k
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
balanceTxs
:: (MonadAppError m, MonadFinance m)
=> [EntryCRU]
-> m ([UEBalanced], [InsertTx])
balanceTxs ebs =
first concat . partitionEithers . catMaybes
<$> evalStateT (mapErrors go $ L.sortOn binDate ebs) M.empty
where
go (ToUpdate utx) =
fmap (Just . Left) $
liftInnerS $
either rebalanceTotalEntrySet rebalanceFullEntrySet utx
go (ToRead ReadEntry {reCurrency, reAcnt, reValue}) = do
modify $ mapAdd_ (reAcnt, reCurrency) reValue
return Nothing
go (ToInsert Tx {txPrimary, txOther, txMeta}) = do
e <- either balancePrimaryEntrySet balanceSecondaryEntrySet txPrimary
let tot = sum $ fmap (eValue . ieEntry) $ NE.toList $ iesFromEntries e
es <- mapErrors (goOther tot) txOther
let tx = InsertTx {itxMeta = txMeta, itxEntrySets = e :| es}
return $ Just $ Right tx
where
goOther tot =
either
balanceSecondaryEntrySet
(balancePrimaryEntrySet . fromShadow tot)
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
-- NOTE this sorting thing is super wonky; I'm basically sorting three different
-- levels of the hierarchy directory and assuming there will be no overlaps.
-- First, sort at the transaction level by day, priority, and description as
-- tiebreaker. Anything that shares those three keys will have an unstable sort
-- order. Within the entrysets, use the index as it appears in the
-- configuration, and same with the entries. Since we assume no overlap, nothing
-- "bad" should happen if the levels above entries/entrysets sort on 'Nothing'
-- for the indices they don't have at their level.
binDate :: EntryCRU -> (TxSortKey, Maybe EntrySetIndex, Maybe EntryIndex)
binDate (ToRead ReadEntry {reSortKey, reESIndex, reIndex}) = (reSortKey, Just reESIndex, Just reIndex)
binDate (ToInsert Tx {txMeta = (TxMeta t p d _)}) = (TxSortKey t p d, Nothing, Nothing)
binDate (ToUpdate u) = either go go u
where
go UpdateEntrySet {utSortKey, utIndex} = (utSortKey, Just utIndex, Nothing)
type BCKey = CurrencyRId
type ABCKey = (AccountRId, BCKey)
type EntryBals = M.Map ABCKey Decimal
--------------------------------------------------------------------------------
-- rebalancing
-- TODO make sure new values are rounded properly here
rebalanceTotalEntrySet :: TotalUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceTotalEntrySet
UpdateEntrySet
{ utFrom0 = (f0@UpdateEntry {ueAcnt = f0Acnt}, f0links)
, utTo0
, utFromUnk
, utToUnk
, utFromRO
, utToRO
, utCurrency
, utTotalValue
} =
do
(fval, fs, tpairs) <- rebalanceDebit bc utFromRO utFromUnk
let f0val = utTotalValue - fval
modify $ mapAdd_ (f0Acnt, bc) f0val
let tsLinked = tpairs ++ (unlink f0val <$> f0links)
ts <- rebalanceCredit bc utTotalValue utTo0 utToUnk utToRO tsLinked
return (f0 {ueValue = StaticValue f0val} : fs ++ ts)
where
bc = utCurrency
rebalanceFullEntrySet :: FullUpdateEntrySet -> State EntryBals [UEBalanced]
rebalanceFullEntrySet
UpdateEntrySet
{ utFrom0
, utTo0
, utFromUnk
, utToUnk
, utFromRO
, utToRO
, utCurrency
} =
do
(ftot, fs, tpairs) <- rebalanceDebit bc rs ls
ts <- rebalanceCredit bc ftot utTo0 utToUnk utToRO tpairs
return (fs ++ ts)
where
(rs, ls) = case utFrom0 of
Left x -> (x : utFromRO, utFromUnk)
Right x -> (utFromRO, x : utFromUnk)
bc = utCurrency
rebalanceDebit
:: BCKey
-> [UE_RO]
-> [(UEUnk, [UELink])]
-> State EntryBals (Decimal, [UEBalanced], [UEBalanced])
rebalanceDebit k ro linked = do
(tot, (tpairs, fs)) <-
fmap (second (partitionEithers . concat)) $
sumM goFrom $
L.sortOn idx $
(Left <$> ro) ++ (Right <$> linked)
return (tot, fs, tpairs)
where
idx = either ueIndex (ueIndex . fst)
goFrom (Left e) = (,[]) <$> updateFixed k e
goFrom (Right (e0, es)) = do
v <- updateUnknown k e0
let e0' = Right $ e0 {ueValue = StaticValue v}
let es' = Left . unlink v <$> es
return (v, e0' : es')
unlink :: Decimal -> UELink -> UEBalanced
unlink v e = e {ueValue = StaticValue $ (-v) *. unLinkScale (ueValue e)}
rebalanceCredit
:: BCKey
-> Decimal
-> UEBlank
-> [UEUnk]
-> [UE_RO]
-> [UEBalanced]
-> State EntryBals [UEBalanced]
rebalanceCredit k tot t0 us rs bs = do
(tval, ts) <-
fmap (second catMaybes) $
sumM goTo $
L.sortOn idx $
(UETLinked <$> bs)
++ (UETUnk <$> us)
++ (UETReadOnly <$> rs)
return (t0 {ueValue = StaticValue (-(tot + tval))} : ts)
where
idx = projectUET ueIndex ueIndex ueIndex
goTo (UETReadOnly e) = (,Nothing) <$> updateFixed k e
goTo (UETLinked e) = (,Just e) <$> updateFixed k e
goTo (UETUnk e) = do
v <- updateUnknown k e
return (v, Just $ e {ueValue = StaticValue v})
data UpdateEntryType a b
= UETReadOnly UE_RO
| UETUnk a
| UETLinked b
projectUET :: (UE_RO -> c) -> (a -> c) -> (b -> c) -> UpdateEntryType a b -> c
projectUET f _ _ (UETReadOnly e) = f e
projectUET _ f _ (UETUnk e) = f e
projectUET _ _ f (UETLinked p) = f p
updateFixed :: BCKey -> UpdateEntry i StaticValue -> State EntryBals Decimal
updateFixed k e = do
let v = unStaticValue $ ueValue e
modify $ mapAdd_ (ueAcnt e, k) v
return v
updateUnknown :: BCKey -> UpdateEntry i EntryValueUnk -> State EntryBals Decimal
updateUnknown k e = do
let key = (ueAcnt e, k)
curBal <- gets (M.findWithDefault 0 key)
let v = case ueValue e of
EVPercent p -> curBal *. p
EVBalance p -> p - curBal
modify $ mapAdd_ key v
return v
--------------------------------------------------------------------------------
-- balancing
balancePrimaryEntrySet
:: (MonadAppError m, MonadFinance m)
=> PrimaryEntrySet
-> StateT EntryBals m InsertEntrySet
balancePrimaryEntrySet
EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
, esCurrency
, esTotalValue
} =
do
let f0res = resolveAcntAndTags f0
let t0res = resolveAcntAndTags t0
let fsres = mapErrors resolveAcntAndTags fs
let tsres = mapErrors resolveAcntAndTags ts
let bc = esCurrency
combineErrorM (combineError f0res fsres (,)) (combineError t0res tsres (,)) $
\(f0', fs') (t0', ts') -> do
let balFrom = fmap liftInnerS . balanceDeferred
fs'' <- balanceTotalEntrySet balFrom bc esTotalValue f0' fs'
balanceFinal bc (-esTotalValue) fs'' t0' ts'
balanceSecondaryEntrySet
:: (MonadAppError m, MonadFinance m)
=> SecondayEntrySet
-> StateT EntryBals m InsertEntrySet
balanceSecondaryEntrySet
EntrySet
{ esFrom = HalfEntrySet {hesPrimary = f0, hesOther = fs}
, esTo = HalfEntrySet {hesPrimary = t0, hesOther = ts}
, esCurrency
} =
do
let fsRes = mapErrors resolveAcntAndTags (f0 :| fs)
let t0Res = resolveAcntAndTags t0
let tsRes = mapErrors resolveAcntAndTags ts
combineErrorM fsRes (combineError t0Res tsRes (,)) $ \fs' (t0', ts') -> do
fs'' <- mapErrors balFrom fs'
let tot = entrySum (NE.toList fs'')
balanceFinal bc (-tot) fs'' t0' ts'
where
entrySum = sum . fmap (eValue . ieEntry)
balFrom = balanceEntry (fmap liftInnerS . balanceDeferred) bc
bc = esCurrency
balanceFinal
:: (MonadAppError m)
=> BCKey
-> Decimal
-> NonEmpty InsertEntry
-> Entry AccountRId () TagRId
-> [Entry AccountRId EntryLink TagRId]
-> StateT EntryBals m InsertEntrySet
balanceFinal curID tot fs t0 ts = do
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
let balTo = balanceLinked fv
ts' <- balanceTotalEntrySet balTo curID tot t0 ts
return $
InsertEntrySet
{ iesCurrency = curID
, iesFromEntries = fs
, iesToEntries = ts'
}
balanceTotalEntrySet
:: (MonadAppError m)
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
-> BCKey
-> Decimal
-> Entry AccountRId () TagRId
-> [Entry AccountRId v TagRId]
-> StateT EntryBals m (NonEmpty InsertEntry)
balanceTotalEntrySet f k tot e@Entry {eAcnt = acntID} es = do
es' <- mapErrors (balanceEntry f k) es
let e0val = tot - entrySum es'
-- TODO not dry
modify (mapAdd_ (acntID, k) e0val)
let e' =
InsertEntry
{ ieEntry = e {eValue = e0val, eAcnt = acntID}
, ieCached = Nothing
}
return $ e' :| es'
where
entrySum = sum . fmap (eValue . ieEntry)
liftInnerS :: Monad m => StateT e Identity a -> StateT e m a
liftInnerS = mapStateT (return . runIdentity)
balanceLinked
:: MonadAppError m
=> Vector Decimal
-> ABCKey
-> EntryLink
-> StateT EntryBals m (Decimal, Maybe CachedEntry)
balanceLinked from k lg = case lg of
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
let i = fromIntegral lngIndex
upper = EntryIndex $ V.length from
res = fmap (go lngScale) $ from V.!? i
case res of
Just v -> return (v, Just $ CachedLink (EntryIndex $ fromIntegral lngIndex) (LinkScale lngScale))
Nothing -> throwAppError $ LinkError (EntryIndex i) upper
(LinkValue d) -> liftInnerS $ balanceDeferred k d
where
go s = negate . (*. s)
balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe CachedEntry)
balanceDeferred k e = do
newval <- findBalance k e
let d = case e of
EntryFixed _ -> Nothing
EntryBalance v -> Just $ CachedBalance v
EntryPercent v -> Just $ CachedPercent v
return (newval, d)
balanceEntry
:: (MonadAppError m)
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
-> BCKey
-> Entry AccountRId v TagRId
-> StateT EntryBals m InsertEntry
balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
(newVal, cached) <- f (acntID, k) eValue
modify (mapAdd_ (acntID, k) newVal)
return $
InsertEntry
{ ieEntry = e {eValue = newVal, eAcnt = acntID}
, ieCached = cached
}
resolveAcntAndTags
:: (MonadAppError m, MonadFinance m)
=> Entry AcntID v TagID
-> m (Entry AccountRId v TagRId)
resolveAcntAndTags e@Entry {eAcnt, eTags} = do
let acntRes = lookupAccountKey eAcnt
let tagRes = mapErrors lookupTag eTags
combineError acntRes tagRes $ \a ts -> e {eAcnt = a, eTags = ts}
findBalance :: ABCKey -> EntryValue -> State EntryBals Decimal
findBalance k e = do
curBal <- gets (M.findWithDefault 0 k)
return $ case e of
EntryBalance b -> b - curBal
EntryPercent p -> curBal *. p
EntryFixed v -> v
--------------------------------------------------------------------------------
-- transfers
expandTransfers
:: (MonadAppError m, MonadFinance m)
=> CommitR
-> DaySpan
-> [PairedTransfer]
-> m [Tx CommitR]
expandTransfers tc bounds = fmap concat . mapErrors (expandTransfer tc bounds)
expandTransfer
:: (MonadAppError m, MonadFinance m)
=> CommitR
-> DaySpan
-> PairedTransfer
-> m [Tx CommitR]
expandTransfer tc bounds Transfer {transAmounts, transTo, transCurrency, transFrom} = do
txs <- mapErrors go transAmounts
return $ concat txs
where
go
Amount
{ amtWhen = pat
, amtValue = TransferValue {tvVal = v, tvType = t}
, amtDesc = desc
, amtPriority = pri
} = do
cp <- lookupCurrency transCurrency
let v' = (-v)
let dec = realFracToDecimalP (cpPrec cp) v'
let v'' = case t of
TFixed -> EntryFixed dec
TPercent -> EntryPercent v'
TBalance -> EntryBalance dec
withDates bounds pat $ \day ->
return
Tx
{ txMeta = TxMeta day (fromIntegral pri) (TxDesc desc) tc
, txPrimary = Right $ entryPair transFrom transTo (cpID cp) desc () v''
, txOther = []
}
entryPair
:: TaggedAcnt
-> TaggedAcnt
-> CurrencyRId
-> T.Text
-> v0
-> v1
-> EntrySet v0 v1 v2 v3
entryPair (TaggedAcnt fa fts) (TaggedAcnt ta tts) curid com totval val1 =
EntrySet
{ esCurrency = curid
, esTotalValue = totval
, esFrom = halfEntry (AcntID fa) (TagID <$> fts) val1
, esTo = halfEntry (AcntID ta) (TagID <$> tts) ()
}
where
halfEntry :: AcntID -> [TagID] -> v -> HalfEntrySet v v0
halfEntry a ts v =
HalfEntrySet
{ hesPrimary = Entry {eAcnt = a, eValue = v, eComment = com, eTags = ts}
, hesOther = []
}
withDates
:: (MonadFinance m, MonadAppError m)
=> DaySpan
-> DatePat
-> (Day -> m a)
-> m [a]
withDates bounds dp f = do
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
sumM :: (Monad m, Num s) => (a -> m (s, b)) -> [a] -> m (s, [b])
sumM f = mapAccumM (\s -> fmap (first (+ s)) . f) 0
mapAccumM :: (Monad m) => (s -> a -> m (s, b)) -> s -> [a] -> m (s, [b])
mapAccumM f s = foldM (\(s', ys) -> fmap (second (: ys)) . f s') (s, [])
realFracToDecimalP :: (Integral i, RealFrac r) => Precision -> r -> DecimalRaw i
realFracToDecimalP p = realFracToDecimal (unPrecision p)
roundToP :: Integral i => Precision -> DecimalRaw i -> DecimalRaw i
roundToP p = roundTo (unPrecision p)
Reference in New Issue View Git Blame Copy Permalink