diff --git a/dhall/Types.dhall b/dhall/Types.dhall index dcc0f1c..e7fa3c7 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -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 } diff --git a/dhall/common.dhall b/dhall/common.dhall index fa539f3..9628282 100644 --- a/dhall/common.dhall +++ b/dhall/common.dhall @@ -4,7 +4,7 @@ let List/map = let T = ./Types.dhall - sha256:1c88b66bd88326bf72f1eb2d6a3b4d6d57fd51a473482390b2d0b0486a9a60e7 + sha256:9d685a852d311e92cff825654c01c37185c0699e56d02908ebb5c4a29c35638f let nullSplit = \(a : T.SplitAcnt) -> diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index 44b929a..2bc5939 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -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 diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index f98362c..41f810c 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -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