ADD currency exchanges in budget

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
     }

dhall/common.dhall

@@ -4,7 +4,7 @@ let List/map =
 
 let T =
       ./Types.dhall
-        sha256:1c88b66bd88326bf72f1eb2d6a3b4d6d57fd51a473482390b2d0b0486a9a60e7
+        sha256:9d685a852d311e92cff825654c01c37185c0699e56d02908ebb5c4a29c35638f
 
 let nullSplit =
       \(a : T.SplitAcnt) ->

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

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