ndwarshuis
/
pwncash
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'add_budget_limits'

This commit is contained in:
Nathan Dwarshuis 2023-06-10 20:59:45 -04:00
parent 6117784d0e 90ff12e7e4
commit 53d77326f5
13 changed files with 1285 additions and 1234 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
app/Main.hs
View File

@ -8,10 +8,11 @@ import Control.Monad.Logger
import Control.Monad.Reader
import qualified Data.Text.IO as TI
import Database.Persist.Monad
import Internal.Config
import Internal.Database.Ops
import Internal.Insert
import Internal.Types
import Dhall hiding (double, record)
import Internal.Budget
import Internal.Database
import Internal.History
import Internal.Types.Main
import Internal.Utils
import Options.Applicative
import RIO
@ -168,25 +169,31 @@ runSync c = do
-- _ <- askLoggerIO
-- get the current DB state
s <- runSqlQueryT pool $ do
(state, updates) <- runSqlQueryT pool $ do
runMigration migrateAll
fmap (\f -> f $ takeDirectory c) $ liftIOExceptT $ getDBState config
liftIOExceptT $ getDBState config
-- read desired statements from disk
bSs <- flip runReaderT s $ catMaybes <$> mapErrorsIO readHistStmt hSs
bSs <-
flip runReaderT state $
catMaybes <$> mapErrorsIO (readHistStmt root) hSs
-- update the DB
runSqlQueryT pool $ withTransaction $ flip runReaderT s $ do
runSqlQueryT pool $ withTransaction $ flip runReaderT state $ do
let hTransRes = mapErrors insertHistTransfer hTs
let bgtRes = mapErrors insertBudget $ budget config
updateDBState -- TODO this will only work if foreign keys are deferred
updateDBState updates -- TODO this will only work if foreign keys are deferred
res <- runExceptT $ do
mapM_ (uncurry insertHistStmt) bSs
combineError hTransRes bgtRes $ \_ _ -> ()
rerunnableIO $ fromEither res
where
root = takeDirectory c
err (InsertException es) = do
liftIO $ mapM_ TI.putStrLn $ concatMap showError es
exitFailure
-- showBalances
readConfig :: MonadUnliftIO m => FilePath -> m Config
readConfig confpath = liftIO $ unfix <$> Dhall.inputFile Dhall.auto confpath

13
budget.cabal
View File

@ -25,12 +25,13 @@ source-repository head
library
exposed-modules:
Internal.Config
Internal.Database.Ops
Internal.Insert
Internal.Statement
Internal.TH
Internal.Types
Internal.Budget
Internal.Database
Internal.History
Internal.Types.Database
Internal.Types.Dhall
Internal.Types.Main
Internal.Types.TH
Internal.Utils
other-modules:
Paths_budget

1
dhall/Types.dhall
View File

@ -1018,6 +1018,7 @@ let Budget =
, bgtPosttax : List (MultiAllocation PosttaxValue)
, bgtTransfers : List BudgetTransfer
, bgtShadowTransfers : List ShadowTransfer
, bgtInterval : Optional Interval
}
in { CurID

570
lib/Internal/Budget.hs Normal file
View File

@ -0,0 +1,570 @@
module Internal.Budget (insertBudget) where
import Control.Monad.Except
import Data.Foldable
import Database.Persist.Monad
import Internal.Database
import Internal.Types.Main
import Internal.Utils
import RIO hiding (to)
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
-- each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
-- transaction (some of which depend on the 'current' balance of the
-- target account)
-- 4. assign shadow transactions
-- 5. insert all transactions
insertBudget
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> Budget
-> m ()
insertBudget
b@Budget
{ bgtLabel
, bgtIncomes
, bgtTransfers
, bgtShadowTransfers
, bgtPretax
, bgtTax
, bgtPosttax
, bgtInterval
} =
whenHash CTBudget b () $ \key -> do
(intAllos, _) <- combineError intAlloRes acntRes (,)
let res1 = mapErrors (insertIncome key bgtLabel intAllos bgtInterval) bgtIncomes
let res2 = expandTransfers key bgtLabel bgtInterval bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
m <- askDBState kmCurrency
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
where
acntRes = mapErrors isNotIncomeAcnt alloAcnts
intAlloRes = combineError3 pre_ tax_ post_ (,,)
pre_ = sortAllos bgtPretax
tax_ = sortAllos bgtTax
post_ = sortAllos bgtPosttax
sortAllos = liftExcept . mapErrors sortAllo
alloAcnts =
(alloAcnt <$> bgtPretax)
++ (alloAcnt <$> bgtTax)
++ (alloAcnt <$> bgtPosttax)
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn ftWhen
where
go bals f@FlatTransfer {ftFrom, ftTo, ftValue = UnbalancedValue {cvValue, cvType}} =
let balTo = M.findWithDefault 0 ftTo bals
x = amtToMove balTo cvType cvValue
bals' = mapAdd_ ftTo x $ mapAdd_ ftFrom (-x) bals
in (bals', f {ftValue = x})
-- TODO might need to query signs to make this intuitive; as it is this will
-- probably work, but for credit accounts I might need to supply a negative
-- target value
amtToMove _ BTFixed x = x
amtToMove bal BTPercent x = -(x / 100 * bal)
amtToMove bal BTTarget x = x - bal
-- TODO this seems too general for this module
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
insertBudgetTx
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> BalancedTransfer
-> m ()
insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhen} = do
((sFrom, sTo), exchange) <- entryPair ftFrom ftTo ftCur ftValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
where
insertPair from to = do
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
insertBudgetLabel k from
insertBudgetLabel k to
insertBudgetLabel k entry = do
sk <- insertEntry k entry
insert_ $ BudgetLabelR sk $ bmName ftMeta
entryPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> BudgetCurrency
-> Rational
-> m (EntryPair, Maybe EntryPair)
entryPair from to cur val = case cur of
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt []
let res1 = pair xFromCur from middle val
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
combineError res1 res2 $ \a b -> (a, Just b)
where
pair curid from_ to_ v = do
let s1 = entry curid from_ (-v)
let s2 = entry curid to_ v
combineError s1 s2 (,)
entry c TaggedAcnt {taAcnt, taTags} v =
resolveEntry $
Entry
{ eAcnt = taAcnt
, eValue = v
, eComment = ""
, eCurrency = c
, eTags = taTags
}
sortAllo :: MultiAllocation v -> InsertExcept (DaySpanAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
bs <- foldSpan [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs}
where
foldSpan acc [] = return acc
foldSpan acc (x : xs) = do
let start = amtWhen x
res <- case xs of
[] -> resolveDaySpan start
(y : _) -> resolveDaySpan_ (intStart $ amtWhen y) start
foldSpan (x {amtWhen = res} : acc) xs
--------------------------------------------------------------------------------
-- Income
-- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :(
insertIncome
:: (MonadInsertError m, MonadFinance m)
=> CommitRId
-> T.Text
-> IntAllocations
-> Maybe Interval
-> Income
-> m [UnbalancedTransfer]
insertIncome
key
name
(intPre, intTax, intPost)
localInterval
Income
{ incWhen
, incCurrency
, incFrom
, incPretax
, incPosttax
, incTaxes
, incToBal
, incGross
, incPayPeriod
} =
combineErrorM
(combineError incRes nonIncRes (,))
(combineError precRes dayRes (,))
$ \_ (precision, days) -> do
let gross = roundPrecision precision incGross
concat <$> foldDays (allocate precision gross) start days
where
incRes = isIncomeAcnt $ taAcnt incFrom
nonIncRes =
mapErrors isNotIncomeAcnt $
taAcnt incToBal
: (alloAcnt <$> incPretax)
++ (alloAcnt <$> incTaxes)
++ (alloAcnt <$> incPosttax)
precRes = lookupCurrencyPrec incCurrency
dayRes = askDays incWhen localInterval
start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod
meta = BudgetMeta key name
flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax
sumAllos = sum . fmap faValue
-- TODO ensure these are all the "correct" accounts
allocate precision gross prevDay day = do
scaler <- liftExcept $ periodScaler pType' prevDay day
let (preDeductions, pre) =
allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre
tax =
allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = gross - sumAllos (tax ++ pre)
post =
allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost
balance = aftertaxGross - sumAllos post
bal =
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftFrom = incFrom
, ftCur = NoX incCurrency
, ftTo = incToBal
, ftValue = UnbalancedValue BTFixed balance
, ftDesc = "balance after deductions"
}
in if balance < 0
then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
periodScaler
:: PeriodType
-> Day
-> Day
-> InsertExcept PeriodScaler
periodScaler pt prev cur = return scale
where
n = fromIntegral $ workingDays wds prev cur
wds = case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds
scale precision x = case pt of
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
fromRational (rnd $ x / fromIntegral hpAnnualHours)
* fromIntegral hpDailyHours
* n
Daily _ -> x * n / 365.25
where
rnd = roundPrecision precision
-- ASSUME start < end
workingDays :: [Weekday] -> Day -> Day -> Natural
workingDays wds start end = fromIntegral $ daysFull + daysTail
where
interval = diffDays end start
(nFull, nPart) = divMod interval 7
daysFull = fromIntegral (length wds') * nFull
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
startDay = dayOfWeek start
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
-- ASSUME days is a sorted list
foldDays
:: MonadInsertError m
=> (Day -> Day -> m a)
-> Day
-> [Day]
-> m [a]
foldDays f start days = case NE.nonEmpty days of
Nothing -> return []
Just ds
| any (start >) ds ->
throwError $
InsertException [PeriodError start $ minimum ds]
| otherwise ->
combineErrors $
snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
isIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isIncomeAcnt = checkAcntType IncomeT
isNotIncomeAcnt :: (MonadInsertError m, MonadFinance m) => AcntID -> m ()
isNotIncomeAcnt = checkAcntTypes (AssetT :| [EquityT, ExpenseT, LiabilityT])
checkAcntType
:: (MonadInsertError m, MonadFinance m)
=> AcntType
-> AcntID
-> m ()
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
:: (MonadInsertError m, MonadFinance m)
=> NE.NonEmpty AcntType
-> AcntID
-> m ()
checkAcntTypes ts i = void $ go =<< lookupAccountType i
where
go t
| t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts]
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
-- ASSUME allocations are sorted
selectAllos :: Day -> DaySpanAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
go <$> filter ((`inDaySpan` day) . amtWhen) alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
allo2Trans
:: BudgetMeta
-> Day
-> TaggedAcnt
-> FlatAllocation Rational
-> UnbalancedTransfer
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftFrom = from
, ftCur = faCur
, ftTo = faTo
, ftValue = UnbalancedValue BTFixed faValue
, ftDesc = faDesc
}
allocatePre
:: Natural
-> Rational
-> [FlatAllocation PretaxValue]
-> (M.Map T.Text Rational, [FlatAllocation Rational])
allocatePre precision gross = L.mapAccumR go M.empty
where
go m f@FlatAllocation {faValue} =
let c = preCategory faValue
p = preValue faValue
v =
if prePercent faValue
then (roundPrecision 3 p / 100) * gross
else roundPrecision precision p
in (mapAdd_ c v m, f {faValue = v})
allocateTax
:: Natural
-> Rational
-> M.Map T.Text Rational
-> PeriodScaler
-> [FlatAllocation TaxValue]
-> [FlatAllocation Rational]
allocateTax precision gross preDeds f = fmap (fmap go)
where
go TaxValue {tvCategories, tvMethod} =
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
in case tvMethod of
TMPercent p ->
roundPrecision precision $
fromRational $
roundPrecision 3 p / 100 * agi
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
let taxDed = roundPrecision precision $ f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets
-- | Compute effective tax percentage of a bracket
-- The algorithm can be thought of in three phases:
-- 1. Find the highest tax bracket by looping backward until the AGI is less
-- than the bracket limit
-- 2. Computing the tax in the top bracket by subtracting the AGI from the
-- bracket limit and multiplying by the tax percentage.
-- 3. Adding all lower brackets, which are just the limit of the bracket less
-- the amount of the lower bracket times the percentage.
--
-- In reality, this can all be done with one loop, but it isn't clear these
-- three steps are implemented from this alone.
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
where
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
let l = roundPrecision precision $ f precision tbLowerLimit
p = roundPrecision 3 tbPercent / 100
in if remain >= l then (acc + p * (remain - l), l) else a
allocatePost
:: Natural
-> Rational
-> [FlatAllocation PosttaxValue]
-> [FlatAllocation Rational]
allocatePost precision aftertax = fmap (fmap go)
where
go PosttaxValue {postValue, postPercent} =
let v = postValue
in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
--------------------------------------------------------------------------------
-- Standalone Transfer
expandTransfers
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> Maybe Interval
-> [BudgetTransfer]
-> m [UnbalancedTransfer]
expandTransfers key name localInterval ts = do
txs <-
fmap (L.sortOn ftWhen . concat) $
combineErrors $
fmap (expandTransfer key name) ts
case localInterval of
Nothing -> return txs
Just i -> do
bounds <- liftExcept $ resolveDaySpan i
return $ filter (inDaySpan bounds . ftWhen) txs
expandTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> BudgetTransfer
-> m [UnbalancedTransfer]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
fmap concat $ combineErrors $ fmap (go precision) transAmounts
where
go
precision
Amount
{ amtWhen = pat
, amtValue = BudgetTransferValue {btVal = v, btType = y}
, amtDesc = desc
} =
withDates pat $ \day -> do
let meta = BudgetMeta {bmCommit = key, bmName = name}
return
FlatTransfer
{ ftMeta = meta
, ftWhen = day
, ftCur = transCurrency
, ftFrom = transFrom
, ftTo = transTo
, ftValue = UnbalancedValue y $ roundPrecision precision v
, ftDesc = desc
}
withDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
--------------------------------------------------------------------------------
-- shadow transfers
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
:: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer]
-> InsertExcept [UnbalancedTransfer]
addShadowTransfers cm ms txs =
fmap catMaybes $
combineErrors $
fmap (uncurry (fromShadow cm)) $
[(t, m) | t <- txs, m <- ms]
fromShadow
:: CurrencyMap
-> UnbalancedTransfer
-> ShadowTransfer
-> InsertExcept (Maybe UnbalancedTransfer)
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
res <- shadowMatches (stMatch t) tx
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
return $
if not res
then Nothing
else
Just $
FlatTransfer
{ ftMeta = ftMeta tx
, ftWhen = ftWhen tx
, ftCur = stCurrency
, ftFrom = stFrom
, ftTo = stTo
, ftValue = UnbalancedValue stType $ v * cvValue (ftValue tx)
, ftDesc = stDesc
}
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ ftValue tx
return $
memberMaybe (taAcnt $ ftFrom tx) tmFrom
&& memberMaybe (taAcnt $ ftTo tx) tmTo
&& maybe True (`dateMatches` ftWhen tx) tmDate
&& valRes
where
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList
--------------------------------------------------------------------------------
-- random
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
alloAcnt :: Allocation w v -> AcntID
alloAcnt = taAcnt . alloTo
data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType
, cvValue :: !Rational
}
deriving (Show)
type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
data FlatTransfer v = FlatTransfer
{ ftFrom :: !TaggedAcnt
, ftTo :: !TaggedAcnt
, ftValue :: !v
, ftWhen :: !Day
, ftDesc :: !T.Text
, ftMeta :: !BudgetMeta
, ftCur :: !BudgetCurrency
}
deriving (Show)
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId
, bmName :: !T.Text
}
deriving (Show)
type IntAllocations =
( [DaySpanAllocation PretaxValue]
, [DaySpanAllocation TaxValue]
, [DaySpanAllocation PosttaxValue]
)
type DaySpanAllocation = Allocation DaySpan
type EntryPair = (KeyEntry, KeyEntry)
type PeriodScaler = Natural -> Double -> Double
data FlatAllocation v = FlatAllocation
{ faValue :: !v
, faDesc :: !T.Text
, faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency
}
deriving (Functor, Show)

