REF clean up useless types
This commit is contained in:
parent
ad5e4a0748
commit
cafc066881
14
app/Main.hs
14
app/Main.hs
|
@ -231,11 +231,11 @@ runSync threads c bs hs = do
|
||||||
-- the database, don't read it but record the commit so we can update it.
|
-- the database, don't read it but record the commit so we can update it.
|
||||||
toIns <-
|
toIns <-
|
||||||
flip runReaderT state $ do
|
flip runReaderT state $ do
|
||||||
(CRUDOps hSs _ _ _) <- askDBState csHistStmts
|
(CRUDOps hSs _ _ _) <- asks csHistStmts
|
||||||
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
hSs' <- mapErrorsIO (readHistStmt root) hSs
|
||||||
(CRUDOps hTs _ _ _) <- askDBState csHistTrans
|
(CRUDOps hTs _ _ _) <- asks csHistTrans
|
||||||
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
|
hTs' <- liftIOExceptT $ mapErrors readHistTransfer hTs
|
||||||
(CRUDOps bTs _ _ _) <- askDBState csBudgets
|
(CRUDOps bTs _ _ _) <- asks csBudgets
|
||||||
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
|
bTs' <- liftIOExceptT $ mapErrors readBudget bTs
|
||||||
return $ concat $ hSs' ++ hTs' ++ bTs'
|
return $ concat $ hSs' ++ hTs' ++ bTs'
|
||||||
|
|
||||||
|
@ -244,9 +244,9 @@ runSync threads c bs hs = do
|
||||||
-- NOTE this must come first (unless we defer foreign keys)
|
-- NOTE this must come first (unless we defer foreign keys)
|
||||||
updateDBState
|
updateDBState
|
||||||
res <- runExceptT $ do
|
res <- runExceptT $ do
|
||||||
(CRUDOps _ bRs bUs _) <- askDBState csBudgets
|
(CRUDOps _ bRs bUs _) <- asks csBudgets
|
||||||
(CRUDOps _ tRs tUs _) <- askDBState csHistTrans
|
(CRUDOps _ tRs tUs _) <- asks csHistTrans
|
||||||
(CRUDOps _ sRs sUs _) <- askDBState csHistStmts
|
(CRUDOps _ sRs sUs _) <- asks csHistStmts
|
||||||
let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
|
let ebs = fmap ToUpdate (bUs ++ tUs ++ sUs) ++ fmap ToRead (bRs ++ tRs ++ sRs) ++ fmap ToInsert toIns
|
||||||
insertAll ebs
|
insertAll ebs
|
||||||
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
|
-- NOTE this rerunnable thing is a bit misleading; fromEither will throw
|
||||||
|
@ -259,8 +259,6 @@ runSync threads c bs hs = do
|
||||||
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
|
||||||
exitFailure
|
exitFailure
|
||||||
|
|
||||||
-- showBalances
|
|
||||||
|
|
||||||
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
readConfig :: MonadUnliftIO m => FilePath -> m Config
|
||||||
readConfig = fmap unfix . readDhall
|
readConfig = fmap unfix . readDhall
|
||||||
|
|
||||||
|
|
|
@ -49,7 +49,7 @@ readBudget
|
||||||
++ (alloAcnt <$> bgtTax)
|
++ (alloAcnt <$> bgtTax)
|
||||||
++ (alloAcnt <$> bgtPosttax)
|
++ (alloAcnt <$> bgtPosttax)
|
||||||
getSpan = do
|
getSpan = do
|
||||||
globalSpan <- askDBState (unBSpan . csBudgetScope)
|
globalSpan <- asks (unBSpan . csBudgetScope)
|
||||||
case bgtInterval of
|
case bgtInterval of
|
||||||
Nothing -> return $ Just globalSpan
|
Nothing -> return $ Just globalSpan
|
||||||
Just bi -> do
|
Just bi -> do
|
||||||
|
@ -253,20 +253,22 @@ selectAllos day Allocation {alloAmts, alloTo} =
|
||||||
, faDesc = amtDesc
|
, faDesc = amtDesc
|
||||||
}
|
}
|
||||||
|
|
||||||
allo2Trans :: FlatAllocation Decimal -> Entry AcntID LinkDeferred TagID
|
allo2Trans :: FlatAllocation Decimal -> Entry AcntID EntryLink TagID
|
||||||
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
|
allo2Trans FlatAllocation {faValue, faTo = TaggedAcnt {taAcnt, taTags}, faDesc} =
|
||||||
Entry
|
Entry
|
||||||
{ eValue = LinkDeferred (EntryFixed faValue)
|
{ eValue = LinkValue (EntryFixed faValue)
|
||||||
, eComment = faDesc
|
, eComment = faDesc
|
||||||
, eAcnt = AcntID taAcnt
|
, eAcnt = AcntID taAcnt
|
||||||
, eTags = TagID <$> taTags
|
, eTags = TagID <$> taTags
|
||||||
}
|
}
|
||||||
|
|
||||||
|
type PreDeductions = M.Map T.Text Decimal
|
||||||
|
|
||||||
allocatePre
|
allocatePre
|
||||||
:: Precision
|
:: Precision
|
||||||
-> Decimal
|
-> Decimal
|
||||||
-> [FlatAllocation PretaxValue]
|
-> [FlatAllocation PretaxValue]
|
||||||
-> (M.Map T.Text Decimal, [FlatAllocation Decimal])
|
-> (PreDeductions, [FlatAllocation Decimal])
|
||||||
allocatePre precision gross = L.mapAccumR go M.empty
|
allocatePre precision gross = L.mapAccumR go M.empty
|
||||||
where
|
where
|
||||||
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
|
go m f@FlatAllocation {faValue = PretaxValue {preCategory, preValue, prePercent}} =
|
||||||
|
@ -279,7 +281,7 @@ allocatePre precision gross = L.mapAccumR go M.empty
|
||||||
allocateTax
|
allocateTax
|
||||||
:: Precision
|
:: Precision
|
||||||
-> Decimal
|
-> Decimal
|
||||||
-> M.Map T.Text Decimal
|
-> PreDeductions
|
||||||
-> PeriodScaler
|
-> PeriodScaler
|
||||||
-> [FlatAllocation TaxValue]
|
-> [FlatAllocation TaxValue]
|
||||||
-> [FlatAllocation Decimal]
|
-> [FlatAllocation Decimal]
|
||||||
|
|
|
@ -674,7 +674,7 @@ makeUnkUE k e = makeUE k e ()
|
||||||
|
|
||||||
insertAll
|
insertAll
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
=> [EntryBin]
|
=> [EntryCRU]
|
||||||
-> m ()
|
-> m ()
|
||||||
insertAll ebs = do
|
insertAll ebs = do
|
||||||
(toUpdate, toInsert) <- balanceTxs ebs
|
(toUpdate, toInsert) <- balanceTxs ebs
|
||||||
|
@ -692,7 +692,7 @@ insertTx c InsertTx {itxDate, itxDescr, itxEntrySets, itxBudget, itxPriority} =
|
||||||
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
|
insertEntrySet tk i InsertEntrySet {iesCurrency, iesFromEntries, iesToEntries} = do
|
||||||
let fs = NE.toList iesFromEntries
|
let fs = NE.toList iesFromEntries
|
||||||
let ts = NE.toList iesToEntries
|
let ts = NE.toList iesToEntries
|
||||||
let rebalance = any (isJust . ieDeferred) (fs ++ ts)
|
let rebalance = any (isJust . ieCached) (fs ++ ts)
|
||||||
esk <- insert $ EntrySetR tk iesCurrency i rebalance
|
esk <- insert $ EntrySetR tk iesCurrency i rebalance
|
||||||
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
|
mapM_ (uncurry (go esk)) $ zip [0 ..] ts ++ zip (negate <$> [1 ..]) fs
|
||||||
go k i e = void $ insertEntry k i e
|
go k i e = void $ insertEntry k i e
|
||||||
|
@ -703,17 +703,17 @@ insertEntry
|
||||||
i
|
i
|
||||||
InsertEntry
|
InsertEntry
|
||||||
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
|
{ ieEntry = Entry {eValue, eTags, eAcnt, eComment}
|
||||||
, ieDeferred
|
, ieCached
|
||||||
} =
|
} =
|
||||||
do
|
do
|
||||||
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
|
ek <- insert $ EntryR k eAcnt eComment (toRational eValue) i cval ctype deflink
|
||||||
mapM_ (insert_ . TagRelationR ek) eTags
|
mapM_ (insert_ . TagRelationR ek) eTags
|
||||||
return ek
|
return ek
|
||||||
where
|
where
|
||||||
(cval, ctype, deflink) = case ieDeferred of
|
(cval, ctype, deflink) = case ieCached of
|
||||||
(Just (DBEntryLinked x s)) -> (Just (toRational s), Nothing, Just $ fromIntegral x)
|
(Just (CachedLink x s)) -> (Just (toRational s), Nothing, Just x)
|
||||||
(Just (DBEntryBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
|
(Just (CachedBalance b)) -> (Just (toRational b), Just TBalance, Nothing)
|
||||||
(Just (DBEntryPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
|
(Just (CachedPercent p)) -> (Just (toRational p), Just TPercent, Nothing)
|
||||||
Nothing -> (Nothing, Just TFixed, Nothing)
|
Nothing -> (Nothing, Just TFixed, Nothing)
|
||||||
|
|
||||||
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
updateTx :: MonadSqlQuery m => UEBalanced -> m ()
|
||||||
|
|
|
@ -41,7 +41,7 @@ readHistTransfer
|
||||||
=> PairedTransfer
|
=> PairedTransfer
|
||||||
-> m [Tx CommitR]
|
-> m [Tx CommitR]
|
||||||
readHistTransfer ht = do
|
readHistTransfer ht = do
|
||||||
bounds <- askDBState (unHSpan . csHistoryScope)
|
bounds <- asks (unHSpan . csHistoryScope)
|
||||||
expandTransfer c historyName bounds ht
|
expandTransfer c historyName bounds ht
|
||||||
where
|
where
|
||||||
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
c = CommitR (CommitHash $ hash ht) CTHistoryTransfer
|
||||||
|
@ -56,7 +56,7 @@ readHistStmt
|
||||||
-> m [Tx CommitR]
|
-> m [Tx CommitR]
|
||||||
readHistStmt root i = do
|
readHistStmt root i = do
|
||||||
bs <- readImport root i
|
bs <- readImport root i
|
||||||
bounds <- askDBState (unHSpan . csHistoryScope)
|
bounds <- asks (unHSpan . csHistoryScope)
|
||||||
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
return $ filter (inDaySpan bounds . txDate) $ fmap (\t -> t {txCommit = c}) bs
|
||||||
where
|
where
|
||||||
c = CommitR (CommitHash $ hash i) CTHistoryStatement
|
c = CommitR (CommitHash $ hash i) CTHistoryStatement
|
||||||
|
@ -317,7 +317,7 @@ toTx
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
curRes = do
|
curRes = do
|
||||||
m <- askDBState csCurrencyMap
|
m <- asks csCurrencyMap
|
||||||
cur <- liftInner $ resolveCurrency m r tgCurrency
|
cur <- liftInner $ resolveCurrency m r tgCurrency
|
||||||
let prec = cpPrec cur
|
let prec = cpPrec cur
|
||||||
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
|
let fromRes = liftInner $ resolveHalfEntry resolveFromValue prec r () tgFrom
|
||||||
|
@ -331,7 +331,7 @@ resolveSubGetter
|
||||||
-> TxSubGetter
|
-> TxSubGetter
|
||||||
-> InsertExceptT m SecondayEntrySet
|
-> InsertExceptT m SecondayEntrySet
|
||||||
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
resolveSubGetter r TxSubGetter {tsgFrom, tsgTo, tsgValue, tsgCurrency} = do
|
||||||
m <- askDBState csCurrencyMap
|
m <- asks csCurrencyMap
|
||||||
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
cur <- liftInner $ resolveCurrency m r tsgCurrency
|
||||||
let prec = cpPrec cur
|
let prec = cpPrec cur
|
||||||
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
|
let toRes = resolveHalfEntry resolveToValue prec r () tsgTo
|
||||||
|
@ -391,9 +391,9 @@ resolveEntry f prec r s@Entry {eAcnt, eValue} =
|
||||||
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
|
resolveFromValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
|
||||||
resolveFromValue = resolveValue
|
resolveFromValue = resolveValue
|
||||||
|
|
||||||
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept LinkDeferred
|
resolveToValue :: Precision -> TxRecord -> LinkedEntryNumGetter -> InsertExcept EntryLink
|
||||||
resolveToValue _ _ (Linked l) = return $ LinkIndex l
|
resolveToValue _ _ (Linked l) = return $ LinkIndex l
|
||||||
resolveToValue prec r (Getter g) = LinkDeferred <$> resolveValue prec r g
|
resolveToValue prec r (Getter g) = LinkValue <$> resolveValue prec r g
|
||||||
|
|
||||||
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
|
resolveValue :: Precision -> TxRecord -> EntryNumGetter -> InsertExcept EntryValue
|
||||||
resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
resolveValue prec TxRecord {trOther, trAmount} s = case s of
|
||||||
|
|
|
@ -75,10 +75,10 @@ data CRUDOps c r u d = CRUDOps
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data DBDeferred
|
data CachedEntry
|
||||||
= DBEntryLinked Natural Double
|
= CachedLink EntryIndex LinkScale
|
||||||
| DBEntryBalance Decimal
|
| CachedBalance Decimal
|
||||||
| DBEntryPercent Double
|
| CachedPercent Double
|
||||||
|
|
||||||
data ReadEntry = ReadEntry
|
data ReadEntry = ReadEntry
|
||||||
{ reCurrency :: !CurrencyRId
|
{ reCurrency :: !CurrencyRId
|
||||||
|
@ -98,12 +98,10 @@ data UpdateEntry i v = UpdateEntry
|
||||||
}
|
}
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data CurrencyRound = CurrencyRound CurID Natural
|
|
||||||
|
|
||||||
deriving instance Functor (UpdateEntry i)
|
deriving instance Functor (UpdateEntry i)
|
||||||
|
|
||||||
newtype LinkScale = LinkScale {unLinkScale :: Decimal}
|
newtype LinkScale = LinkScale {unLinkScale :: Double}
|
||||||
deriving newtype (Num, Show)
|
deriving newtype (Num, Show, Eq, Ord, Real, Fractional)
|
||||||
|
|
||||||
newtype StaticValue = StaticValue {unStaticValue :: Decimal}
|
newtype StaticValue = StaticValue {unStaticValue :: Decimal}
|
||||||
deriving newtype (Num, Show)
|
deriving newtype (Num, Show)
|
||||||
|
@ -139,18 +137,13 @@ type TotalUpdateEntrySet = UpdateEntrySet (UEBlank, [UELink]) Decimal
|
||||||
|
|
||||||
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
|
type FullUpdateEntrySet = UpdateEntrySet (Either UE_RO (UEUnk, [UELink])) ()
|
||||||
|
|
||||||
data EntryBin
|
data EntryCRU
|
||||||
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
|
= ToUpdate (Either TotalUpdateEntrySet FullUpdateEntrySet)
|
||||||
| ToRead ReadEntry
|
| ToRead ReadEntry
|
||||||
| ToInsert (Tx CommitR)
|
| ToInsert (Tx CommitR)
|
||||||
|
|
||||||
type TreeR = Tree ([T.Text], AccountRId)
|
|
||||||
|
|
||||||
type MonadFinance = MonadReader ConfigState
|
type MonadFinance = MonadReader ConfigState
|
||||||
|
|
||||||
askDBState :: MonadFinance m => (ConfigState -> a) -> m a
|
|
||||||
askDBState = asks
|
|
||||||
|
|
||||||
-------------------------------------------------------------------------------
|
-------------------------------------------------------------------------------
|
||||||
-- misc
|
-- misc
|
||||||
|
|
||||||
|
@ -190,13 +183,13 @@ type TotalEntrySet v0 vpN vtN = EntrySet v0 () vpN vtN
|
||||||
|
|
||||||
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
|
type FullEntrySet vp0 vpN vtN = EntrySet () vp0 vpN vtN
|
||||||
|
|
||||||
type PrimaryEntrySet = TotalEntrySet Decimal EntryValue LinkDeferred
|
type PrimaryEntrySet = TotalEntrySet Decimal EntryValue EntryLink
|
||||||
|
|
||||||
type SecondayEntrySet = FullEntrySet EntryValue EntryValue LinkDeferred
|
type SecondayEntrySet = FullEntrySet EntryValue EntryValue EntryLink
|
||||||
|
|
||||||
type TransferEntrySet = SecondayEntrySet
|
type TransferEntrySet = SecondayEntrySet
|
||||||
|
|
||||||
type ShadowEntrySet = TotalEntrySet Double EntryValue LinkDeferred
|
type ShadowEntrySet = TotalEntrySet Double EntryValue EntryLink
|
||||||
|
|
||||||
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
|
data TxCommit = HistoryCommit CommitR | BudgetCommit CommitR T.Text
|
||||||
deriving (Eq, Ord, Show)
|
deriving (Eq, Ord, Show)
|
||||||
|
@ -213,7 +206,7 @@ data Tx k = Tx
|
||||||
deriving (Generic, Show)
|
deriving (Generic, Show)
|
||||||
|
|
||||||
data InsertEntry = InsertEntry
|
data InsertEntry = InsertEntry
|
||||||
{ ieDeferred :: !(Maybe DBDeferred)
|
{ ieCached :: !(Maybe CachedEntry)
|
||||||
, ieEntry :: !(Entry AccountRId Decimal TagRId)
|
, ieEntry :: !(Entry AccountRId Decimal TagRId)
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -233,18 +226,13 @@ data InsertTx = InsertTx
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
data Deferred a = Deferred Bool a
|
|
||||||
deriving (Show, Functor, Foldable, Traversable)
|
|
||||||
|
|
||||||
data EntryValue_ a = EntryValue_ TransferType a
|
data EntryValue_ a = EntryValue_ TransferType a
|
||||||
deriving (Show, Functor, Foldable, Traversable)
|
deriving (Show, Functor, Foldable, Traversable)
|
||||||
|
|
||||||
data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
|
data EntryValue = EntryFixed Decimal | EntryPercent Double | EntryBalance Decimal
|
||||||
deriving (Show, Eq, Ord)
|
deriving (Show, Eq, Ord)
|
||||||
|
|
||||||
data LinkDeferred
|
data EntryLink = LinkValue EntryValue | LinkIndex LinkedNumGetter
|
||||||
= LinkDeferred EntryValue
|
|
||||||
| LinkIndex LinkedNumGetter
|
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||||
|
@ -302,13 +290,6 @@ type InsertExceptT = ExceptT InsertException
|
||||||
|
|
||||||
type InsertExcept = InsertExceptT Identity
|
type InsertExcept = InsertExceptT Identity
|
||||||
|
|
||||||
data XGregorian = XGregorian
|
|
||||||
{ xgYear :: !Int
|
|
||||||
, xgMonth :: !Int
|
|
||||||
, xgDay :: !Int
|
|
||||||
, xgDayOfWeek :: !Int
|
|
||||||
}
|
|
||||||
|
|
||||||
type MatchRe = StatementParser (T.Text, Regex)
|
type MatchRe = StatementParser (T.Text, Regex)
|
||||||
|
|
||||||
type TxOptsRe = TxOpts (T.Text, Regex)
|
type TxOptsRe = TxOpts (T.Text, Regex)
|
||||||
|
|
|
@ -30,9 +30,7 @@ module Internal.Utils
|
||||||
, showError
|
, showError
|
||||||
, tshow
|
, tshow
|
||||||
, lookupErr
|
, lookupErr
|
||||||
, gregorians
|
|
||||||
, uncurry3
|
, uncurry3
|
||||||
, xGregToDay
|
|
||||||
, dateMatches
|
, dateMatches
|
||||||
, valMatches
|
, valMatches
|
||||||
, lookupAccount
|
, lookupAccount
|
||||||
|
@ -152,7 +150,7 @@ askDays
|
||||||
-> Maybe Interval
|
-> Maybe Interval
|
||||||
-> m [Day]
|
-> m [Day]
|
||||||
askDays dp i = do
|
askDays dp i = do
|
||||||
globalSpan <- askDBState (unBSpan . csBudgetScope)
|
globalSpan <- asks (unBSpan . csBudgetScope)
|
||||||
case i of
|
case i of
|
||||||
Just i' -> do
|
Just i' -> do
|
||||||
localSpan <- liftExcept $ resolveDaySpan i'
|
localSpan <- liftExcept $ resolveDaySpan i'
|
||||||
|
@ -174,33 +172,6 @@ fromWeekday Fri = Friday
|
||||||
fromWeekday Sat = Saturday
|
fromWeekday Sat = Saturday
|
||||||
fromWeekday Sun = Sunday
|
fromWeekday Sun = Sunday
|
||||||
|
|
||||||
-- | find the next date
|
|
||||||
-- this is meant to go in a very tight loop and be very fast (hence no
|
|
||||||
-- complex date functions, most of which heavily use 'mod' and friends)
|
|
||||||
nextXGreg :: XGregorian -> XGregorian
|
|
||||||
nextXGreg 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
|
|
||||||
|
|
||||||
gregorians :: Day -> [XGregorian]
|
|
||||||
gregorians x = L.iterate nextXGreg $ XGregorian (fromIntegral y) m d w
|
|
||||||
where
|
|
||||||
(y, m, d) = toGregorian x
|
|
||||||
w = fromEnum $ dayOfWeek x
|
|
||||||
|
|
||||||
xGregToDay :: XGregorian -> Day
|
|
||||||
xGregToDay XGregorian {xgYear = y, xgMonth = m, xgDay = d} = fromGregorian (fromIntegral y) m d
|
|
||||||
|
|
||||||
gregTup :: Gregorian -> (Integer, Int, Int)
|
gregTup :: Gregorian -> (Integer, Int, Int)
|
||||||
gregTup Gregorian {gYear, gMonth, gDay} =
|
gregTup Gregorian {gYear, gMonth, gDay} =
|
||||||
( fromIntegral gYear
|
( fromIntegral gYear
|
||||||
|
@ -645,11 +616,11 @@ lookupFinance
|
||||||
-> (ConfigState -> M.Map k a)
|
-> (ConfigState -> M.Map k a)
|
||||||
-> k
|
-> k
|
||||||
-> m a
|
-> m a
|
||||||
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
|
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< asks f
|
||||||
|
|
||||||
balanceTxs
|
balanceTxs
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> [EntryBin]
|
=> [EntryCRU]
|
||||||
-> m ([UEBalanced], [InsertTx])
|
-> m ([UEBalanced], [InsertTx])
|
||||||
balanceTxs ebs =
|
balanceTxs ebs =
|
||||||
first concat . partitionEithers . catMaybes
|
first concat . partitionEithers . catMaybes
|
||||||
|
@ -684,7 +655,7 @@ balanceTxs ebs =
|
||||||
(balancePrimaryEntrySet txBudget . fromShadow tot)
|
(balancePrimaryEntrySet txBudget . fromShadow tot)
|
||||||
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
|
fromShadow tot e@EntrySet {esTotalValue} = e {esTotalValue = tot *. esTotalValue}
|
||||||
|
|
||||||
binDate :: EntryBin -> (Day, Int)
|
binDate :: EntryCRU -> (Day, Int)
|
||||||
binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
|
binDate (ToRead ReadEntry {reDate, rePriority}) = (reDate, rePriority)
|
||||||
binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
|
binDate (ToInsert Tx {txDate, txPriority}) = (txDate, txPriority)
|
||||||
binDate (ToUpdate u) = either go go u
|
binDate (ToUpdate u) = either go go u
|
||||||
|
@ -768,7 +739,7 @@ rebalanceDebit k ro linked = do
|
||||||
return (v, e0' : es')
|
return (v, e0' : es')
|
||||||
|
|
||||||
unlink :: Decimal -> UELink -> UEBalanced
|
unlink :: Decimal -> UELink -> UEBalanced
|
||||||
unlink v e = e {ueValue = StaticValue $ (-v) * unLinkScale (ueValue e)}
|
unlink v e = e {ueValue = StaticValue $ (-v) *. unLinkScale (ueValue e)}
|
||||||
|
|
||||||
rebalanceCredit
|
rebalanceCredit
|
||||||
:: BCKey
|
:: BCKey
|
||||||
|
@ -880,7 +851,7 @@ balanceFinal
|
||||||
-> Decimal
|
-> Decimal
|
||||||
-> NonEmpty InsertEntry
|
-> NonEmpty InsertEntry
|
||||||
-> Entry AccountRId () TagRId
|
-> Entry AccountRId () TagRId
|
||||||
-> [Entry AccountRId LinkDeferred TagRId]
|
-> [Entry AccountRId EntryLink TagRId]
|
||||||
-> StateT EntryBals m InsertEntrySet
|
-> StateT EntryBals m InsertEntrySet
|
||||||
balanceFinal k@(curID, _) tot fs t0 ts = do
|
balanceFinal k@(curID, _) tot fs t0 ts = do
|
||||||
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
|
let fv = V.fromList $ NE.toList $ fmap (eValue . ieEntry) fs
|
||||||
|
@ -895,7 +866,7 @@ balanceFinal k@(curID, _) tot fs t0 ts = do
|
||||||
|
|
||||||
balanceTotalEntrySet
|
balanceTotalEntrySet
|
||||||
:: (MonadInsertError m)
|
:: (MonadInsertError m)
|
||||||
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
|
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
|
||||||
-> BCKey
|
-> BCKey
|
||||||
-> Decimal
|
-> Decimal
|
||||||
-> Entry AccountRId () TagRId
|
-> Entry AccountRId () TagRId
|
||||||
|
@ -909,7 +880,7 @@ balanceTotalEntrySet f k tot e@Entry {eAcnt = acntID} es = do
|
||||||
let e' =
|
let e' =
|
||||||
InsertEntry
|
InsertEntry
|
||||||
{ ieEntry = e {eValue = e0val, eAcnt = acntID}
|
{ ieEntry = e {eValue = e0val, eAcnt = acntID}
|
||||||
, ieDeferred = Nothing
|
, ieCached = Nothing
|
||||||
}
|
}
|
||||||
return $ e' :| es'
|
return $ e' :| es'
|
||||||
where
|
where
|
||||||
|
@ -922,42 +893,42 @@ balanceLinked
|
||||||
:: MonadInsertError m
|
:: MonadInsertError m
|
||||||
=> Vector Decimal
|
=> Vector Decimal
|
||||||
-> ABCKey
|
-> ABCKey
|
||||||
-> LinkDeferred
|
-> EntryLink
|
||||||
-> StateT EntryBals m (Decimal, Maybe DBDeferred)
|
-> StateT EntryBals m (Decimal, Maybe CachedEntry)
|
||||||
balanceLinked from k lg = case lg of
|
balanceLinked from k lg = case lg of
|
||||||
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
|
(LinkIndex LinkedNumGetter {lngIndex, lngScale}) -> do
|
||||||
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
|
let res = fmap (go lngScale) $ from V.!? fromIntegral lngIndex
|
||||||
case res of
|
case res of
|
||||||
Just v -> return (v, Just $ DBEntryLinked lngIndex lngScale)
|
Just v -> return (v, Just $ CachedLink (EntryIndex $ fromIntegral lngIndex) (LinkScale lngScale))
|
||||||
-- TODO this error would be much more informative if I had access to the
|
-- TODO this error would be much more informative if I had access to the
|
||||||
-- file from which it came
|
-- file from which it came
|
||||||
Nothing -> throwError undefined
|
Nothing -> throwError undefined
|
||||||
(LinkDeferred d) -> liftInnerS $ balanceDeferred k d
|
(LinkValue d) -> liftInnerS $ balanceDeferred k d
|
||||||
where
|
where
|
||||||
go s = negate . (*. s)
|
go s = negate . (*. s)
|
||||||
|
|
||||||
balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe DBDeferred)
|
balanceDeferred :: ABCKey -> EntryValue -> State EntryBals (Decimal, Maybe CachedEntry)
|
||||||
balanceDeferred k e = do
|
balanceDeferred k e = do
|
||||||
newval <- findBalance k e
|
newval <- findBalance k e
|
||||||
let d = case e of
|
let d = case e of
|
||||||
EntryFixed _ -> Nothing
|
EntryFixed _ -> Nothing
|
||||||
EntryBalance v -> Just $ DBEntryBalance v
|
EntryBalance v -> Just $ CachedBalance v
|
||||||
EntryPercent v -> Just $ DBEntryPercent v
|
EntryPercent v -> Just $ CachedPercent v
|
||||||
return (newval, d)
|
return (newval, d)
|
||||||
|
|
||||||
balanceEntry
|
balanceEntry
|
||||||
:: (MonadInsertError m)
|
:: (MonadInsertError m)
|
||||||
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe DBDeferred))
|
=> (ABCKey -> v -> StateT EntryBals m (Decimal, Maybe CachedEntry))
|
||||||
-> BCKey
|
-> BCKey
|
||||||
-> Entry AccountRId v TagRId
|
-> Entry AccountRId v TagRId
|
||||||
-> StateT EntryBals m InsertEntry
|
-> StateT EntryBals m InsertEntry
|
||||||
balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
|
balanceEntry f k e@Entry {eValue, eAcnt = acntID} = do
|
||||||
(newVal, deferred) <- f (acntID, k) eValue
|
(newVal, cached) <- f (acntID, k) eValue
|
||||||
modify (mapAdd_ (acntID, k) newVal)
|
modify (mapAdd_ (acntID, k) newVal)
|
||||||
return $
|
return $
|
||||||
InsertEntry
|
InsertEntry
|
||||||
{ ieEntry = e {eValue = newVal, eAcnt = acntID}
|
{ ieEntry = e {eValue = newVal, eAcnt = acntID}
|
||||||
, ieDeferred = deferred
|
, ieCached = cached
|
||||||
}
|
}
|
||||||
|
|
||||||
resolveAcntAndTags
|
resolveAcntAndTags
|
||||||
|
|
Loading…
Reference in New Issue