ADD currency exchanges in budget
This commit is contained in:
parent
ad2937880c
commit
61aabf45a3
|
@ -203,10 +203,15 @@ let TransferTarget =
|
|||
| GenericTarget : AcntID
|
||||
>
|
||||
|
||||
let Exchange =
|
||||
{ xFromCur : CurID, xToCur : CurID, xAcnt : AcntID, xRate : Decimal }
|
||||
|
||||
let BudgetCurrency = < NoX : CurID | X : Exchange >
|
||||
|
||||
let Allocation =
|
||||
{ alloPath : TransferTarget
|
||||
, alloAmts : List Amount
|
||||
, alloCurrency : CurID
|
||||
, alloCurrency : BudgetCurrency
|
||||
}
|
||||
|
||||
let Income =
|
||||
|
@ -227,7 +232,7 @@ let Transfer =
|
|||
{ transFrom : AcntID
|
||||
, transTo : TransferTarget
|
||||
, transAmounts : List TimeAmount
|
||||
, transCurrency : CurID
|
||||
, transCurrency : BudgetCurrency
|
||||
}
|
||||
|
||||
let AcntSet =
|
||||
|
@ -315,4 +320,6 @@ in { CurID
|
|||
, ShadowMatch
|
||||
, ShadowTransfer
|
||||
, AcntSet
|
||||
, BudgetCurrency
|
||||
, Exchange
|
||||
}
|
||||
|
|
|
@ -4,7 +4,7 @@ let List/map =
|
|||
|
||||
let T =
|
||||
./Types.dhall
|
||||
sha256:1c88b66bd88326bf72f1eb2d6a3b4d6d57fd51a473482390b2d0b0486a9a60e7
|
||||
sha256:9d685a852d311e92cff825654c01c37185c0699e56d02908ebb5c4a29c35638f
|
||||
|
||||
let nullSplit =
|
||||
\(a : T.SplitAcnt) ->
|
||||
|
|
|
@ -206,7 +206,7 @@ data BudgetSplit b = BudgetSplit
|
|||
|
||||
data BudgetMeta = BudgetMeta
|
||||
{ bmCommit :: !(Key CommitR)
|
||||
, bmCur :: !CurID
|
||||
, bmCur :: !BudgetCurrency
|
||||
, bmName :: !T.Text
|
||||
}
|
||||
|
||||
|
@ -229,7 +229,7 @@ insertIncome
|
|||
name
|
||||
i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} =
|
||||
whenHash CTIncome i (Right []) $ \c -> do
|
||||
let meta = BudgetMeta c incCurrency name
|
||||
let meta = BudgetMeta c (NoX incCurrency) name
|
||||
let balRes = balanceIncome i
|
||||
fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just)
|
||||
toRes <- lift $ expandTarget incToBal
|
||||
|
@ -373,11 +373,14 @@ expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom}
|
|||
insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError]
|
||||
insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc, btWhen} = do
|
||||
res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue
|
||||
unlessLefts_ res $ \(sFrom, sTo) -> do
|
||||
k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
|
||||
insertBudgetLabel name k IncomeBucketR sFrom btFrom
|
||||
insertBudgetLabel name k ExpenseBucketR sTo btTo
|
||||
unlessLefts_ res $ \((sFrom, sTo), exchange) -> do
|
||||
insertPair sFrom sTo
|
||||
forM_ exchange $ \(xFrom, xTo) -> insertPair xFrom xTo
|
||||
where
|
||||
insertPair from to = do
|
||||
k <- insert $ TransactionR (bmCommit btMeta) btWhen btDesc
|
||||
insertBudgetLabel name k IncomeBucketR from btFrom
|
||||
insertBudgetLabel name k ExpenseBucketR to btTo
|
||||
name = bmName btMeta
|
||||
|
||||
insertBudgetLabel
|
||||
|
@ -393,25 +396,33 @@ insertBudgetLabel name k bucketType split bs = do
|
|||
bk <- insert $ BudgetLabelR sk name
|
||||
forM_ (bsBucket bs) $ insert_ . bucketType bk
|
||||
|
||||
type SplitPair = (KeySplit, KeySplit)
|
||||
|
||||
splitPair
|
||||
:: MonadFinance m
|
||||
=> AcntID
|
||||
-> AcntID
|
||||
-> CurID
|
||||
-> BudgetCurrency
|
||||
-> Rational
|
||||
-> m (EitherErrs (KeySplit, KeySplit))
|
||||
splitPair from to cur val = do
|
||||
s1 <- split from (-val)
|
||||
s2 <- split to val
|
||||
return $ concatEithers2 s1 s2 (,)
|
||||
-> m (EitherErrs (SplitPair, Maybe SplitPair))
|
||||
splitPair from to cur val = case cur of
|
||||
NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val
|
||||
X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do
|
||||
res1 <- pair xFromCur from xAcnt val
|
||||
res2 <- pair xToCur xAcnt to (val * dec2Rat xRate)
|
||||
return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
|
||||
where
|
||||
split a v =
|
||||
pair curid from_ to_ v = do
|
||||
s1 <- split curid from_ (-v)
|
||||
s2 <- split curid to_ v
|
||||
return $ concatEithers2 s1 s2 (,)
|
||||
split c a v =
|
||||
resolveSplit $
|
||||
Split
|
||||
{ sAcnt = a
|
||||
, sValue = v
|
||||
, sComment = ""
|
||||
, sCurrency = cur
|
||||
, sCurrency = c
|
||||
}
|
||||
|
||||
expandTarget
|
||||
|
|
|
@ -36,6 +36,7 @@ makeHaskellTypesWith
|
|||
, MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket"
|
||||
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
||||
, MultipleConstructors "TransferTarget" "(./dhall/Types.dhall).TransferTarget"
|
||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||
, SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian"
|
||||
, SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM"
|
||||
|
@ -54,6 +55,7 @@ makeHaskellTypesWith
|
|||
, SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income"
|
||||
, SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget"
|
||||
, SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer"
|
||||
, SingleConstructor "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
|
||||
, SingleConstructor "AcntSet" "AcntSet" "(./dhall/Types.dhall).AcntSet.Type"
|
||||
, SingleConstructor "ShadowMatch" "ShadowMatch" "(./dhall/Types.dhall).ShadowMatch.Type"
|
||||
, SingleConstructor "ShadowTransfer" "ShadowTransfer" "(./dhall/Types.dhall).ShadowTransfer"
|
||||
|
@ -251,6 +253,14 @@ deriving instance Eq Amount
|
|||
|
||||
deriving instance Hashable Amount
|
||||
|
||||
deriving instance Eq Exchange
|
||||
|
||||
deriving instance Hashable Exchange
|
||||
|
||||
deriving instance Eq BudgetCurrency
|
||||
|
||||
deriving instance Hashable BudgetCurrency
|
||||
|
||||
deriving instance Eq Allocation
|
||||
|
||||
deriving instance Hashable Allocation
|
||||
|
|
Loading…
Reference in New Issue