21
lib/Internal/Config.hs
View File

@ -1,21 +0,0 @@
module Internal.Config
( readConfig
-- , readYaml
)
where
-- import Control.Exception
-- import Data.Yaml
import Dhall hiding (record)
import Internal.Types
import RIO
readConfig :: MonadUnliftIO m => FilePath -> m Config
readConfig confpath = liftIO $ unfix <$> inputFile auto confpath
-- readYaml :: FromJSON a => FilePath -> IO a
-- readYaml p = do
-- r <- decodeFileEither p
-- case r of
-- Right a -> return a
-- Left e -> throw e

152
lib/Internal/Database/Ops.hs → lib/Internal/Database.hs
View File

@ -1,4 +1,4 @@
module Internal.Database.Ops
module Internal.Database
( runDB
, nukeTables
, updateHashes
@ -8,6 +8,10 @@ module Internal.Database.Ops
, flattenAcntRoot
, paths2IDs
, mkPool
, whenHash
, whenHash_
, insertEntry
, resolveEntry
)
where
@ -19,10 +23,18 @@ import Database.Esqueleto.Experimental ((==.), (^.))
import qualified Database.Esqueleto.Experimental as E
import Database.Esqueleto.Internal.Internal (SqlSelect)
import Database.Persist.Monad
-- import Database.Persist.Sql hiding (delete, runMigration, (==.), (||.))
import Database.Persist.Sqlite hiding (delete, deleteWhere, insert, insertKey, runMigration, (==.), (||.))
import Database.Persist.Sqlite hiding
( delete
, deleteWhere
, insert
, insertKey
, insert_
, runMigration
, (==.)
, (||.)
)
import GHC.Err
import Internal.Types
import Internal.Types.Main
import Internal.Utils
import RIO hiding (LogFunc, isNothing, on, (^.))
import RIO.List ((\\))
@ -288,79 +300,117 @@ indexAcntRoot r =
getDBState
:: (MonadInsertError m, MonadSqlQuery m)
=> Config
-> m (FilePath -> DBState)
-> m (DBState, DBUpdates)
getDBState c = do
(del, new) <- getConfigHashes c
-- TODO not sure how I feel about this, probably will change this struct alot
-- in the future so whatever...for now
combineError bi si $ \b s f ->
-- TODO this can be cleaned up, half of it is meant to be queried when
-- determining how to insert budgets/history and the rest is just
-- holdover data to delete upon successful insertion
DBState
{ kmCurrency = currencyMap cs
, kmAccount = am
, kmBudgetInterval = b
, kmStatementInterval = s
, kmNewCommits = new
, kmOldCommits = del
, kmConfigDir = f
, kmTag = tagMap ts
, kmTagAll = ts
, kmAcntPaths = paths
, kmAcntsOld = acnts
, kmCurrenciesOld = cs
}
combineError bi si $ \b s ->
( DBState
{ kmCurrency = currencyMap cs
, kmAccount = am
, kmBudgetInterval = b
, kmStatementInterval = s
, kmTag = tagMap ts
, kmNewCommits = new
}
, DBUpdates
{ duOldCommits = del
, duNewTagIds = ts
, duNewAcntPaths = paths
, duNewAcntIds = acnts
, duNewCurrencyIds = cs
}
)
where
bi = liftExcept $ resolveBounds $ budgetInterval $ global c
si = liftExcept $ resolveBounds $ statementInterval $ global c
bi = liftExcept $ resolveDaySpan $ budgetInterval $ global c
si = liftExcept $ resolveDaySpan $ statementInterval $ global c
(acnts, paths, am) = indexAcntRoot $ accounts c
cs = currency2Record <$> currencies c
ts = toRecord <$> tags c
toRecord t@Tag {tagID, tagDesc} = Entity (toKey t) $ TagR tagID tagDesc
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
updateHashes :: (MonadFinance m, MonadSqlQuery m) => m ()
updateHashes = do
old <- askDBState kmOldCommits
nukeDBHashes old
updateHashes :: (MonadSqlQuery m) => DBUpdates -> m ()
updateHashes DBUpdates {duOldCommits} = nukeDBHashes duOldCommits
updateTags :: (MonadFinance m, MonadSqlQuery m) => m ()
updateTags = do
tags <- askDBState kmTagAll
updateTags :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
updateTags DBUpdates {duNewTagIds} = do
tags' <- selectE $ E.from $ E.table @TagR
let (toIns, toDel) = setDiff tags tags'
let (toIns, toDel) = setDiff duNewTagIds tags'
mapM_ deleteTag toDel
mapM_ insertFull toIns
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => m ()
updateAccounts = do
acnts <- askDBState kmAcntsOld
paths <- askDBState kmAcntPaths
updateAccounts :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
updateAccounts DBUpdates {duNewAcntIds, duNewAcntPaths} = do
acnts' <- dumpTbl
let (toIns, toDel) = setDiff acnts acnts'
let (toIns, toDel) = setDiff duNewAcntIds acnts'
deleteWhere ([] :: [Filter AccountPathR])
mapM_ deleteAccount toDel
mapM_ insertFull toIns
mapM_ insert paths
mapM_ insert duNewAcntPaths
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => m ()
updateCurrencies = do
curs <- askDBState kmCurrenciesOld
updateCurrencies :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
updateCurrencies DBUpdates {duNewCurrencyIds} = do
curs' <- selectE $ E.from $ E.table @CurrencyR
let (toIns, toDel) = setDiff curs curs'
let (toIns, toDel) = setDiff duNewCurrencyIds curs'
mapM_ deleteCurrency toDel
mapM_ insertFull toIns
updateDBState :: (MonadFinance m, MonadSqlQuery m) => m ()
updateDBState = do
updateHashes
updateTags
updateAccounts
updateCurrencies
updateDBState :: (MonadFinance m, MonadSqlQuery m) => DBUpdates -> m ()
updateDBState u = do
updateHashes u
updateTags u
updateAccounts u
updateCurrencies u
deleteE :: (MonadSqlQuery m) => E.SqlQuery () -> m ()
deleteE q = unsafeLiftSql "esqueleto-delete" (E.delete q)
selectE :: (MonadSqlQuery m, SqlSelect a r) => E.SqlQuery a -> m [r]
selectE q = unsafeLiftSql "esqueleto-select" (E.select q)
whenHash
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
=> ConfigType
-> a
-> b
-> (CommitRId -> m b)
-> m b
whenHash t o def f = do
let h = hash o
hs <- askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def
whenHash_
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> m b
-> m (Maybe (CommitR, b))
whenHash_ t o f = do
let h = hash o
let c = CommitR h t
hs <- askDBState kmNewCommits
if h `elem` hs then Just . (c,) <$> f else return Nothing
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
k <- insert $ EntryR t eCurrency eAcnt eComment eValue
mapM_ (insert_ . TagRelationR k) eTags
return k
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey eCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
-- TODO correct sign here?
-- TODO lenses would be nice here
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ eAcnt = aid
, eCurrency = cid
, eValue = eValue * fromIntegral (sign2Int sign)
, eTags = tags
}

