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