REF remove "split" lingo
This commit is contained in:
parent
627704704e
commit
ff0393dc02
|
@ -12,6 +12,17 @@ import qualified RIO.NonEmpty as NE
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
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 (TODO)
|
||||||
|
-- 5. insert all transactions
|
||||||
|
|
||||||
insertBudget
|
insertBudget
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
=> Budget
|
=> Budget
|
||||||
|
@ -73,8 +84,8 @@ insertBudgetTx FlatTransfer {ftFrom, ftTo, ftMeta, ftCur, ftValue, ftDesc, ftWhe
|
||||||
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
|
k <- insert $ TransactionR (bmCommit ftMeta) ftWhen ftDesc
|
||||||
insertBudgetLabel k from
|
insertBudgetLabel k from
|
||||||
insertBudgetLabel k to
|
insertBudgetLabel k to
|
||||||
insertBudgetLabel k split = do
|
insertBudgetLabel k entry = do
|
||||||
sk <- insertSplit k split
|
sk <- insertEntry k entry
|
||||||
insert_ $ BudgetLabelR sk $ bmName ftMeta
|
insert_ $ BudgetLabelR sk $ bmName ftMeta
|
||||||
|
|
||||||
entryPair
|
entryPair
|
||||||
|
@ -83,7 +94,7 @@ entryPair
|
||||||
-> TaggedAcnt
|
-> TaggedAcnt
|
||||||
-> BudgetCurrency
|
-> BudgetCurrency
|
||||||
-> Rational
|
-> Rational
|
||||||
-> m (SplitPair, Maybe SplitPair)
|
-> m (EntryPair, Maybe EntryPair)
|
||||||
entryPair from to cur val = case cur of
|
entryPair from to cur val = case cur of
|
||||||
NoX curid -> (,Nothing) <$> pair curid from to val
|
NoX curid -> (,Nothing) <$> pair curid from to val
|
||||||
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
|
X Exchange {xFromCur, xToCur, xAcnt, xRate} -> do
|
||||||
|
@ -93,11 +104,11 @@ entryPair from to cur val = case cur of
|
||||||
combineError res1 res2 $ \a b -> (a, Just b)
|
combineError res1 res2 $ \a b -> (a, Just b)
|
||||||
where
|
where
|
||||||
pair curid from_ to_ v = do
|
pair curid from_ to_ v = do
|
||||||
let s1 = split curid from_ (-v)
|
let s1 = entry curid from_ (-v)
|
||||||
let s2 = split curid to_ v
|
let s2 = entry curid to_ v
|
||||||
combineError s1 s2 (,)
|
combineError s1 s2 (,)
|
||||||
split c TaggedAcnt {taAcnt, taTags} v =
|
entry c TaggedAcnt {taAcnt, taTags} v =
|
||||||
resolveSplit $
|
resolveEntry $
|
||||||
Entry
|
Entry
|
||||||
{ eAcnt = taAcnt
|
{ eAcnt = taAcnt
|
||||||
, eValue = v
|
, eValue = v
|
||||||
|
@ -368,7 +379,7 @@ allocatePost precision aftertax = fmap (fmap go)
|
||||||
else roundPrecision precision v
|
else roundPrecision precision v
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- Transfer
|
-- Standalone Transfer
|
||||||
|
|
||||||
expandTransfers
|
expandTransfers
|
||||||
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
:: (MonadInsertError m, MonadSqlQuery m, MonadFinance m)
|
||||||
|
@ -520,7 +531,7 @@ type IntAllocations =
|
||||||
|
|
||||||
type DaySpanAllocation = Allocation DaySpan
|
type DaySpanAllocation = Allocation DaySpan
|
||||||
|
|
||||||
type SplitPair = (KeySplit, KeySplit)
|
type EntryPair = (KeyEntry, KeyEntry)
|
||||||
|
|
||||||
type PeriodScaler = Natural -> Double -> Double
|
type PeriodScaler = Natural -> Double -> Double
|
||||||
|
|
||||||
|
|
|
@ -10,8 +10,8 @@ module Internal.Database.Ops
|
||||||
, mkPool
|
, mkPool
|
||||||
, whenHash
|
, whenHash
|
||||||
, whenHash_
|
, whenHash_
|
||||||
, insertSplit
|
, insertEntry
|
||||||
, resolveSplit
|
, resolveEntry
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -401,14 +401,14 @@ whenHash_ t o f = do
|
||||||
hs <- askDBState kmNewCommits
|
hs <- askDBState kmNewCommits
|
||||||
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
if h `elem` hs then Just . (c,) <$> f else return Nothing
|
||||||
|
|
||||||
insertSplit :: MonadSqlQuery m => TransactionRId -> KeySplit -> m SplitRId
|
insertEntry :: MonadSqlQuery m => TransactionRId -> KeyEntry -> m EntryRId
|
||||||
insertSplit t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
insertEntry t Entry {eAcnt, eCurrency, eValue, eComment, eTags} = do
|
||||||
k <- insert $ SplitR t eCurrency eAcnt eComment eValue
|
k <- insert $ EntryR t eCurrency eAcnt eComment eValue
|
||||||
mapM_ (insert_ . TagRelationR k) eTags
|
mapM_ (insert_ . TagRelationR k) eTags
|
||||||
return k
|
return k
|
||||||
|
|
||||||
resolveSplit :: (MonadInsertError m, MonadFinance m) => BalSplit -> m KeySplit
|
resolveEntry :: (MonadInsertError m, MonadFinance m) => BalEntry -> m KeyEntry
|
||||||
resolveSplit s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
resolveEntry s@Entry {eAcnt, eCurrency, eValue, eTags} = do
|
||||||
let aRes = lookupAccountKey eAcnt
|
let aRes = lookupAccountKey eAcnt
|
||||||
let cRes = lookupCurrencyKey eCurrency
|
let cRes = lookupCurrencyKey eCurrency
|
||||||
let sRes = lookupAccountSign eAcnt
|
let sRes = lookupAccountSign eAcnt
|
||||||
|
|
|
@ -16,23 +16,6 @@ import RIO hiding (to)
|
||||||
import qualified RIO.Text as T
|
import qualified RIO.Text as T
|
||||||
import RIO.Time
|
import RIO.Time
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- 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
|
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
|
||||||
-- statements
|
|
||||||
|
|
||||||
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
splitHistory :: [History] -> ([HistTransfer], [Statement])
|
||||||
splitHistory = partitionEithers . fmap go
|
splitHistory = partitionEithers . fmap go
|
||||||
where
|
where
|
||||||
|
@ -118,16 +101,16 @@ txPair day from to cur val desc = resolveTx tx
|
||||||
Tx
|
Tx
|
||||||
{ txDescr = desc
|
{ txDescr = desc
|
||||||
, txDate = day
|
, txDate = day
|
||||||
, txSplits = [split from (-val), split to val]
|
, txEntries = [split from (-val), split to val]
|
||||||
}
|
}
|
||||||
|
|
||||||
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
resolveTx :: (MonadInsertError m, MonadFinance m) => BalTx -> m KeyTx
|
||||||
resolveTx t@Tx {txSplits = ss} =
|
resolveTx t@Tx {txEntries = ss} =
|
||||||
fmap (\kss -> t {txSplits = kss}) $
|
fmap (\kss -> t {txEntries = kss}) $
|
||||||
combineErrors $
|
combineErrors $
|
||||||
fmap resolveSplit ss
|
fmap resolveEntry ss
|
||||||
|
|
||||||
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
insertTx :: MonadSqlQuery m => CommitRId -> KeyTx -> m ()
|
||||||
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
insertTx c Tx {txDate = d, txDescr = e, txEntries = ss} = do
|
||||||
k <- insert $ TransactionR c d e
|
k <- insert $ TransactionR c d e
|
||||||
mapM_ (insertSplit k) ss
|
mapM_ (insertEntry k) ss
|
||||||
|
|
|
@ -217,12 +217,12 @@ matchNonDates ms = go ([], [], initZipper ms)
|
||||||
in go (m, u, resetZipper z') rs
|
in go (m, u, resetZipper z') rs
|
||||||
|
|
||||||
balanceTx :: RawTx -> InsertExcept BalTx
|
balanceTx :: RawTx -> InsertExcept BalTx
|
||||||
balanceTx t@Tx {txSplits = ss} = do
|
balanceTx t@Tx {txEntries = ss} = do
|
||||||
bs <- balanceSplits ss
|
bs <- balanceEntries ss
|
||||||
return $ t {txSplits = bs}
|
return $ t {txEntries = bs}
|
||||||
|
|
||||||
balanceSplits :: [RawSplit] -> InsertExcept [BalSplit]
|
balanceEntries :: [RawEntry] -> InsertExcept [BalEntry]
|
||||||
balanceSplits ss =
|
balanceEntries ss =
|
||||||
fmap concat
|
fmap concat
|
||||||
<$> mapM (uncurry bal)
|
<$> mapM (uncurry bal)
|
||||||
$ groupByKey
|
$ groupByKey
|
||||||
|
@ -231,7 +231,7 @@ balanceSplits ss =
|
||||||
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
haeValue s@Entry {eValue = Just v} = Right s {eValue = v}
|
||||||
haeValue s = Left s
|
haeValue s = Left s
|
||||||
bal cur rss
|
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
|
| otherwise = case partitionEithers $ fmap haeValue rss of
|
||||||
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
([noVal], val) -> return $ noVal {eValue = foldr (\s x -> x - eValue s) 0 val} : val
|
||||||
([], val) -> return val
|
([], val) -> return val
|
||||||
|
|
|
@ -44,7 +44,7 @@ TransactionR sql=transactions
|
||||||
date Day
|
date Day
|
||||||
description T.Text
|
description T.Text
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
SplitR sql=splits
|
EntryR sql=entries
|
||||||
transaction TransactionRId OnDeleteCascade
|
transaction TransactionRId OnDeleteCascade
|
||||||
currency CurrencyRId OnDeleteCascade
|
currency CurrencyRId OnDeleteCascade
|
||||||
account AccountRId OnDeleteCascade
|
account AccountRId OnDeleteCascade
|
||||||
|
@ -52,10 +52,10 @@ SplitR sql=splits
|
||||||
value Rational
|
value Rational
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
TagRelationR sql=tag_relations
|
TagRelationR sql=tag_relations
|
||||||
split SplitRId OnDeleteCascade
|
entry EntryRId OnDeleteCascade
|
||||||
tag TagRId OnDeleteCascade
|
tag TagRId OnDeleteCascade
|
||||||
BudgetLabelR sql=budget_labels
|
BudgetLabelR sql=budget_labels
|
||||||
split SplitRId OnDeleteCascade
|
entry EntryRId OnDeleteCascade
|
||||||
budgetName T.Text
|
budgetName T.Text
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
|]
|
|]
|
||||||
|
|
|
@ -421,7 +421,7 @@ data History
|
||||||
| HistStatement !Statement
|
| HistStatement !Statement
|
||||||
deriving (Eq, Generic, Hashable, FromDhall)
|
deriving (Eq, Generic, Hashable, FromDhall)
|
||||||
|
|
||||||
type EntryGetter = Entry SplitAcnt (Maybe EntryNumGetter) SplitCur TagID
|
type EntryGetter = Entry EntryAcnt (Maybe EntryNumGetter) EntryCur TagID
|
||||||
|
|
||||||
instance FromDhall EntryGetter
|
instance FromDhall EntryGetter
|
||||||
|
|
||||||
|
@ -436,7 +436,7 @@ deriving instance (Eq a, Eq v, Eq c, Eq t) => Eq (Entry a v c t)
|
||||||
data Tx s = Tx
|
data Tx s = Tx
|
||||||
{ txDescr :: !T.Text
|
{ txDescr :: !T.Text
|
||||||
, txDate :: !Day
|
, txDate :: !Day
|
||||||
, txSplits :: ![s]
|
, txEntries :: ![s]
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
|
||||||
|
@ -463,7 +463,7 @@ data Statement = Statement
|
||||||
}
|
}
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
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
|
-- can either be a raw (constant) value, a lookup from the record, or a map
|
||||||
-- between the lookup and some other value
|
-- between the lookup and some other value
|
||||||
data EntryTextGetter t
|
data EntryTextGetter t
|
||||||
|
@ -473,9 +473,9 @@ data EntryTextGetter t
|
||||||
| Map2T !(FieldMap (T.Text, T.Text) t)
|
| Map2T !(FieldMap (T.Text, T.Text) t)
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
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)
|
deriving instance (Show k, Show v) => Show (Field k v)
|
||||||
|
|
||||||
|
@ -504,8 +504,8 @@ data FieldMatcher re
|
||||||
deriving instance Show (FieldMatcher T.Text)
|
deriving instance Show (FieldMatcher T.Text)
|
||||||
|
|
||||||
data TxGetter = TxGetter
|
data TxGetter = TxGetter
|
||||||
{ tgCurrency :: !SplitCur
|
{ tgCurrency :: !EntryCur
|
||||||
, tgAcnt :: !SplitAcnt
|
, tgAcnt :: !EntryAcnt
|
||||||
, tgEntries :: ![EntryGetter]
|
, tgEntries :: ![EntryGetter]
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
||||||
|
|
|
@ -57,9 +57,9 @@ data DBState = DBState
|
||||||
|
|
||||||
type CurrencyM = Reader CurrencyMap
|
type CurrencyM = Reader CurrencyMap
|
||||||
|
|
||||||
type KeySplit = Entry AccountRId Rational CurrencyRId TagRId
|
type KeyEntry = Entry AccountRId Rational CurrencyRId TagRId
|
||||||
|
|
||||||
type KeyTx = Tx KeySplit
|
type KeyTx = Tx KeyEntry
|
||||||
|
|
||||||
type TreeR = Tree ([T.Text], AccountRId)
|
type TreeR = Tree ([T.Text], AccountRId)
|
||||||
|
|
||||||
|
@ -125,30 +125,30 @@ accountSign IncomeT = Credit
|
||||||
accountSign LiabilityT = Credit
|
accountSign LiabilityT = Credit
|
||||||
accountSign EquityT = Credit
|
accountSign EquityT = Credit
|
||||||
|
|
||||||
type RawSplit = Entry AcntID (Maybe Rational) CurID TagID
|
type RawEntry = Entry AcntID (Maybe Rational) CurID TagID
|
||||||
|
|
||||||
type BalSplit = Entry AcntID Rational CurID TagID
|
type BalEntry = Entry AcntID Rational CurID TagID
|
||||||
|
|
||||||
type RawTx = Tx RawSplit
|
type RawTx = Tx RawEntry
|
||||||
|
|
||||||
type BalTx = Tx BalSplit
|
type BalTx = Tx BalEntry
|
||||||
|
|
||||||
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
data MatchRes a = MatchPass !a | MatchFail | MatchSkip
|
||||||
|
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- exception types
|
-- exception types
|
||||||
|
|
||||||
data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
data BalanceType = TooFewEntries | NotOneBlank deriving (Show)
|
||||||
|
|
||||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||||
|
|
||||||
data SplitIDType = AcntField | CurField | TagField deriving (Show)
|
data EntryIDType = AcntField | CurField | TagField deriving (Show)
|
||||||
|
|
||||||
data LookupSuberr
|
data LookupSuberr
|
||||||
= SplitIDField !SplitIDType
|
= EntryIDField !EntryIDType
|
||||||
| SplitValField
|
| EntryValField
|
||||||
| MatchField !MatchType
|
| MatchField !MatchType
|
||||||
| DBKey !SplitIDType
|
| DBKey !EntryIDType
|
||||||
deriving (Show)
|
deriving (Show)
|
||||||
|
|
||||||
data AllocationSuberr
|
data AllocationSuberr
|
||||||
|
@ -168,7 +168,7 @@ data InsertError
|
||||||
| ParseError !T.Text
|
| ParseError !T.Text
|
||||||
| ConversionError !T.Text
|
| ConversionError !T.Text
|
||||||
| LookupError !LookupSuberr !T.Text
|
| LookupError !LookupSuberr !T.Text
|
||||||
| BalanceError !BalanceType !CurID ![RawSplit]
|
| BalanceError !BalanceType !CurID ![RawEntry]
|
||||||
| IncomeError !Day !T.Text !Rational
|
| IncomeError !Day !T.Text !Rational
|
||||||
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
| PatternError !Natural !Natural !(Maybe Natural) !PatternSuberr
|
||||||
| DaySpanError !Gregorian !(Maybe Gregorian)
|
| DaySpanError !Gregorian !(Maybe Gregorian)
|
||||||
|
|
|
@ -306,10 +306,10 @@ matches
|
||||||
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
desc = maybe (return True) (matchMaybe trDesc . snd) spDesc
|
||||||
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
|
convert (TxGetter cur a ss) = MatchPass <$> toTx cur a ss r
|
||||||
|
|
||||||
toTx :: SplitCur -> SplitAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
|
toTx :: EntryCur -> EntryAcnt -> [EntryGetter] -> TxRecord -> InsertExceptT CurrencyM RawTx
|
||||||
toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
|
toTx sc sa toEntries r@TxRecord {trAmount, trDate, trDesc} = do
|
||||||
combineError3 acntRes curRes ssRes $ \a c ss ->
|
combineError3 acntRes curRes ssRes $ \a c es ->
|
||||||
let fromSplit =
|
let fromEntry =
|
||||||
Entry
|
Entry
|
||||||
{ eAcnt = a
|
{ eAcnt = a
|
||||||
, eCurrency = c
|
, eCurrency = c
|
||||||
|
@ -320,12 +320,12 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} = do
|
||||||
in Tx
|
in Tx
|
||||||
{ txDate = trDate
|
{ txDate = trDate
|
||||||
, txDescr = trDesc
|
, txDescr = trDesc
|
||||||
, txSplits = fromSplit : ss
|
, txEntries = fromEntry : es
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
acntRes = liftInner $ resolveAcnt r sa
|
acntRes = liftInner $ resolveAcnt r sa
|
||||||
curRes = liftInner $ resolveCurrency r sc
|
curRes = liftInner $ resolveCurrency r sc
|
||||||
ssRes = combineErrors $ fmap (resolveEntry r) toSplits
|
ssRes = combineErrors $ fmap (resolveEntry r) toEntries
|
||||||
|
|
||||||
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
|
valMatches :: ValMatcher -> Rational -> InsertExcept Bool
|
||||||
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
valMatches ValMatcher {vmDen, vmSign, vmNum, vmPrec} x
|
||||||
|
@ -351,7 +351,7 @@ otherMatches dict m = case m of
|
||||||
where
|
where
|
||||||
lookup_ t n = lookupErr (MatchField t) n dict
|
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
|
resolveEntry r s@Entry {eAcnt, eValue, eCurrency} = do
|
||||||
m <- ask
|
m <- ask
|
||||||
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
liftInner $ combineErrorM3 acntRes curRes valRes $ \a c v -> do
|
||||||
|
@ -447,18 +447,18 @@ collectErrorsIO = mapErrorsIO id
|
||||||
|
|
||||||
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
|
resolveValue :: TxRecord -> EntryNumGetter -> InsertExcept Double
|
||||||
resolveValue TxRecord {trOther, trAmount} s = case s of
|
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
|
(ConstN c) -> return c
|
||||||
AmountN m -> return $ (* m) $ fromRational trAmount
|
AmountN m -> return $ (* m) $ fromRational trAmount
|
||||||
|
|
||||||
resolveAcnt :: TxRecord -> SplitAcnt -> InsertExcept T.Text
|
resolveAcnt :: TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||||
resolveAcnt = resolveSplitField AcntField
|
resolveAcnt = resolveEntryField AcntField
|
||||||
|
|
||||||
resolveCurrency :: TxRecord -> SplitCur -> InsertExcept T.Text
|
resolveCurrency :: TxRecord -> EntryCur -> InsertExcept T.Text
|
||||||
resolveCurrency = resolveSplitField CurField
|
resolveCurrency = resolveEntryField CurField
|
||||||
|
|
||||||
resolveSplitField :: SplitIDType -> TxRecord -> SplitAcnt -> InsertExcept T.Text
|
resolveEntryField :: EntryIDType -> TxRecord -> EntryAcnt -> InsertExcept T.Text
|
||||||
resolveSplitField t TxRecord {trOther = o} s = case s of
|
resolveEntryField t TxRecord {trOther = o} s = case s of
|
||||||
ConstT p -> return p
|
ConstT p -> return p
|
||||||
LookupT f -> lookup_ f o
|
LookupT f -> lookup_ f o
|
||||||
MapT (Field f m) -> do
|
MapT (Field f m) -> do
|
||||||
|
@ -469,7 +469,7 @@ resolveSplitField t TxRecord {trOther = o} s = case s of
|
||||||
lookup_ (k1, k2) m
|
lookup_ (k1, k2) m
|
||||||
where
|
where
|
||||||
lookup_ :: (Ord k, Show k) => k -> M.Map k v -> InsertExcept v
|
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 :: (Ord k, Show k) => LookupSuberr -> k -> M.Map k v -> InsertExcept v
|
||||||
lookupErr what k m = case M.lookup k m of
|
lookupErr what k m = case M.lookup k m of
|
||||||
|
@ -596,8 +596,8 @@ showError other = case other of
|
||||||
[T.unwords ["Could not find field", f, "when resolving", what]]
|
[T.unwords ["Could not find field", f, "when resolving", what]]
|
||||||
where
|
where
|
||||||
what = case t of
|
what = case t of
|
||||||
SplitIDField st -> T.unwords ["split", idName st, "ID"]
|
EntryIDField st -> T.unwords ["entry", idName st, "ID"]
|
||||||
SplitValField -> "split value"
|
EntryValField -> "entry value"
|
||||||
MatchField mt -> T.unwords [matchName mt, "match"]
|
MatchField mt -> T.unwords [matchName mt, "match"]
|
||||||
DBKey st -> T.unwords ["database", idName st, "ID key"]
|
DBKey st -> T.unwords ["database", idName st, "ID key"]
|
||||||
-- TODO this should be its own function
|
-- TODO this should be its own function
|
||||||
|
@ -629,15 +629,15 @@ showError other = case other of
|
||||||
[ msg
|
[ msg
|
||||||
, "for currency"
|
, "for currency"
|
||||||
, singleQuote cur
|
, singleQuote cur
|
||||||
, "and for splits"
|
, "and for entries"
|
||||||
, splits
|
, entries
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
msg = case t of
|
msg = case t of
|
||||||
TooFewSplits -> "Need at least two splits to balance"
|
TooFewEntries -> "Need at least two entries to balance"
|
||||||
NotOneBlank -> "Exactly one split must be blank"
|
NotOneBlank -> "Exactly one entries must be blank"
|
||||||
splits = T.intercalate ", " $ fmap (singleQuote . showSplit) rss
|
entries = T.intercalate ", " $ fmap (singleQuote . showEntry) rss
|
||||||
|
|
||||||
showGregorian_ :: Gregorian -> T.Text
|
showGregorian_ :: Gregorian -> T.Text
|
||||||
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
showGregorian_ Gregorian {gYear, gMonth, gDay} = T.intercalate "-" $ showT <$> [gYear, gMonth, gDay]
|
||||||
|
@ -725,8 +725,8 @@ showMatchOther (Val (Field f mv)) =
|
||||||
, singleQuote $ fromMaybe "*" $ showValMatcher mv
|
, singleQuote $ fromMaybe "*" $ showValMatcher mv
|
||||||
]
|
]
|
||||||
|
|
||||||
showSplit :: RawSplit -> T.Text
|
showEntry :: RawEntry -> T.Text
|
||||||
showSplit Entry {eAcnt, eValue, eComment} =
|
showEntry Entry {eAcnt, eValue, eComment} =
|
||||||
keyVals
|
keyVals
|
||||||
[ ("account", eAcnt)
|
[ ("account", eAcnt)
|
||||||
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
|
, ("value", T.pack $ show ((fromRational <$> eValue) :: Maybe Float))
|
||||||
|
@ -921,7 +921,7 @@ lookupTag = lookupFinance TagField kmTag
|
||||||
|
|
||||||
lookupFinance
|
lookupFinance
|
||||||
:: (MonadInsertError m, MonadFinance m)
|
:: (MonadInsertError m, MonadFinance m)
|
||||||
=> SplitIDType
|
=> EntryIDType
|
||||||
-> (DBState -> M.Map T.Text a)
|
-> (DBState -> M.Map T.Text a)
|
||||||
-> T.Text
|
-> T.Text
|
||||||
-> m a
|
-> m a
|
||||||
|
|
Loading…
Reference in New Issue