133
lib/Internal/Statement.hs → lib/Internal/History.hs
View File

@ -1,16 +1,18 @@
{-# LANGUAGE RecordWildCards #-}
module Internal.Statement
( readImport
module Internal.History
( splitHistory
, insertHistTransfer
, readHistStmt
, insertHistStmt
)
where
import Control.Monad.Error.Class
import Control.Monad.Except
import Data.Csv
import Internal.Types
import Database.Persist.Monad
import Internal.Database
import Internal.Types.Main
import Internal.Utils
import RIO
import RIO hiding (to)
import qualified RIO.ByteString.Lazy as BL
import RIO.FilePath
import qualified RIO.List as L
@ -19,30 +21,118 @@ import qualified RIO.Text as T
import RIO.Time
import qualified RIO.Vector as V
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
insertHistTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer
-> m ()
insertHistTransfer
m@Transfer
{ transFrom = from
, transTo = to
, transCurrency = u
, transAmounts = amts
} = do
whenHash CTManual m () $ \c -> do
bounds <- askDBState kmStatementInterval
let precRes = lookupCurrencyPrec u
let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,)
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
keys <- combineErrors $ fmap tx days
mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts
readHistStmt
:: (MonadUnliftIO m, MonadFinance m)
=> FilePath
-> Statement
-> m (Maybe (CommitR, [KeyTx]))
readHistStmt root i = whenHash_ CTImport i $ do
bs <- readImport root i
bounds <- askDBState kmStatementInterval
liftIOExceptT $ mapErrors resolveTx $ filter (inDaySpan bounds . txDate) bs
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
insertHistStmt c ks = do
ck <- insert c
mapM_ (insertTx ck) ks
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> m KeyTx
txPair day from to cur val desc = resolveTx tx
where
split a v =
Entry
{ eAcnt = a
, eValue = v
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txEntries = [split from (-val), split to val]
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txEntries = ss} =
fmap (\kss -> t {txEntries = kss}) $
combineErrors $
fmap resolveEntry ss
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertEntry k) ss
--------------------------------------------------------------------------------
-- Statements
-- TODO this probably won't scale well (pipes?)
readImport :: (MonadUnliftIO m, MonadFinance m) => Statement -> m [BalTx]
readImport Statement {..} = do
readImport :: (MonadUnliftIO m, MonadFinance m) => FilePath -> Statement -> m [BalTx]
readImport root Statement {stmtTxOpts, stmtParsers, stmtSkipLines, stmtDelim, stmtPaths} = do
let ores = compileOptions stmtTxOpts
let cres = combineErrors $ compileMatch <$> stmtParsers
(compiledOptions, compiledMatches) <- liftIOExcept $ combineError ores cres (,)
let readStmt = readImport_ stmtSkipLines stmtDelim compiledOptions
records <- L.sort . concat <$> mapErrorsIO readStmt stmtPaths
records <- L.sort . concat <$> mapErrorsIO readStmt paths
m <- askDBState kmCurrency
fromEither $
flip runReader m $
runExceptT $
matchRecords compiledMatches records
where
paths = (root </>) <$> stmtPaths
readImport_
:: (MonadUnliftIO m, MonadFinance m)
:: MonadUnliftIO m
=> Natural
-> Word
-> TxOptsRe
-> FilePath
-> m [TxRecord]
readImport_ n delim tns p = do
dir <- askDBState kmConfigDir
res <- tryIO $ BL.readFile $ dir </> p
res <- tryIO $ BL.readFile p
bs <- fromEither $ first (InsertException . (: []) . InsertIOError . showT) res
case decodeByNameWithP (parseTxRecord p tns) opts $ skip bs of
Left m -> throwIO $ InsertException [ParseError $ T.pack m]
@ -54,7 +144,7 @@ readImport_ n delim tns p = do
-- TODO handle this better, this maybe thing is a hack to skip lines with
-- blank dates but will likely want to make this more flexible
parseTxRecord :: FilePath -> TxOptsRe -> NamedRecord -> Parser (Maybe TxRecord)
parseTxRecord p TxOpts {..} r = do
parseTxRecord p TxOpts {toDate, toAmountFmt, toDesc, toAmount, toOther, toDateFmt} r = do
d <- r .: T.encodeUtf8 toDate
if d == ""
then return Nothing
@ -69,7 +159,6 @@ matchRecords :: [MatchRe] -> [TxRecord] -> InsertExceptT CurrencyM [BalTx]
matchRecords ms rs = do
(matched, unmatched, notfound) <- matchAll (matchPriorities ms) rs
case (matched, unmatched, notfound) of
-- TODO record number of times each match hits for debugging
(ms_, [], []) -> liftInner $ combineErrors $ fmap balanceTx ms_
(_, us, ns) -> throwError $ InsertException [StatementError us ns]
@ -85,7 +174,6 @@ matchToGroup ms =
first (L.sortOn spDate) $
L.partition (isJust . spDate) ms
-- TDOO could use a better struct to flatten the maybe date subtype
data MatchGroup = MatchGroup
{ mgDate :: ![MatchRe]
, mgNoDate :: ![MatchRe]
@ -141,7 +229,6 @@ zipperMatch (Unzipped bs cs as) x = go [] cs
ms' = maybe ms (: ms) (matchDec m)
in return (Zipped bs $ ps ++ ms' ++ as, skipOrPass)
-- TODO all this unpacking left/error crap is annoying
zipperMatch'
:: Zipped MatchRe
-> TxRecord
@ -217,12 +304,12 @@ matchNonDates ms = go ([], [], initZipper ms)
in go (m, u, resetZipper z') rs
balanceTx :: RawTx -> InsertExcept BalTx
balanceTx t@Tx {txSplits = ss} = do
bs <- balanceSplits ss
return $ t {txSplits = bs}
balanceTx t@Tx {txEntries = ss} = do
bs <- balanceEntries ss
return $ t {txEntries = bs}
balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
balanceSplits ss =
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
balanceEntries ss =
fmap concat
<$> mapM (uncurry bal)
$ groupByKey
@ -231,7 +318,7 @@ balanceSplits ss =
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
haeValue s = Left s
bal cur rss
| length rss < 2 = throwError $ InsertException [BalanceError TooFewSplits cur rss]
| length rss < 2 = throwError $ InsertException [BalanceError TooFewEntries cur rss]
| otherwise = case partitionEithers $ fmap haeValue rss of
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
([], val) -> return val

789
lib/Internal/Insert.hs
View File

@ -1,789 +0,0 @@
module Internal.Insert
( insertBudget
, splitHistory
, insertHistTransfer
, readHistStmt
, insertHistStmt
)
where
import Control.Monad.Except
import Data.Hashable
import Database.Persist.Monad
import Internal.Statement
import Internal.Types
import Internal.Utils
import RIO hiding (to)
import qualified RIO.List as L
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
--------------------------------------------------------------------------------
-- intervals
expandDatePat :: Bounds -> DatePat -> InsertExcept [Day]
expandDatePat b (Cron cp) = expandCronPat b cp
expandDatePat i (Mod mp) = return $ expandModPat mp i
expandModPat :: ModPat -> Bounds -> [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) = expandBounds bs
start = maybe lower fromGregorian' s
b' = fromIntegral b
addFun = case u of
Day -> addDays
Week -> addDays . (* 7)
Month -> addGregorianMonthsClip
Year -> addGregorianYearsClip
expandCronPat :: Bounds -> CronPat -> InsertExcept [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) = expandBounds 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 -> InsertExcept [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 = throwError $ InsertException [PatternError 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 = throwError $ InsertException [PatternError s b r ZeroRepeats]
| otherwise = return $ min (s + b * (n - 1)) upper
dayToWeekday :: Day -> Int
dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7
withDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> (Day -> m a)
-> m [a]
withDates dp f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $ fmap f days
foldDates
:: (MonadSqlQuery m, MonadFinance m, MonadInsertError m)
=> DatePat
-> Day
-> (Day -> Day -> m a)
-> m [a]
foldDates dp start f = do
bounds <- askDBState kmBudgetInterval
days <- liftExcept $ expandDatePat bounds dp
combineErrors $
snd $
L.mapAccumL (\prevDay day -> (day, f prevDay day)) start days
--------------------------------------------------------------------------------
-- budget
-- each budget (designated at the top level by a 'name') is processed in the
-- following steps
-- 1. expand all transactions given the desired date range and date patterns for
-- each directive in the budget
-- 2. sort all transactions by date
-- 3. propagate all balances forward, and while doing so assign values to each
-- transaction (some of which depend on the 'current' balance of the
-- target account)
-- 4. assign shadow transactions (TODO)
-- 5. insert all transactions
insertBudget
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> Budget
-> m ()
insertBudget
b@Budget
{ bgtLabel
, bgtIncomes
, bgtTransfers
, bgtShadowTransfers
, bgtPretax
, bgtTax
, bgtPosttax
} =
whenHash CTBudget b () $ \key -> do
intAllos <- combineError3 pre_ tax_ post_ (,,)
let res1 = mapErrors (insertIncome key bgtLabel intAllos) bgtIncomes
let res2 = expandTransfers key bgtLabel bgtTransfers
txs <- combineError (concat <$> res1) res2 (++)
m <- askDBState kmCurrency
shadow <- liftExcept $ addShadowTransfers m bgtShadowTransfers txs
void $ mapErrors insertBudgetTx $ balanceTransfers $ txs ++ shadow
where
pre_ = sortAllos bgtPretax
tax_ = sortAllos bgtTax
post_ = sortAllos bgtPosttax
sortAllos = liftExcept . combineErrors . fmap sortAllo
type BoundAllocation = Allocation (Day, Day)
type IntAllocations =
( [BoundAllocation PretaxValue]
, [BoundAllocation TaxValue]
, [BoundAllocation PosttaxValue]
)
-- TODO this should actually error if there is no ultimate end date?
sortAllo :: MultiAllocation v -> InsertExcept (BoundAllocation v)
sortAllo a@Allocation {alloAmts = as} = do
bs <- foldBounds [] $ L.sortOn amtWhen as
return $ a {alloAmts = reverse bs}
where
foldBounds acc [] = return acc
foldBounds acc (x : xs) = do
let start = amtWhen x
res <- case xs of
[] -> resolveBounds start
(y : _) -> resolveBounds_ (intStart $ amtWhen y) start
foldBounds (x {amtWhen = expandBounds res} : acc) xs
-- TODO this is going to be O(n*m), which might be a problem?
addShadowTransfers
:: CurrencyMap
-> [ShadowTransfer]
-> [UnbalancedTransfer]
-> InsertExcept [UnbalancedTransfer]
addShadowTransfers cm ms txs =
fmap catMaybes $
combineErrors $
fmap (uncurry (fromShadow cm)) $
[(t, m) | t <- txs, m <- ms]
fromShadow
:: CurrencyMap
-> UnbalancedTransfer
-> ShadowTransfer
-> InsertExcept (Maybe UnbalancedTransfer)
fromShadow cm tx t@ShadowTransfer {stFrom, stTo, stDesc, stRatio, stCurrency, stType} = do
res <- shadowMatches (stMatch t) tx
v <- roundPrecisionCur (initialCurrency stCurrency) cm stRatio
return $
if not res
then Nothing
else
Just $
-- TODO does this actually share the same metadata as the "parent" tx?
FlatTransfer
{ cbtMeta = cbtMeta tx
, cbtWhen = cbtWhen tx
, cbtCur = stCurrency
, cbtFrom = stFrom
, cbtTo = stTo
, cbtValue = UnbalancedValue stType $ v * cvValue (cbtValue tx)
, cbtDesc = stDesc
}
shadowMatches :: TransferMatcher -> UnbalancedTransfer -> InsertExcept Bool
shadowMatches TransferMatcher {tmFrom, tmTo, tmDate, tmVal} tx = do
valRes <- valMatches tmVal $ cvValue $ cbtValue tx
return $
memberMaybe (taAcnt $ cbtFrom tx) tmFrom
&& memberMaybe (taAcnt $ cbtTo tx) tmTo
&& maybe True (`dateMatches` cbtWhen tx) tmDate
&& valRes
where
memberMaybe x AcntSet {asList, asInclude} =
(if asInclude then id else not) $ x `elem` asList
balanceTransfers :: [UnbalancedTransfer] -> [BalancedTransfer]
balanceTransfers = snd . L.mapAccumR go M.empty . reverse . L.sortOn cbtWhen
where
go bals f@FlatTransfer {cbtFrom, cbtTo, cbtValue = UnbalancedValue {cvValue, cvType}} =
let balTo = M.findWithDefault 0 cbtTo bals
x = amtToMove balTo cvType cvValue
bals' = mapAdd_ cbtTo x $ mapAdd_ cbtFrom (-x) bals
in (bals', f {cbtValue = x})
-- TODO might need to query signs to make this intuitive; as it is this will
-- probably work, but for credit accounts I might need to supply a negative
-- target value
amtToMove _ BTFixed x = x
amtToMove bal BTPercent x = -(x / 100 * bal)
amtToMove bal BTTarget x = x - bal
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
data BudgetMeta = BudgetMeta
{ bmCommit :: !CommitRId
, bmName :: !T.Text
}
deriving (Show)
data FlatTransfer v = FlatTransfer
{ cbtFrom :: !TaggedAcnt
, cbtTo :: !TaggedAcnt
, cbtValue :: !v
, cbtWhen :: !Day
, cbtDesc :: !T.Text
, cbtMeta :: !BudgetMeta
, cbtCur :: !BudgetCurrency
}
deriving (Show)
data UnbalancedValue = UnbalancedValue
{ cvType :: !BudgetTransferType
, cvValue :: !Rational
}
deriving (Show)
type UnbalancedTransfer = FlatTransfer UnbalancedValue
type BalancedTransfer = FlatTransfer Rational
insertIncome
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> IntAllocations
-> Income
-> m [UnbalancedTransfer]
insertIncome
key
name
(intPre, intTax, intPost)
Income
{ incWhen
, incCurrency
, incFrom
, incPretax
, incPosttax
, incTaxes
, incToBal
, incGross
, incPayPeriod
} = do
-- TODO check that the other accounts are not income somewhere here
_ <- checkAcntType IncomeT $ taAcnt incFrom
precision <- lookupCurrencyPrec incCurrency
let gross = roundPrecision precision incGross
-- TODO this will scan the interval allocations fully each time
-- iteration which is a total waste, but the fix requires turning this
-- loop into a fold which I don't feel like doing now :(
res <- foldDates incWhen start (allocate precision gross)
return $ concat res
where
start = fromGregorian' $ pStart incPayPeriod
pType' = pType incPayPeriod
meta = BudgetMeta key name
flatPre = concatMap flattenAllo incPretax
flatTax = concatMap flattenAllo incTaxes
flatPost = concatMap flattenAllo incPosttax
sumAllos = sum . fmap faValue
-- TODO ensure these are all the "correct" accounts
allocate precision gross prevDay day = do
scaler <- liftExcept $ periodScaler pType' prevDay day
let (preDeductions, pre) =
allocatePre precision gross $
flatPre ++ concatMap (selectAllos day) intPre
tax =
allocateTax precision gross preDeductions scaler $
flatTax ++ concatMap (selectAllos day) intTax
aftertaxGross = gross - sumAllos (tax ++ pre)
post =
allocatePost precision aftertaxGross $
flatPost ++ concatMap (selectAllos day) intPost
balance = aftertaxGross - sumAllos post
bal =
FlatTransfer
{ cbtMeta = meta
, cbtWhen = day
, cbtFrom = incFrom
, cbtCur = NoX incCurrency
, cbtTo = incToBal
, cbtValue = UnbalancedValue BTFixed balance
, cbtDesc = "balance after deductions"
}
in if balance < 0
then throwError $ InsertException [IncomeError day name balance]
else return (bal : fmap (allo2Trans meta day incFrom) (pre ++ tax ++ post))
type PeriodScaler = Natural -> Double -> Double
-- TODO we probably don't need to check for 1/0 each time
periodScaler
:: PeriodType
-> Day
-> Day
-> InsertExcept PeriodScaler
periodScaler pt prev cur = do
n <- workingDays wds prev cur
return $ scale (fromIntegral n)
where
wds = case pt of
Hourly HourlyPeriod {hpWorkingDays} -> hpWorkingDays
Daily ds -> ds
scale n precision x = case pt of
Hourly HourlyPeriod {hpAnnualHours, hpDailyHours} ->
fromRational (rnd $ x / fromIntegral hpAnnualHours)
* fromIntegral hpDailyHours
* n
Daily _ -> x * n / 365.25
where
rnd = roundPrecision precision
workingDays :: [Weekday] -> Day -> Day -> InsertExcept Natural
workingDays wds start end
| interval > 0 =
let (nFull, nPart) = divMod interval 7
daysFull = fromIntegral (length wds') * nFull
daysTail = fromIntegral $ length $ takeWhile (< nPart) wds'
in return $ fromIntegral $ daysFull + daysTail
| otherwise = throwError $ InsertException undefined
where
interval = diffDays end start
startDay = dayOfWeek start
wds' = L.sort $ (\x -> diff (fromWeekday x) startDay) <$> L.nub wds
diff a b = fromIntegral $ mod (fromEnum a - fromEnum b) 7
allocatePre
:: Natural
-> Rational
-> [FlatAllocation PretaxValue]
-> (M.Map T.Text Rational, [FlatAllocation Rational])
allocatePre precision gross = L.mapAccumR go M.empty
where
go m f@FlatAllocation {faValue} =
let c = preCategory faValue
p = preValue faValue
v =
if prePercent faValue
then (roundPrecision 3 p / 100) * gross
else roundPrecision precision p
in (mapAdd_ c v m, f {faValue = v})
allo2Trans
:: BudgetMeta
-> Day
-> TaggedAcnt
-> FlatAllocation Rational
-> UnbalancedTransfer
allo2Trans meta day from FlatAllocation {faValue, faTo, faDesc, faCur} =
FlatTransfer
{ cbtMeta = meta
, cbtWhen = day
, cbtFrom = from
, cbtCur = faCur
, cbtTo = faTo
, cbtValue = UnbalancedValue BTFixed faValue
, cbtDesc = faDesc
}
allocateTax
:: Natural
-> Rational
-> M.Map T.Text Rational
-> PeriodScaler
-> [FlatAllocation TaxValue]
-> [FlatAllocation Rational]
allocateTax precision gross preDeds f = fmap (fmap go)
where
go TaxValue {tvCategories, tvMethod} =
let agi = gross - sum (mapMaybe (`M.lookup` preDeds) tvCategories)
in case tvMethod of
TMPercent p ->
roundPrecision precision $
fromRational $
roundPrecision 3 p / 100 * agi
TMBracket TaxProgression {tpDeductible, tpBrackets} ->
let taxDed = roundPrecision precision $ f precision tpDeductible
in foldBracket f precision (agi - taxDed) tpBrackets
allocatePost
:: Natural
-> Rational
-> [FlatAllocation PosttaxValue]
-> [FlatAllocation Rational]
allocatePost precision aftertax = fmap (fmap go)
where
go PosttaxValue {postValue, postPercent} =
let v = postValue
in if postPercent
then aftertax * roundPrecision 3 v / 100
else roundPrecision precision v
-- | Compute effective tax percentage of a bracket
-- The algorithm can be thought of in three phases:
-- 1. Find the highest tax bracket by looping backward until the AGI is less
-- than the bracket limit
-- 2. Computing the tax in the top bracket by subtracting the AGI from the
-- bracket limit and multiplying by the tax percentage.
-- 3. Adding all lower brackets, which are just the limit of the bracket less
-- the amount of the lower bracket times the percentage.
--
-- In reality, this can all be done with one loop, but it isn't clear these
-- three steps are implemented from this alone.
foldBracket :: PeriodScaler -> Natural -> Rational -> [TaxBracket] -> Rational
foldBracket f precision agi bs = fst $ foldr go (0, agi) $ L.sortOn tbLowerLimit bs
where
go TaxBracket {tbLowerLimit, tbPercent} a@(acc, remain) =
let l = roundPrecision precision $ f precision tbLowerLimit
p = roundPrecision 3 tbPercent / 100
in if remain >= l then (acc + p * (remain - l), l) else a
data FlatAllocation v = FlatAllocation
{ faValue :: !v
, faDesc :: !T.Text
, faTo :: !TaggedAcnt
, faCur :: !BudgetCurrency
}
deriving (Functor, Show)
flattenAllo :: SingleAllocation v -> [FlatAllocation v]
flattenAllo Allocation {alloAmts, alloCur, alloTo} = fmap go alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
-- ASSUME allocations are sorted
selectAllos :: Day -> BoundAllocation v -> [FlatAllocation v]
selectAllos day Allocation {alloAmts, alloCur, alloTo} =
go <$> filter ((`inBounds` day) . amtWhen) alloAmts
where
go Amount {amtValue, amtDesc} =
FlatAllocation
{ faCur = NoX alloCur
, faTo = alloTo
, faValue = amtValue
, faDesc = amtDesc
}
expandTransfers
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> [BudgetTransfer]
-> m [UnbalancedTransfer]
expandTransfers key name ts =
fmap (L.sortOn cbtWhen . concat) $
combineErrors $
fmap (expandTransfer key name) ts
initialCurrency :: BudgetCurrency -> CurID
initialCurrency (NoX c) = c
initialCurrency (X Exchange {xFromCur = c}) = c
expandTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> CommitRId
-> T.Text
-> BudgetTransfer
-> m [UnbalancedTransfer]
expandTransfer key name Transfer {transAmounts, transTo, transCurrency, transFrom} = do
precision <- lookupCurrencyPrec $ initialCurrency transCurrency
fmap concat $ combineErrors $ fmap (go precision) transAmounts
where
go
precision
Amount
{ amtWhen = pat
, amtValue = BudgetTransferValue {btVal = v, btType = y}
, amtDesc = desc
} =
withDates pat $ \day -> do
let meta = BudgetMeta {bmCommit = key, bmName = name}
return
FlatTransfer
{ cbtMeta = meta
, cbtWhen = day
, cbtCur = transCurrency
, cbtFrom = transFrom
, cbtTo = transTo
, cbtValue = UnbalancedValue y $ roundPrecision precision v
, cbtDesc = desc
}
insertBudgetTx :: (MonadInsertError m, MonadSqlQuery m, MonadFinance m) => BalancedTransfer -> m ()
insertBudgetTx FlatTransfer {cbtFrom, cbtTo, cbtMeta, cbtCur, cbtValue, cbtDesc, cbtWhen} = do
((sFrom, sTo), exchange) <- splitPair cbtFrom cbtTo cbtCur cbtValue
insertPair sFrom sTo
forM_ exchange $ uncurry insertPair
where
insertPair from to = do
k <- insert $ TransactionR (bmCommit cbtMeta) cbtWhen cbtDesc
insertBudgetLabel k from
insertBudgetLabel k to
insertBudgetLabel k split = do
sk <- insertSplit k split
insert_ $ BudgetLabelR sk $ bmName cbtMeta
type SplitPair = (KeySplit, KeySplit)
splitPair
:: (MonadInsertError m, MonadFinance m)
=> TaggedAcnt
-> TaggedAcnt
-> BudgetCurrency
-> Rational
-> m (SplitPair, Maybe SplitPair)
splitPair from to cur val = case cur of
NoX curid -> (,Nothing) <$> pair curid from to val
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
let middle = TaggedAcnt xAcnt []
let res1 = pair xFromCur from middle val
let res2 = pair xToCur middle to (val * roundPrecision 3 xRate)
combineError res1 res2 $ \a b -> (a, Just b)
where
pair curid from_ to_ v = do
let s1 = split curid from_ (-v)
let s2 = split curid to_ v
combineError s1 s2 (,)
split c TaggedAcnt {taAcnt, taTags} v =
resolveSplit $
Entry
{ eAcnt = taAcnt
, eValue = v
, eComment = ""
, eCurrency = c
, eTags = taTags
}
checkAcntType
:: (MonadInsertError m, MonadFinance m)
=> AcntType
-> AcntID
-> m AcntID
checkAcntType t = checkAcntTypes (t :| [])
checkAcntTypes
:: (MonadInsertError m, MonadFinance m)
=> NE.NonEmpty AcntType
-> AcntID
-> m AcntID
checkAcntTypes ts i = go =<< lookupAccountType i
where
go t
| t `L.elem` ts = return i
| otherwise = throwError $ InsertException [AccountError i ts]
--------------------------------------------------------------------------------
-- statements
splitHistory :: [History] -> ([HistTransfer], [Statement])
splitHistory = partitionEithers . fmap go
where
go (HistTransfer x) = Left x
go (HistStatement x) = Right x
-- insertStatement
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-- => History
-- -> m ()
-- insertStatement (HistTransfer m) = liftIOExceptT $ insertManual m
-- insertStatement (HistStatement i) = insertImport i
insertHistTransfer
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
=> HistTransfer
-> m ()
insertHistTransfer
m@Transfer
{ transFrom = from
, transTo = to
, transCurrency = u
, transAmounts = amts
} = do
whenHash CTManual m () $ \c -> do
bounds <- askDBState kmStatementInterval
let precRes = lookupCurrencyPrec u
let go Amount {amtWhen, amtValue, amtDesc} = do
let dayRes = liftExcept $ expandDatePat bounds amtWhen
(days, precision) <- combineError dayRes precRes (,)
let tx day = txPair day from to u (roundPrecision precision amtValue) amtDesc
keys <- combineErrors $ fmap tx days
mapM_ (insertTx c) keys
void $ combineErrors $ fmap go amts
readHistStmt :: (MonadUnliftIO m, MonadFinance m) => Statement -> m (Maybe (CommitR, [KeyTx]))
readHistStmt i = whenHash_ CTImport i $ do
bs <- readImport i
bounds <- expandBounds <$> askDBState kmStatementInterval
liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
insertHistStmt :: (MonadSqlQuery m) => CommitR -> [KeyTx] -> m ()
insertHistStmt c ks = do
ck <- insert c
mapM_ (insertTx ck) ks
-- insertImport
-- :: (MonadUnliftIO m, MonadSqlQuery m, MonadFinance m)
-- => Statement
-- -> m ()
-- 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
-- bs <- readImport i
-- bounds <- expandBounds <$> askDBState kmStatementInterval
-- keys <- liftIOExceptT $ mapErrors resolveTx $ filter (inBounds bounds . txDate) bs
-- mapM_ (insertTx c) keys
--------------------------------------------------------------------------------
-- low-level transaction stuff
-- TODO tags here?
txPair
:: (MonadInsertError m, MonadFinance m)
=> Day
-> AcntID
-> AcntID
-> CurID
-> Rational
-> T.Text
-> m KeyTx
txPair day from to cur val desc = resolveTx tx
where
split a v =
Entry
{ eAcnt = a
, eValue = v
, eComment = ""
, eCurrency = cur
, eTags = []
}
tx =
Tx
{ txDescr = desc
, txDate = day
, txSplits = [split from (-val), split to val]
}
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
resolveTx t@Tx {txSplits = ss} =
fmap (\kss -> t {txSplits = kss}) $
combineErrors $
fmap resolveSplit ss
resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
let aRes = lookupAccountKey eAcnt
let cRes = lookupCurrencyKey eCurrency
let sRes = lookupAccountSign eAcnt
let tagRes = combineErrors $ fmap lookupTag eTags
-- TODO correct sign here?
-- TODO lenses would be nice here
combineError (combineError3 aRes cRes sRes (,,)) tagRes $
\(aid, cid, sign) tags ->
s
{ eAcnt = aid
, eCurrency = cid
, eValue = eValue * fromIntegral (sign2Int sign)
, eTags = tags
}
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
k <- insert $ TransactionR c d e
mapM_ (insertSplit k) ss
insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
mapM_ (insert_ . TagRelationR k) eTags
return k
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
lookupAccount = lookupFinance AcntField kmAccount
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fstOf3 . lookupAccount
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
lookupAccountSign = fmap sndOf3 . lookupAccount
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap thdOf3 . lookupAccount
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
lookupCurrency = lookupFinance CurField kmCurrency
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
lookupCurrencyKey = fmap fst . lookupCurrency
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
lookupCurrencyPrec = fmap snd . lookupCurrency
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField kmTag
lookupFinance
:: (MonadInsertError m, MonadFinance m)
=> SplitIDType
-> (DBState -> M.Map T.Text a)
-> T.Text
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f
-- TODO this hashes twice (not that it really matters)
whenHash
:: (Hashable a, MonadFinance m, MonadSqlQuery m)
=> ConfigType
-> a
-> b
-> (CommitRId -> m b)
-> m b
whenHash t o def f = do
let h = hash o
hs <- askDBState kmNewCommits
if h `elem` hs then f =<< insert (CommitR h t) else return def
whenHash_
:: (Hashable a, MonadFinance m)
=> ConfigType
-> a
-> m b
-> m (Maybe (CommitR, b))
whenHash_ t o f = do
let h = hash o
let c = CommitR h t
hs <- askDBState kmNewCommits
if h `elem` hs then Just . (c,) <$> f else return Nothing

75
lib/Internal/Types/Database.hs Normal file
View File

@ -0,0 +1,75 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Types corresponding to the database model
module Internal.Types.Database where
import Database.Persist.Sql hiding (Desc, In, Statement)
import Database.Persist.TH
import RIO
import qualified RIO.Text as T
import RIO.Time
share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
CommitR sql=commits
hash Int
type ConfigType
deriving Show Eq
CurrencyR sql=currencies
symbol T.Text
fullname T.Text
precision Int
deriving Show Eq
TagR sql=tags
symbol T.Text
fullname T.Text
deriving Show Eq
AccountR sql=accounts
name T.Text
fullpath T.Text
desc T.Text
deriving Show Eq
AccountPathR sql=account_paths
parent AccountRId OnDeleteCascade
child AccountRId OnDeleteCascade
depth Int
deriving Show Eq
TransactionR sql=transactions
commit CommitRId OnDeleteCascade
date Day
description T.Text
deriving Show Eq
EntryR sql=entries
transaction TransactionRId OnDeleteCascade
currency CurrencyRId OnDeleteCascade
account AccountRId OnDeleteCascade
memo T.Text
value Rational
deriving Show Eq
TagRelationR sql=tag_relations
entry EntryRId OnDeleteCascade
tag TagRId OnDeleteCascade
BudgetLabelR sql=budget_labels
entry EntryRId OnDeleteCascade
budgetName T.Text
deriving Show Eq
|]
data ConfigType = CTBudget | CTManual | CTImport
deriving (Eq, Show, Read, Enum)
instance PersistFieldSql ConfigType where
sqlType _ = SqlString
instance PersistField ConfigType where
toPersistValue = PersistText . T.pack . show
-- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type"

291
lib/Internal/Types.hs → lib/Internal/Types/Dhall.hs
View File

@ -4,29 +4,24 @@
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Internal.Types where
-- | Types corresponding to the configuration tree (written in Dhall)
module Internal.Types.Dhall where
import Control.Monad.Except
import Data.Fix (Fix (..), foldFix)
import Data.Functor.Foldable (embed)
import qualified Data.Functor.Foldable.TH as TH
import Database.Persist.Sql hiding (Desc, In, Statement)
import Database.Persist.TH
import Dhall hiding (embed, maybe)
import Dhall.TH
import Internal.TH (deriveProduct)
import Internal.Types.TH (deriveProduct)
import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
import Text.Regex.TDFA
-------------------------------------------------------------------------------
-- DHALL CONFIG
-------------------------------------------------------------------------------
makeHaskellTypesWith
(defaultGenerateOptions {generateToDhallInstance = False, generateFromDhallInstance = False})
[ MultipleConstructors "SqlConfig" "(./dhall/Types.dhall).SqlConfig"
@ -200,6 +195,7 @@ data Budget = Budget
, bgtPosttax :: [MultiAllocation PosttaxValue]
, bgtTransfers :: [BudgetTransfer]
, bgtShadowTransfers :: [ShadowTransfer]
, bgtInterval :: !(Maybe Interval)
}
deriving instance Hashable PretaxValue
@ -425,7 +421,7 @@ data History
| HistStatement !Statement
deriving (Eq, Generic, Hashable, FromDhall)
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
instance FromDhall EntryGetter
@ -440,7 +436,7 @@ deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
data Tx s = Tx
{ txDescr :: !T.Text
, txDate :: !Day
, txSplits :: ![s]
, txEntries :: ![s]
}
deriving (Generic)
@ -467,7 +463,7 @@ data Statement = Statement
}
deriving (Eq, Hashable, Generic, FromDhall)
-- | the value of a field in split (text version)
-- | the value of a field in entry (text version)
-- can either be a raw (constant) value, a lookup from the record, or a map
-- between the lookup and some other value
data EntryTextGetter t
@ -477,9 +473,9 @@ data EntryTextGetter t
| Map2T !(FieldMap (T.Text, T.Text) t)
deriving (Eq, Generic, Hashable, Show, FromDhall)
type SplitCur = EntryTextGetter CurID
type EntryCur = EntryTextGetter CurID
type SplitAcnt = EntryTextGetter AcntID
type EntryAcnt = EntryTextGetter AcntID
deriving instance (Show k, Show v) => Show (Field k v)
@ -508,8 +504,8 @@ data FieldMatcher re
deriving instance Show (FieldMatcher T.Text)
data TxGetter = TxGetter
{ tgCurrency :: !SplitCur
, tgAcnt :: !SplitAcnt
{ tgCurrency :: !EntryCur
, tgAcnt :: !EntryAcnt
, tgEntries :: ![EntryGetter]
}
deriving (Eq, Generic, Hashable, Show, FromDhall)
@ -527,270 +523,5 @@ data StatementParser re = StatementParser
deriving instance Show (StatementParser T.Text)
--------------------------------------------------------------------------------
-- DATABASE MODEL
--------------------------------------------------------------------------------
share
[mkPersist sqlSettings, mkMigrate "migrateAll"]
[persistLowerCase|
CommitR sql=commits
hash Int
type ConfigType
deriving Show Eq
CurrencyR sql=currencies
symbol T.Text
fullname T.Text
precision Int
deriving Show Eq
TagR sql=tags
symbol T.Text
fullname T.Text
deriving Show Eq
AccountR sql=accounts
name T.Text
fullpath T.Text
desc T.Text
deriving Show Eq
AccountPathR sql=account_paths
parent AccountRId OnDeleteCascade
child AccountRId OnDeleteCascade
depth Int
deriving Show Eq
TransactionR sql=transactions
commit CommitRId OnDeleteCascade
date Day
description T.Text
deriving Show Eq
SplitR sql=splits
transaction TransactionRId OnDeleteCascade
currency CurrencyRId OnDeleteCascade
account AccountRId OnDeleteCascade
memo T.Text
value Rational
deriving Show Eq
TagRelationR sql=tag_relations
split SplitRId OnDeleteCascade
tag TagRId OnDeleteCascade
BudgetLabelR sql=budget_labels
split SplitRId OnDeleteCascade
budgetName T.Text
deriving Show Eq
|]
--------------------------------------------------------------------------------
-- database cache types
data ConfigHashes = ConfigHashes
{ chIncome :: ![Int]
, chExpense :: ![Int]
, chManual :: ![Int]
, chImport :: ![Int]
}
data ConfigType = CTBudget | CTManual | CTImport
deriving (Eq, Show, Read, Enum)
instance PersistFieldSql ConfigType where
sqlType _ = SqlString
instance PersistField ConfigType where
toPersistValue = PersistText . T.pack . show
-- TODO these error messages *might* be good enough?
fromPersistValue (PersistText v) =
maybe (Left $ "could not parse: " <> v) Right $ readMaybe $ T.unpack v
fromPersistValue _ = Left "wrong type"
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
type TagMap = M.Map TagID TagRId
data DBState = DBState
{ kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap
, kmTag :: !TagMap
, kmBudgetInterval :: !Bounds
, kmStatementInterval :: !Bounds
, kmNewCommits :: ![Int]
, kmOldCommits :: ![Int]
, kmConfigDir :: !FilePath
, kmTagAll :: ![Entity TagR]
, kmAcntPaths :: ![AccountPathR]
, kmAcntsOld :: ![Entity AccountR]
, kmCurrenciesOld :: ![Entity CurrencyR]
}
type CurrencyM = Reader CurrencyMap
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
type KeyTx = Tx KeySplit
type TreeR = Tree ([T.Text], AccountRId)
type Balances = M.Map AccountRId Rational
type BalanceM = ReaderT (MVar Balances)
type MonadFinance = MonadReader DBState
askDBState :: MonadFinance m => (DBState -> a) -> m a
askDBState = asks
class MonadUnliftIO m => MonadBalance m where
askBalances :: m (MVar Balances)
withBalances :: (Balances -> m a) -> m a
withBalances f = do
bs <- askBalances
withMVar bs f
modifyBalances :: (Balances -> m (Balances, a)) -> m a
modifyBalances f = do
bs <- askBalances
modifyMVar bs f
lookupBalance :: AccountRId -> m Rational
lookupBalance i = withBalances $ return . fromMaybe 0 . M.lookup i
addBalance :: AccountRId -> Rational -> m ()
addBalance i v =
modifyBalances $ return . (,()) . M.alter (Just . maybe v (v +)) i
-------------------------------------------------------------------------------
-- misc
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
data TxRecord = TxRecord
{ trDate :: !Day
, trAmount :: !Rational
, trDesc :: !T.Text
, trOther :: !(M.Map T.Text T.Text)
, trFile :: !FilePath
}
deriving (Show, Eq, Ord)
type Bounds = (Day, Natural)
data Keyed a = Keyed
{ kKey :: !Int64
, kVal :: !a
}
deriving (Eq, Show, Functor)
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
data AcntSign = Credit | Debit
deriving (Show)
sign2Int :: AcntSign -> Int
sign2Int Debit = 1
sign2Int Credit = 1
accountSign :: AcntType -> AcntSign
accountSign AssetT = Debit
accountSign ExpenseT = Debit
accountSign IncomeT = Credit
accountSign LiabilityT = Credit
accountSign EquityT = Credit
type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
type BalSplit = Entry AcntID Rational CurID TagID
type RawTx = Tx RawSplit
type BalTx = Tx BalSplit
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
--------------------------------------------------------------------------------
-- exception types
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
data MatchType = MatchNumeric | MatchText deriving (Show)
data SplitIDType = AcntField | CurField | TagField deriving (Show)
data LookupSuberr
= SplitIDField !SplitIDType
| SplitValField
| MatchField !MatchType
| DBKey !SplitIDType
deriving (Show)
data AllocationSuberr
= NoAllocations
| ExceededTotal
| MissingBlank
| TooManyBlanks
deriving (Show)
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
data InsertError
= RegexError !T.Text
| MatchValPrecisionError !Natural !Natural
| AccountError !AcntID !(NE.NonEmpty AcntType)
| InsertIOError !T.Text
| ParseError !T.Text
| ConversionError !T.Text
| LookupError !LookupSuberr !T.Text
| BalanceError !BalanceType !CurID ![RawSplit]
| IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| BoundsError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day
deriving (Show)
newtype InsertException = InsertException [InsertError]
deriving (Show, Semigroup) via [InsertError]
instance Exception InsertException
type MonadInsertError = MonadError InsertException
type InsertExceptT = ExceptT InsertException
type InsertExcept = InsertExceptT Identity
data XGregorian = XGregorian
{ xgYear :: !Int
, xgMonth :: !Int
, xgDay :: !Int
, xgDayOfWeek :: !Int
}
type MatchRe = StatementParser (T.Text, Regex)
type TxOptsRe = TxOpts (T.Text, Regex)
type FieldMatcherRe = FieldMatcher (T.Text, Regex)
instance Show (StatementParser (T.Text, Regex)) where
show = show . fmap fst

203
lib/Internal/Types/Main.hs Normal file
View File

@ -0,0 +1,203 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE UndecidableInstances #-}
-- | Other types used throughout the program; kept in its own module to prevent
-- circular imports
module Internal.Types.Main
( module Internal.Types.Main
, module Internal.Types.Dhall
, module Internal.Types.Database
)
where
import Control.Monad.Except
import Database.Persist.Sql hiding (Desc, In, Statement)
import Dhall hiding (embed, maybe)
import Internal.Types.Database
import Internal.Types.Dhall
import Language.Haskell.TH.Syntax (Lift)
import RIO
import qualified RIO.Map as M
import qualified RIO.NonEmpty as NE
import qualified RIO.Text as T
import RIO.Time
import Text.Regex.TDFA
--------------------------------------------------------------------------------
-- database cache types
data ConfigHashes = ConfigHashes
{ chIncome :: ![Int]
, chExpense :: ![Int]
, chManual :: ![Int]
, chImport :: ![Int]
}
type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
type CurrencyMap = M.Map CurID (CurrencyRId, Natural)
type TagMap = M.Map TagID TagRId
data DBState = DBState
{ kmCurrency :: !CurrencyMap
, kmAccount :: !AccountMap
, kmTag :: !TagMap
, kmBudgetInterval :: !DaySpan
, kmStatementInterval :: !DaySpan
, kmNewCommits :: ![Int]
}
data DBUpdates = DBUpdates
{ duOldCommits :: ![Int]
, duNewTagIds :: ![Entity TagR]
, duNewAcntPaths :: ![AccountPathR]
, duNewAcntIds :: ![Entity AccountR]
, duNewCurrencyIds :: ![Entity CurrencyR]
}
type CurrencyM = Reader CurrencyMap
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
type KeyTx = Tx KeyEntry
type TreeR = Tree ([T.Text], AccountRId)
type MonadFinance = MonadReader DBState
askDBState :: MonadFinance m => (DBState -> a) -> m a
askDBState = asks
-------------------------------------------------------------------------------
-- misc
data AcntType
= AssetT
| EquityT
| ExpenseT
| IncomeT
| LiabilityT
deriving (Show, Eq, Ord, Lift, Hashable, Generic, Read, FromDhall)
atName :: AcntType -> T.Text
atName AssetT = "asset"
atName EquityT = "equity"
atName ExpenseT = "expense"
atName IncomeT = "income"
atName LiabilityT = "liability"
data AcntPath = AcntPath
{ apType :: !AcntType
, apChildren :: ![T.Text]
}
deriving (Eq, Ord, Show, Lift, Hashable, Generic, Read, FromDhall)
data TxRecord = TxRecord
{ trDate :: !Day
, trAmount :: !Rational
, trDesc :: !T.Text
, trOther :: !(M.Map T.Text T.Text)
, trFile :: !FilePath
}
deriving (Show, Eq, Ord)
type DaySpan = (Day, Natural)
data Keyed a = Keyed
{ kKey :: !Int64
, kVal :: !a
}
deriving (Eq, Show, Functor)
data Tree a = Branch !a ![Tree a] | Leaf !a deriving (Show)
data AcntSign = Credit | Debit
deriving (Show)
sign2Int :: AcntSign -> Int
sign2Int Debit = 1
sign2Int Credit = 1
accountSign :: AcntType -> AcntSign
accountSign AssetT = Debit
accountSign ExpenseT = Debit
accountSign IncomeT = Credit
accountSign LiabilityT = Credit
accountSign EquityT = Credit
type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
type BalEntry = Entry AcntID Rational CurID TagID
type RawTx = Tx RawEntry
type BalTx = Tx BalEntry
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
--------------------------------------------------------------------------------
-- exception types
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
data MatchType = MatchNumeric | MatchText deriving (Show)
data EntryIDType = AcntField | CurField | TagField deriving (Show)
data LookupSuberr
= EntryIDField !EntryIDType
| EntryValField
| MatchField !MatchType
| DBKey !EntryIDType
deriving (Show)
data AllocationSuberr
= NoAllocations
| ExceededTotal
| MissingBlank
| TooManyBlanks
deriving (Show)
data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show)
data InsertError
= RegexError !T.Text
| MatchValPrecisionError !Natural !Natural
| AccountError !AcntID !(NE.NonEmpty AcntType)
| InsertIOError !T.Text
| ParseError !T.Text
| ConversionError !T.Text
| LookupError !LookupSuberr !T.Text
| BalanceError !BalanceType !CurID ![RawEntry]
| IncomeError !Day !T.Text !Rational
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
| DaySpanError !Gregorian !(Maybe Gregorian)
| StatementError ![TxRecord] ![MatchRe]
| PeriodError !Day !Day
deriving (Show)
newtype InsertException = InsertException [InsertError]
deriving (Show, Semigroup) via [InsertError]
instance Exception InsertException
type MonadInsertError = MonadError InsertException
type InsertExceptT = ExceptT InsertException
type InsertExcept = InsertExceptT Identity
data XGregorian = XGregorian
{ xgYear :: !Int
, xgMonth :: !Int
, xgDay :: !Int
, xgDayOfWeek :: !Int
}
type MatchRe = StatementParser (T.Text, Regex)
type TxOptsRe = TxOpts (T.Text, Regex)
type FieldMatcherRe = FieldMatcher (T.Text, Regex)

3
lib/Internal/TH.hs → lib/Internal/Types/TH.hs
View File

@ -1,4 +1,5 @@
module Internal.TH where
-- | Helper functions so I don't need to write lots of dhall instances
module Internal.Types.TH where
import Language.Haskell.TH.Syntax (Dec (..), Q (..), Type (..), mkName)
import RIO

243
lib/Internal/Utils.hs
View File

@ -1,13 +1,15 @@
module Internal.Utils
( compareDate
, expandDatePat
, askDays
, fromWeekday
, inBounds
, expandBounds
, inDaySpan
, fmtRational
, matches
, fromGregorian'
, resolveBounds
, resolveBounds_
, resolveDaySpan
, resolveDaySpan_
, intersectDaySpan
, liftInner
, liftExceptT
, liftExcept
@ -26,15 +28,6 @@ module Internal.Utils
, combineErrorIOM3
, collectErrorsIO
, mapErrorsIO
-- , leftToMaybe
-- , concatEithers2
-- , concatEithers3
-- , concatEither3
-- , concatEither2
-- , concatEitherL
-- , concatEithersL
-- , concatEither2M
-- , concatEithers2M
, parseRational
, showError
, unlessLeft_
@ -50,13 +43,18 @@ module Internal.Utils
, sndOf3
, thdOf3
, xGregToDay
-- , plural
, compileMatch
, compileOptions
, dateMatches
, valMatches
, roundPrecision
, roundPrecisionCur
, lookupAccountKey
, lookupAccountSign
, lookupAccountType
, lookupCurrencyKey
, lookupCurrencyPrec
, lookupTag
)
where
@ -65,7 +63,7 @@ import Control.Monad.Except
import Control.Monad.Reader
import Data.Time.Format.ISO8601
import GHC.Real
import Internal.Types
import Internal.Types.Main
import RIO
import qualified RIO.List as L
import qualified RIO.Map as M
@ -75,6 +73,96 @@ import RIO.Time
import Text.Regex.TDFA
import Text.Regex.TDFA.Text
--------------------------------------------------------------------------------
-- intervals
expandDatePat :: DaySpan -> DatePat -> InsertExcept [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 -> InsertExcept [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 -> InsertExcept [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 = throwError $ InsertException [PatternError 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 = throwError $ InsertException [PatternError 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, MonadInsertError m)
=> DatePat
-> Maybe Interval
-> m [Day]
askDays dp i = do
globalSpan <- askDBState kmBudgetInterval
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
@ -161,27 +249,42 @@ compareDate (In md offset) x = do
fromGregorian' :: Gregorian -> Day
fromGregorian' = uncurry3 fromGregorian . gregTup
-- TODO misleading name
inBounds :: (Day, Day) -> Day -> Bool
inBounds (d0, d1) x = d0 <= x && x < d1
inDaySpan :: DaySpan -> Day -> Bool
inDaySpan bs = withinDays (fromDaySpan bs)
resolveBounds :: Interval -> InsertExcept Bounds
resolveBounds i@Interval {intStart = s} =
resolveBounds_ (s {gYear = gYear s + 50}) i
withinDays :: (Day, Day) -> Day -> Bool
withinDays (d0, d1) x = d0 <= x && x < d1
resolveBounds_ :: Gregorian -> Interval -> InsertExcept Bounds
resolveBounds_ def Interval {intStart = s, intEnd = e} =
resolveDaySpan :: Interval -> InsertExcept 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 -> InsertExcept DaySpan
resolveDaySpan_ def Interval {intStart = s, intEnd = e} =
case fromGregorian' <$> e of
Nothing -> return $ toBounds $ fromGregorian' def
Nothing -> return $ toDaySpan_ $ fromGregorian' def
Just e_
| s_ < e_ -> return $ toBounds e_
| otherwise -> throwError $ InsertException [BoundsError s e]
| s_ < e_ -> return $ toDaySpan_ e_
| otherwise -> throwError $ InsertException [DaySpanError s e]
where
s_ = fromGregorian' s
toBounds end = (s_, fromIntegral $ diffDays end s_ - 1)
toDaySpan_ end = toDaySpan (s_, end)
expandBounds :: Bounds -> (Day, Day)
expandBounds (d, n) = (d, addDays (fromIntegral n + 1) d)
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
@ -203,10 +306,10 @@ matches
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
combineError3 acntRes curRes ssRes $ \a c ss ->
let fromSplit =
toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do
combineError3 acntRes curRes ssRes $ \a c es ->
let fromEntry =
Entry
{ eAcnt = a
, eCurrency = c
@ -217,12 +320,12 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
in Tx
{ txDate = trDate
, txDescr = trDesc
, txSplits = fromSplit : ss
, txEntries = fromEntry : es
}
where
acntRes = liftInner $ resolveAcnt r sa
curRes = liftInner $ resolveCurrency r sc
ssRes = combineErrors $ fmap (resolveEntry r) toSplits
ssRes = combineErrors $ fmap (resolveEntry r) toEntries
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
@ -248,7 +351,7 @@ otherMatches dict m = case m of
where
lookup_ t n = lookupErr (MatchField t) n dict
resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawSplit
resolveEntry :: TxRecord -> EntryGetter -> InsertExceptT CurrencyM RawEntry
resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
m <- ask
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
@ -344,18 +447,18 @@ collectErrorsIO = mapErrorsIO id
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
resolveValue TxRecord {trOther, trAmount} s = case s of
(LookupN t) -> readDouble =<< lookupErr SplitValField t trOther
(LookupN t) -> readDouble =<< lookupErr EntryValField t trOther
(ConstN c) -> return c
AmountN m -> return $ (* m) $ fromRational trAmount
resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
resolveAcnt = resolveSplitField AcntField
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveAcnt = resolveEntryField AcntField
resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
resolveCurrency = resolveSplitField CurField
resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text
resolveCurrency = resolveEntryField CurField
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
resolveSplitField t TxRecord {trOther = o} s = case s of
resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
resolveEntryField t TxRecord {trOther = o} s = case s of
ConstT p -> return p
LookupT f -> lookup_ f o
MapT (Field f m) -> do
@ -366,7 +469,7 @@ resolveSplitField t TxRecord {trOther = o} s = case s of
lookup_ (k1, k2) m
where
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
lookup_ = lookupErr (SplitIDField t)
lookup_ = lookupErr (EntryIDField t)
lookupErr :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
lookupErr what k m = case M.lookup k m of
@ -454,7 +557,7 @@ acntPath2Text (AcntPath t cs) = T.intercalate "/" (atName t : cs)
showError :: InsertError -> [T.Text]
showError other = case other of
(StatementError ts ms) -> (showTx <$> ts) ++ (showMatch <$> ms)
(BoundsError a b) ->
(DaySpanError a b) ->
[T.unwords ["Could not create bounds from", showGregorian_ a, "and", showGreg b]]
where
showGreg (Just g) = showGregorian_ g
@ -493,8 +596,8 @@ showError other = case other of
[T.unwords ["Could not find field", f, "when resolving", what]]
where
what = case t of
SplitIDField st -> T.unwords ["split", idName st, "ID"]
SplitValField -> "split value"
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
@ -526,15 +629,15 @@ showError other = case other of
[ msg
, "for currency"
, singleQuote cur
, "and for splits"
, splits
, "and for entries"
, entries
]
]
where
msg = case t of
TooFewSplits -> "Need at least two splits to balance"
NotOneBlank -> "Exactly one split must be blank"
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
TooFewEntries -> "Need at least two entries to balance"
NotOneBlank -> "Exactly one entries must be blank"
entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
showGregorian_ :: Gregorian -> T.Text
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
@ -622,8 +725,8 @@ showMatchOther (Val (Field f mv)) =
, singleQuote $ fromMaybe "*" $ showValMatcher mv
]
showSplit :: RawSplit -> T.Text
showSplit Entry {eAcnt, eValue, eComment} =
showEntry :: RawEntry -> T.Text
showEntry Entry {eAcnt, eValue, eComment} =
keyVals
[ ("account", eAcnt)
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
@ -791,3 +894,35 @@ matchGroupsMaybe q re = case regexec re q of
Right (Just (_, _, _, xs)) -> xs
-- this should never fail as regexec always returns Right
Left _ -> []
lookupAccount :: (MonadInsertError m, MonadFinance m) => AcntID -> m (AccountRId, AcntSign, AcntType)
lookupAccount = lookupFinance AcntField kmAccount
lookupAccountKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m AccountRId
lookupAccountKey = fmap fstOf3 . lookupAccount
lookupAccountSign :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntSign
lookupAccountSign = fmap sndOf3 . lookupAccount
lookupAccountType :: (MonadInsertError m, MonadFinance m) => AcntID -> m AcntType
lookupAccountType = fmap thdOf3 . lookupAccount
lookupCurrency :: (MonadInsertError m, MonadFinance m) => T.Text -> m (CurrencyRId, Natural)
lookupCurrency = lookupFinance CurField kmCurrency
lookupCurrencyKey :: (MonadInsertError m, MonadFinance m) => AcntID -> m CurrencyRId
lookupCurrencyKey = fmap fst . lookupCurrency
lookupCurrencyPrec :: (MonadInsertError m, MonadFinance m) => AcntID -> m Natural
lookupCurrencyPrec = fmap snd . lookupCurrency
lookupTag :: (MonadInsertError m, MonadFinance m) => TagID -> m TagRId
lookupTag = lookupFinance TagField kmTag
lookupFinance
:: (MonadInsertError m, MonadFinance m)
=> EntryIDType
-> (DBState -> M.Map T.Text a)
-> T.Text
-> m a
lookupFinance t f c = (liftExcept . lookupErr (DBKey t) c) =<< askDBState f