WIP use tags for splits
This commit is contained in:
parent
4e38f9ed8d
commit
4eae92eb01
|
@ -6,10 +6,14 @@ let CurID = Text
|
||||||
|
|
||||||
let AcntID = Text
|
let AcntID = Text
|
||||||
|
|
||||||
|
let TagID = Text
|
||||||
|
|
||||||
let SqlConfig {- TODO pgsql -} = < Sqlite : Text | Postgres >
|
let SqlConfig {- TODO pgsql -} = < Sqlite : Text | Postgres >
|
||||||
|
|
||||||
let Currency = { curSymbol : CurID, curFullname : Text }
|
let Currency = { curSymbol : CurID, curFullname : Text }
|
||||||
|
|
||||||
|
let Tag = { tagID : TagID, tagDesc : Text }
|
||||||
|
|
||||||
let Gregorian = { gYear : Natural, gMonth : Natural, gDay : Natural }
|
let Gregorian = { gYear : Natural, gMonth : Natural, gDay : Natural }
|
||||||
|
|
||||||
let GregorianM = { gmYear : Natural, gmMonth : Natural }
|
let GregorianM = { gmYear : Natural, gmMonth : Natural }
|
||||||
|
@ -194,10 +198,13 @@ let Exchange =
|
||||||
|
|
||||||
let BudgetCurrency = < NoX : CurID | X : Exchange >
|
let BudgetCurrency = < NoX : CurID | X : Exchange >
|
||||||
|
|
||||||
|
let TaggedAcnt = { taAcnt : AcntID, taTags : List TagID }
|
||||||
|
|
||||||
let Allocation =
|
let Allocation =
|
||||||
{ alloPath : AcntID
|
{ alloTo : TaggedAcnt
|
||||||
|
, alloTags : List TagID
|
||||||
, alloAmts : List Amount
|
, alloAmts : List Amount
|
||||||
, alloCurrency : BudgetCurrency
|
, alloCur : BudgetCurrency
|
||||||
}
|
}
|
||||||
|
|
||||||
let Income =
|
let Income =
|
||||||
|
@ -207,16 +214,16 @@ let Income =
|
||||||
, incFrom :
|
, incFrom :
|
||||||
{- this must be an income AcntID, and is the only place income
|
{- this must be an income AcntID, and is the only place income
|
||||||
accounts may be specified in the entire budget -}
|
accounts may be specified in the entire budget -}
|
||||||
AcntID
|
TaggedAcnt
|
||||||
, incPretax : List Allocation
|
, incPretax : List Allocation
|
||||||
, incTaxes : List Tax
|
, incTaxes : List Tax
|
||||||
, incPosttax : List Allocation
|
, incPosttax : List Allocation
|
||||||
, incToBal : AcntID
|
, incToBal : TaggedAcnt
|
||||||
}
|
}
|
||||||
|
|
||||||
let Transfer =
|
let Transfer =
|
||||||
{ transFrom : AcntID
|
{ transFrom : TaggedAcnt
|
||||||
, transTo : AcntID
|
, transTo : TaggedAcnt
|
||||||
, transAmounts : List TimeAmount
|
, transAmounts : List TimeAmount
|
||||||
, transCurrency : BudgetCurrency
|
, transCurrency : BudgetCurrency
|
||||||
}
|
}
|
||||||
|
@ -242,8 +249,8 @@ let ShadowMatch =
|
||||||
}
|
}
|
||||||
|
|
||||||
let ShadowTransfer =
|
let ShadowTransfer =
|
||||||
{ stFrom : AcntID
|
{ stFrom : TaggedAcnt
|
||||||
, stTo : AcntID
|
, stTo : TaggedAcnt
|
||||||
, stCurrency : CurID
|
, stCurrency : CurID
|
||||||
, stDesc : Text
|
, stDesc : Text
|
||||||
, stMatch : ShadowMatch.Type
|
, stMatch : ShadowMatch.Type
|
||||||
|
@ -261,6 +268,7 @@ in { CurID
|
||||||
, AcntID
|
, AcntID
|
||||||
, SqlConfig
|
, SqlConfig
|
||||||
, Currency
|
, Currency
|
||||||
|
, Tag
|
||||||
, Interval
|
, Interval
|
||||||
, Global
|
, Global
|
||||||
, Gregorian
|
, Gregorian
|
||||||
|
@ -305,4 +313,5 @@ in { CurID
|
||||||
, AcntSet
|
, AcntSet
|
||||||
, BudgetCurrency
|
, BudgetCurrency
|
||||||
, Exchange
|
, Exchange
|
||||||
|
, TaggedAcnt
|
||||||
}
|
}
|
||||||
|
|
|
@ -161,6 +161,13 @@ deleteCurrency e = delete $ do
|
||||||
where
|
where
|
||||||
k = entityKey e
|
k = entityKey e
|
||||||
|
|
||||||
|
deleteTag :: MonadUnliftIO m => Entity TagR -> SqlPersistT m ()
|
||||||
|
deleteTag e = delete $ do
|
||||||
|
c <- from $ table @TagR
|
||||||
|
where_ (c ^. TagRId ==. val k)
|
||||||
|
where
|
||||||
|
k = entityKey e
|
||||||
|
|
||||||
updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
|
updateAccounts :: MonadUnliftIO m => AccountRoot -> SqlPersistT m AccountMap
|
||||||
updateAccounts ar = do
|
updateAccounts ar = do
|
||||||
let (acnts, paths, acntMap) = indexAcntRoot ar
|
let (acnts, paths, acntMap) = indexAcntRoot ar
|
||||||
|
@ -173,6 +180,7 @@ updateAccounts ar = do
|
||||||
mapM_ insert paths
|
mapM_ insert paths
|
||||||
return acntMap
|
return acntMap
|
||||||
|
|
||||||
|
-- TODO slip-n-slide code...
|
||||||
insertFull
|
insertFull
|
||||||
:: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
|
:: (MonadUnliftIO m, PersistStoreWrite b, PersistRecordBackend r b)
|
||||||
=> Entity r
|
=> Entity r
|
||||||
|
@ -195,6 +203,18 @@ currency2Record c@Currency {curSymbol, curFullname} =
|
||||||
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
currencyMap :: [Entity CurrencyR] -> CurrencyMap
|
||||||
currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
|
currencyMap = M.fromList . fmap (\e -> (currencyRSymbol $ entityVal e, entityKey e))
|
||||||
|
|
||||||
|
updateTags :: MonadUnliftIO m => [Tag] -> SqlPersistT m TagMap
|
||||||
|
updateTags cs = do
|
||||||
|
let tags = fmap toRecord cs
|
||||||
|
tags' <- select $ from $ table @TagR
|
||||||
|
let (toIns, toDel) = setDiff tags tags'
|
||||||
|
mapM_ deleteTag toDel
|
||||||
|
mapM_ insertFull toIns
|
||||||
|
return $ tagMap tags
|
||||||
|
where
|
||||||
|
toRecord t@(Tag {tagID, tagDesc}) = Entity (toKey t) $ TagR tagID tagDesc
|
||||||
|
tagMap = M.fromList . fmap (\e -> (tagRSymbol $ entityVal e, entityKey e))
|
||||||
|
|
||||||
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
toKey :: (ToBackendKey SqlBackend b, Hashable a) => a -> Key b
|
||||||
toKey = toSqlKey . fromIntegral . hash
|
toKey = toSqlKey . fromIntegral . hash
|
||||||
|
|
||||||
|
@ -306,6 +326,7 @@ getDBState
|
||||||
getDBState c = do
|
getDBState c = do
|
||||||
am <- updateAccounts $ accounts c
|
am <- updateAccounts $ accounts c
|
||||||
cm <- updateCurrencies $ currencies c
|
cm <- updateCurrencies $ currencies c
|
||||||
|
ts <- updateTags $ tags c
|
||||||
hs <- updateHashes c
|
hs <- updateHashes c
|
||||||
-- TODO not sure how I feel about this, probably will change this struct alot
|
-- TODO not sure how I feel about this, probably will change this struct alot
|
||||||
-- in the future so whatever...for now
|
-- in the future so whatever...for now
|
||||||
|
@ -317,6 +338,7 @@ getDBState c = do
|
||||||
, kmStatementInterval = s
|
, kmStatementInterval = s
|
||||||
, kmNewCommits = hs
|
, kmNewCommits = hs
|
||||||
, kmConfigDir = f
|
, kmConfigDir = f
|
||||||
|
, kmTag = ts
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
bi = resolveBounds $ budgetInterval $ global c
|
bi = resolveBounds $ budgetInterval $ global c
|
||||||
|
|
|
@ -163,8 +163,8 @@ shadowMatches ShadowMatch {smFrom, smTo, smDate, smVal} tx = do
|
||||||
-- TODO what does the amount do for each of the different types?
|
-- TODO what does the amount do for each of the different types?
|
||||||
valRes <- valMatches smVal (btValue tx_)
|
valRes <- valMatches smVal (btValue tx_)
|
||||||
return $
|
return $
|
||||||
memberMaybe (btFrom tx_) smFrom
|
memberMaybe (taAcnt $ btFrom tx_) smFrom
|
||||||
&& memberMaybe (btTo tx_) smTo
|
&& memberMaybe (taAcnt $ btTo tx_) smTo
|
||||||
&& maybe True (`dateMatches` (btWhen tx_)) smDate
|
&& maybe True (`dateMatches` (btWhen tx_)) smDate
|
||||||
&& valRes
|
&& valRes
|
||||||
where
|
where
|
||||||
|
@ -205,8 +205,8 @@ data BudgetMeta = BudgetMeta
|
||||||
data BudgetTx = BudgetTx
|
data BudgetTx = BudgetTx
|
||||||
{ btMeta :: !BudgetMeta
|
{ btMeta :: !BudgetMeta
|
||||||
, btWhen :: !Day
|
, btWhen :: !Day
|
||||||
, btFrom :: !AcntID
|
, btFrom :: !TaggedAcnt
|
||||||
, btTo :: !AcntID
|
, btTo :: !TaggedAcnt
|
||||||
, btValue :: !Rational
|
, btValue :: !Rational
|
||||||
, btDesc :: !T.Text
|
, btDesc :: !T.Text
|
||||||
}
|
}
|
||||||
|
@ -223,17 +223,18 @@ insertIncome
|
||||||
whenHash CTIncome i (Right []) $ \c -> do
|
whenHash CTIncome i (Right []) $ \c -> do
|
||||||
let meta = BudgetMeta c (NoX incCurrency) name
|
let meta = BudgetMeta c (NoX incCurrency) name
|
||||||
let balRes = balanceIncome i
|
let balRes = balanceIncome i
|
||||||
fromRes <- lift $ checkAcntType IncomeT incFrom
|
fromRes <- lift $ checkAcntType IncomeT $ taAcnt incFrom
|
||||||
case concatEither2 balRes fromRes (,) of
|
case concatEither2 balRes fromRes (,) of
|
||||||
Left es -> return $ Left es
|
Left es -> return $ Left es
|
||||||
Right (balance, from) ->
|
-- TODO this hole seems sloppy...
|
||||||
|
Right (balance, _) ->
|
||||||
fmap (fmap (concat . concat)) $
|
fmap (fmap (concat . concat)) $
|
||||||
withDates incWhen $ \day -> do
|
withDates incWhen $ \day -> do
|
||||||
let fromAllos = fmap concat . mapM (lift . fromAllo day meta from)
|
let fromAllos = fmap concat . mapM (lift . fromAllo day meta incFrom)
|
||||||
pre <- fromAllos incPretax
|
pre <- fromAllos incPretax
|
||||||
tax <-
|
tax <-
|
||||||
concatEitherL
|
concatEitherL
|
||||||
<$> mapM (lift . fromTax day meta from) incTaxes
|
<$> mapM (lift . fromTax day meta (taAcnt incFrom)) incTaxes
|
||||||
post <- fromAllos incPosttax
|
post <- fromAllos incPosttax
|
||||||
let bal =
|
let bal =
|
||||||
BudgetTxType
|
BudgetTxType
|
||||||
|
@ -241,7 +242,7 @@ insertIncome
|
||||||
BudgetTx
|
BudgetTx
|
||||||
{ btMeta = meta
|
{ btMeta = meta
|
||||||
, btWhen = day
|
, btWhen = day
|
||||||
, btFrom = from
|
, btFrom = incFrom
|
||||||
, btTo = incToBal
|
, btTo = incToBal
|
||||||
, btValue = balance
|
, btValue = balance
|
||||||
, btDesc = "balance after deductions"
|
, btDesc = "balance after deductions"
|
||||||
|
@ -254,10 +255,10 @@ fromAllo
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> Day
|
=> Day
|
||||||
-> BudgetMeta
|
-> BudgetMeta
|
||||||
-> AcntID
|
-> TaggedAcnt
|
||||||
-> Allocation
|
-> Allocation
|
||||||
-> m [BudgetTxType]
|
-> m [BudgetTxType]
|
||||||
fromAllo day meta from Allocation {alloPath, alloAmts} = do
|
fromAllo day meta from Allocation {alloTo, alloAmts} = do
|
||||||
-- TODO this is going to be repeated a zillion times (might matter)
|
-- TODO this is going to be repeated a zillion times (might matter)
|
||||||
-- res <- expandTarget alloPath
|
-- res <- expandTarget alloPath
|
||||||
return $ fmap toBT alloAmts
|
return $ fmap toBT alloAmts
|
||||||
|
@ -268,7 +269,7 @@ fromAllo day meta from Allocation {alloPath, alloAmts} = do
|
||||||
BudgetTx
|
BudgetTx
|
||||||
{ btFrom = from
|
{ btFrom = from
|
||||||
, btWhen = day
|
, btWhen = day
|
||||||
, btTo = alloPath
|
, btTo = alloTo
|
||||||
, btValue = dec2Rat v
|
, btValue = dec2Rat v
|
||||||
, btDesc = desc
|
, btDesc = desc
|
||||||
, btMeta = meta
|
, btMeta = meta
|
||||||
|
@ -276,6 +277,7 @@ fromAllo day meta from Allocation {alloPath, alloAmts} = do
|
||||||
, bttType = FixedAmt
|
, bttType = FixedAmt
|
||||||
}
|
}
|
||||||
|
|
||||||
|
-- TODO maybe allow tags here?
|
||||||
fromTax
|
fromTax
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> Day
|
=> Day
|
||||||
|
@ -291,9 +293,9 @@ fromTax day meta from Tax {taxAcnt = to, taxValue = v} = do
|
||||||
BudgetTxType
|
BudgetTxType
|
||||||
{ bttTx =
|
{ bttTx =
|
||||||
BudgetTx
|
BudgetTx
|
||||||
{ btFrom = from
|
{ btFrom = TaggedAcnt from []
|
||||||
, btWhen = day
|
, btWhen = day
|
||||||
, btTo = to_
|
, btTo = TaggedAcnt to_ []
|
||||||
, btValue = dec2Rat v
|
, btValue = dec2Rat v
|
||||||
, btDesc = ""
|
, btDesc = ""
|
||||||
, btMeta = meta
|
, btMeta = meta
|
||||||
|
@ -376,29 +378,31 @@ type SplitPair = (KeySplit, KeySplit)
|
||||||
|
|
||||||
splitPair
|
splitPair
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> AcntID
|
=> TaggedAcnt
|
||||||
-> AcntID
|
-> TaggedAcnt
|
||||||
-> BudgetCurrency
|
-> BudgetCurrency
|
||||||
-> Rational
|
-> Rational
|
||||||
-> m (EitherErrs (SplitPair, Maybe SplitPair))
|
-> m (EitherErrs (SplitPair, Maybe SplitPair))
|
||||||
splitPair from to cur val = case cur of
|
splitPair from to cur val = case cur of
|
||||||
NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val
|
NoX curid -> fmap (fmap (,Nothing)) $ pair curid from to val
|
||||||
X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do
|
X (Exchange {xFromCur, xToCur, xAcnt, xRate}) -> do
|
||||||
res1 <- pair xFromCur from xAcnt val
|
let middle = TaggedAcnt xAcnt []
|
||||||
res2 <- pair xToCur xAcnt to (val * dec2Rat xRate)
|
res1 <- pair xFromCur from middle val
|
||||||
|
res2 <- pair xToCur middle to (val * dec2Rat xRate)
|
||||||
return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
|
return $ concatEithers2 res1 res2 $ \a b -> (a, Just b)
|
||||||
where
|
where
|
||||||
pair curid from_ to_ v = do
|
pair curid from_ to_ v = do
|
||||||
s1 <- split curid from_ (-v)
|
s1 <- split curid from_ (-v)
|
||||||
s2 <- split curid to_ v
|
s2 <- split curid to_ v
|
||||||
return $ concatEithers2 s1 s2 (,)
|
return $ concatEithers2 s1 s2 (,)
|
||||||
split c a v =
|
split c TaggedAcnt {taAcnt, taTags} v =
|
||||||
resolveSplit $
|
resolveSplit $
|
||||||
Split
|
Split
|
||||||
{ sAcnt = a
|
{ sAcnt = taAcnt
|
||||||
, sValue = v
|
, sValue = v
|
||||||
, sComment = ""
|
, sComment = ""
|
||||||
, sCurrency = c
|
, sCurrency = c
|
||||||
|
, sTags = taTags
|
||||||
}
|
}
|
||||||
|
|
||||||
checkAcntType
|
checkAcntType
|
||||||
|
@ -469,6 +473,7 @@ insertImport i = whenHash CTImport i [] $ \c -> do
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- low-level transaction stuff
|
-- low-level transaction stuff
|
||||||
|
|
||||||
|
-- TODO tags here?
|
||||||
txPair
|
txPair
|
||||||
:: MonadFinance m
|
:: MonadFinance m
|
||||||
=> Day
|
=> Day
|
||||||
|
@ -480,7 +485,7 @@ txPair
|
||||||
-> m (EitherErrs KeyTx)
|
-> m (EitherErrs KeyTx)
|
||||||
txPair day from to cur val desc = resolveTx tx
|
txPair day from to cur val desc = resolveTx tx
|
||||||
where
|
where
|
||||||
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur}
|
split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur, sTags = []}
|
||||||
tx =
|
tx =
|
||||||
Tx
|
Tx
|
||||||
{ txDescr = desc
|
{ txDescr = desc
|
||||||
|
@ -495,18 +500,22 @@ resolveTx t@Tx {txSplits = ss} = do
|
||||||
return $ fmap (\kss -> t {txSplits = kss}) res
|
return $ fmap (\kss -> t {txSplits = kss}) res
|
||||||
|
|
||||||
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit)
|
||||||
resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do
|
resolveSplit s@Split {sAcnt, sCurrency, sValue, sTags} = do
|
||||||
aid <- lookupAccountKey p
|
aid <- lookupAccountKey sAcnt
|
||||||
cid <- lookupCurrency c
|
cid <- lookupCurrency sCurrency
|
||||||
sign <- lookupAccountSign p
|
sign <- lookupAccountSign sAcnt
|
||||||
|
tags <- mapM lookupTag sTags
|
||||||
-- TODO correct sign here?
|
-- TODO correct sign here?
|
||||||
-- TODO lenses would be nice here
|
-- TODO lenses would be nice here
|
||||||
return $ concatEither3 aid cid sign $ \aid_ cid_ sign_ ->
|
return $
|
||||||
s
|
(concatEithers2 (concatEither3 aid cid sign (,,)) $ concatEitherL tags) $
|
||||||
{ sAcnt = aid_
|
\(aid_, cid_, sign_) tags_ ->
|
||||||
, sCurrency = cid_
|
s
|
||||||
, sValue = v * fromIntegral (sign2Int sign_)
|
{ sAcnt = aid_
|
||||||
}
|
, sCurrency = cid_
|
||||||
|
, sValue = sValue * fromIntegral (sign2Int sign_)
|
||||||
|
, sTags = tags_
|
||||||
|
}
|
||||||
|
|
||||||
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
insertTx :: MonadUnliftIO m => Key CommitR -> KeyTx -> SqlPersistT m ()
|
||||||
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
||||||
|
@ -514,8 +523,10 @@ insertTx c Tx {txDate = d, txDescr = e, txSplits = ss} = do
|
||||||
mapM_ (insertSplit k) ss
|
mapM_ (insertSplit k) ss
|
||||||
|
|
||||||
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
|
insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m (Key SplitR)
|
||||||
insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do
|
insertSplit t Split {sAcnt, sCurrency, sValue, sComment, sTags} = do
|
||||||
insert $ SplitR t cid aid c v
|
k <- insert $ SplitR t sCurrency sAcnt sComment sValue
|
||||||
|
mapM_ (insert_ . TagRelationR k) sTags
|
||||||
|
return k
|
||||||
|
|
||||||
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
|
lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType))
|
||||||
lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
|
lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount)
|
||||||
|
@ -532,6 +543,9 @@ lookupAccountType = fmap (fmap thdOf3) . lookupAccount
|
||||||
lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
|
lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR))
|
||||||
lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency)
|
lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency)
|
||||||
|
|
||||||
|
lookupTag :: MonadFinance m => TagID -> m (EitherErr (Key TagR))
|
||||||
|
lookupTag c = lookupErr (DBKey TagField) c <$> (askDBState kmTag)
|
||||||
|
|
||||||
-- TODO this hashes twice (not that it really matters)
|
-- TODO this hashes twice (not that it really matters)
|
||||||
whenHash
|
whenHash
|
||||||
:: (Hashable a, MonadFinance m)
|
:: (Hashable a, MonadFinance m)
|
||||||
|
|
|
@ -38,6 +38,7 @@ makeHaskellTypesWith
|
||||||
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
, MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType"
|
||||||
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
, MultipleConstructors "BudgetCurrency" "(./dhall/Types.dhall).BudgetCurrency"
|
||||||
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
, SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency"
|
||||||
|
, SingleConstructor "Tag" "Tag" "(./dhall/Types.dhall).Tag"
|
||||||
, 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"
|
||||||
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
, SingleConstructor "Interval" "Interval" "(./dhall/Types.dhall).Interval"
|
||||||
|
@ -56,6 +57,7 @@ makeHaskellTypesWith
|
||||||
, 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 "Exchange" "Exchange" "(./dhall/Types.dhall).Exchange"
|
||||||
|
, SingleConstructor "TaggedAcnt" "TaggedAcnt" "(./dhall/Types.dhall).TaggedAcnt"
|
||||||
, 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"
|
||||||
|
@ -70,6 +72,12 @@ deriving instance Lift Currency
|
||||||
|
|
||||||
deriving instance Hashable Currency
|
deriving instance Hashable Currency
|
||||||
|
|
||||||
|
deriving instance Eq Tag
|
||||||
|
|
||||||
|
deriving instance Lift Tag
|
||||||
|
|
||||||
|
deriving instance Hashable Tag
|
||||||
|
|
||||||
deriving instance Eq TimeUnit
|
deriving instance Eq TimeUnit
|
||||||
|
|
||||||
deriving instance Ord TimeUnit
|
deriving instance Ord TimeUnit
|
||||||
|
@ -166,6 +174,12 @@ deriving instance Eq Budget
|
||||||
|
|
||||||
deriving instance Hashable Budget
|
deriving instance Hashable Budget
|
||||||
|
|
||||||
|
deriving instance Eq TaggedAcnt
|
||||||
|
|
||||||
|
deriving instance Hashable TaggedAcnt
|
||||||
|
|
||||||
|
deriving instance Ord TaggedAcnt
|
||||||
|
|
||||||
deriving instance Eq Income
|
deriving instance Eq Income
|
||||||
|
|
||||||
deriving instance Hashable Income
|
deriving instance Hashable Income
|
||||||
|
@ -316,6 +330,7 @@ data Config_ a = Config_
|
||||||
, currencies :: ![Currency]
|
, currencies :: ![Currency]
|
||||||
, statements :: ![Statement]
|
, statements :: ![Statement]
|
||||||
, accounts :: !a
|
, accounts :: !a
|
||||||
|
, tags :: ![Tag]
|
||||||
, sqlConfig :: !SqlConfig
|
, sqlConfig :: !SqlConfig
|
||||||
}
|
}
|
||||||
deriving (Generic)
|
deriving (Generic)
|
||||||
|
@ -342,24 +357,30 @@ instance FromDhall a => FromDhall (Config_ a)
|
||||||
--------------------------------------------------------------------------------
|
--------------------------------------------------------------------------------
|
||||||
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
-- dhall type overrides (since dhall can't import types with parameters...yet)
|
||||||
|
|
||||||
|
-- TODO newtypes for these?
|
||||||
type AcntID = T.Text
|
type AcntID = T.Text
|
||||||
|
|
||||||
type CurID = T.Text
|
type CurID = T.Text
|
||||||
|
|
||||||
|
type TagID = T.Text
|
||||||
|
|
||||||
data Statement
|
data Statement
|
||||||
= StmtManual !Manual
|
= StmtManual !Manual
|
||||||
| StmtImport !Import
|
| StmtImport !Import
|
||||||
deriving (Eq, Hashable, Generic, FromDhall)
|
deriving (Eq, Hashable, Generic, FromDhall)
|
||||||
|
|
||||||
data Split a v c = Split
|
data Split a v c t = Split
|
||||||
{ sAcnt :: !a
|
{ sAcnt :: !a
|
||||||
, sValue :: !v
|
, sValue :: !v
|
||||||
, sCurrency :: !c
|
, sCurrency :: !c
|
||||||
, sComment :: !T.Text
|
, sComment :: !T.Text
|
||||||
|
, sTags :: ![t]
|
||||||
}
|
}
|
||||||
deriving (Eq, Generic, Hashable, Show, FromDhall)
|
deriving (Eq, Generic, Hashable, Show)
|
||||||
|
|
||||||
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur
|
type ExpSplit = Split SplitAcnt (Maybe SplitNum) SplitCur TagID
|
||||||
|
|
||||||
|
instance FromDhall ExpSplit
|
||||||
|
|
||||||
data Tx s = Tx
|
data Tx s = Tx
|
||||||
{ txDescr :: !T.Text
|
{ txDescr :: !T.Text
|
||||||
|
@ -459,6 +480,10 @@ CurrencyR sql=currencies
|
||||||
symbol T.Text
|
symbol T.Text
|
||||||
fullname T.Text
|
fullname T.Text
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
|
TagR sql=tags
|
||||||
|
symbol T.Text
|
||||||
|
fullname T.Text
|
||||||
|
deriving Show Eq
|
||||||
AccountR sql=accounts
|
AccountR sql=accounts
|
||||||
name T.Text
|
name T.Text
|
||||||
fullpath T.Text
|
fullpath T.Text
|
||||||
|
@ -481,6 +506,9 @@ SplitR sql=splits
|
||||||
memo T.Text
|
memo T.Text
|
||||||
value Rational
|
value Rational
|
||||||
deriving Show Eq
|
deriving Show Eq
|
||||||
|
TagRelationR sql=tag_relations
|
||||||
|
split SplitRId OnDeleteCascade
|
||||||
|
tag TagRId OnDeleteCascade
|
||||||
BudgetLabelR sql=budget_labels
|
BudgetLabelR sql=budget_labels
|
||||||
split SplitRId OnDeleteCascade
|
split SplitRId OnDeleteCascade
|
||||||
budgetName T.Text
|
budgetName T.Text
|
||||||
|
@ -515,9 +543,12 @@ type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType)
|
||||||
|
|
||||||
type CurrencyMap = M.Map CurID CurrencyRId
|
type CurrencyMap = M.Map CurID CurrencyRId
|
||||||
|
|
||||||
|
type TagMap = M.Map TagID TagRId
|
||||||
|
|
||||||
data DBState = DBState
|
data DBState = DBState
|
||||||
{ kmCurrency :: !CurrencyMap
|
{ kmCurrency :: !CurrencyMap
|
||||||
, kmAccount :: !AccountMap
|
, kmAccount :: !AccountMap
|
||||||
|
, kmTag :: !TagMap
|
||||||
, kmBudgetInterval :: !Bounds
|
, kmBudgetInterval :: !Bounds
|
||||||
, kmStatementInterval :: !Bounds
|
, kmStatementInterval :: !Bounds
|
||||||
, kmNewCommits :: ![Int]
|
, kmNewCommits :: ![Int]
|
||||||
|
@ -526,7 +557,7 @@ data DBState = DBState
|
||||||
|
|
||||||
type MappingT m = ReaderT DBState (SqlPersistT m)
|
type MappingT m = ReaderT DBState (SqlPersistT m)
|
||||||
|
|
||||||
type KeySplit = Split AccountRId Rational CurrencyRId
|
type KeySplit = Split AccountRId Rational CurrencyRId TagRId
|
||||||
|
|
||||||
type KeyTx = Tx KeySplit
|
type KeyTx = Tx KeySplit
|
||||||
|
|
||||||
|
@ -619,9 +650,9 @@ accountSign IncomeT = Credit
|
||||||
accountSign LiabilityT = Credit
|
accountSign LiabilityT = Credit
|
||||||
accountSign EquityT = Credit
|
accountSign EquityT = Credit
|
||||||
|
|
||||||
type RawSplit = Split AcntID (Maybe Rational) CurID
|
type RawSplit = Split AcntID (Maybe Rational) CurID TagID
|
||||||
|
|
||||||
type BalSplit = Split AcntID Rational CurID
|
type BalSplit = Split AcntID Rational CurID TagID
|
||||||
|
|
||||||
type RawTx = Tx RawSplit
|
type RawTx = Tx RawSplit
|
||||||
|
|
||||||
|
@ -636,7 +667,7 @@ data BalanceType = TooFewSplits | NotOneBlank deriving (Show)
|
||||||
|
|
||||||
data MatchType = MatchNumeric | MatchText deriving (Show)
|
data MatchType = MatchNumeric | MatchText deriving (Show)
|
||||||
|
|
||||||
data SplitIDType = AcntField | CurField deriving (Show)
|
data SplitIDType = AcntField | CurField | TagField deriving (Show)
|
||||||
|
|
||||||
data LookupSuberr
|
data LookupSuberr
|
||||||
= SplitIDField !SplitIDType
|
= SplitIDField !SplitIDType
|
||||||
|
|
|
@ -170,6 +170,7 @@ toTx sc sa toSplits r@TxRecord {trAmount, trDate, trDesc} =
|
||||||
, sCurrency = c_
|
, sCurrency = c_
|
||||||
, sValue = Just trAmount
|
, sValue = Just trAmount
|
||||||
, sComment = ""
|
, sComment = ""
|
||||||
|
, sTags = [] -- TODO what goes here?
|
||||||
}
|
}
|
||||||
in Tx
|
in Tx
|
||||||
{ txTags = []
|
{ txTags = []
|
||||||
|
@ -357,8 +358,10 @@ showError other = (: []) $ case other of
|
||||||
SplitValField -> "split value"
|
SplitValField -> "split 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
|
||||||
idName AcntField = "account"
|
idName AcntField = "account"
|
||||||
idName CurField = "currency"
|
idName CurField = "currency"
|
||||||
|
idName TagField = "tag"
|
||||||
matchName MatchNumeric = "numeric"
|
matchName MatchNumeric = "numeric"
|
||||||
matchName MatchText = "text"
|
matchName MatchText = "text"
|
||||||
(IncomeError dp) ->
|
(IncomeError dp) ->
|
||||||
|
|
Loading…
Reference in New Issue