diff --git a/dhall/Types.dhall b/dhall/Types.dhall index 1ae7e69..b33ac9a 100644 --- a/dhall/Types.dhall +++ b/dhall/Types.dhall @@ -193,9 +193,18 @@ let TimeAmount = { taWhen : DatePat, taAmt : Amount, taAmtType : AmountType } let Tax = { taxAcnt : AcntID, taxValue : Decimal } +let TransferTarget = + < ExpenseTarget : + { _1xtarget : + {- this is the only place expense accounts may be specified -} + AcntID + , _2xtarget : ExpenseBucket + } + | GenericTarget : AcntID + > + let Allocation = - { alloPath : AcntID - , alloBucket : ExpenseBucket + { alloPath : TransferTarget , alloAmts : List Amount , alloCurrency : CurID } @@ -204,17 +213,19 @@ let Income = { incGross : Decimal , incCurrency : CurID , incWhen : DatePat - , incFrom : AcntID + , incFrom : + {- this must be an income AcntID, and is the only place income + accounts may be specified in the entire budget -} + AcntID , incPretax : List Allocation , incTaxes : List Tax , incPosttax : List Allocation - , incToBal : AcntID + , incToBal : TransferTarget } let Transfer = { transFrom : AcntID - , transTo : AcntID - , transBucket : ExpenseBucket + , transTo : TransferTarget , transAmounts : List TimeAmount , transCurrency : CurID } @@ -267,4 +278,5 @@ in { CurID , Amount , TimeAmount , AmountType + , TransferTarget } diff --git a/lib/Internal/Database/Model.hs b/lib/Internal/Database/Model.hs index ea6b684..74790db 100644 --- a/lib/Internal/Database/Model.hs +++ b/lib/Internal/Database/Model.hs @@ -59,7 +59,7 @@ IncomeBucketR sql=income_buckets deriving Show Eq |] -type AccountMap = M.Map AcntID (AccountRId, AcntSign) +type AccountMap = M.Map AcntID (AccountRId, AcntSign, AcntType) type CurrencyMap = M.Map CurID CurrencyRId diff --git a/lib/Internal/Database/Ops.hs b/lib/Internal/Database/Ops.hs index 7d90a27..e961234 100644 --- a/lib/Internal/Database/Ops.hs +++ b/lib/Internal/Database/Ops.hs @@ -212,7 +212,7 @@ tree2Entity t parents name des = tree2Records :: AcntType -> AccountTree - -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign))]) + -> ([Entity AccountR], [AccountPathR], [(AcntPath, (AccountRId, AcntSign, AcntType))]) tree2Records t = go [] where go ps (Placeholder d n cs) = @@ -227,7 +227,7 @@ tree2Records t = go [] k = entityKey e in ( [acnt k n (fmap snd ps) d] , expand k $ fmap fst ps - , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign))] + , [(AcntPath t $ reverse $ n : fmap snd ps, (k, sign, t))] ) toPath = T.intercalate "/" . (atName t :) . reverse acnt k n ps = Entity k . AccountR n (toPath ps) diff --git a/lib/Internal/Insert.hs b/lib/Internal/Insert.hs index a91fe9b..e777a3c 100644 --- a/lib/Internal/Insert.hs +++ b/lib/Internal/Insert.hs @@ -7,6 +7,7 @@ where import Data.Hashable import Database.Persist.Class import Database.Persist.Sql hiding (Single, Statement) +import GHC.Utils.Misc hiding (split) import Internal.Database.Model import Internal.Statement import Internal.Types hiding (sign) @@ -14,6 +15,7 @@ import Internal.Utils import RIO hiding (to) import qualified RIO.List as L import qualified RIO.Map as M +import qualified RIO.NonEmpty as NE import qualified RIO.Text as T import RIO.Time @@ -95,12 +97,13 @@ dayToWeekday (ModifiedJulianDay d) = mod (fromIntegral d + 2) 7 withDates :: MonadFinance m => DatePat - -> (Day -> SqlPersistT m a) + -> (Day -> SqlPersistT m (EitherErrs a)) -> SqlPersistT m (EitherErrs [a]) withDates dp f = do bounds <- lift $ askDBState kmBudgetInterval - let days = expandDatePat bounds dp - mapM (mapM f) days + case expandDatePat bounds dp of + Left es -> return $ Left es + Right days -> concatEithersL <$> mapM f days -------------------------------------------------------------------------------- -- budget @@ -159,55 +162,88 @@ insertIncome :: MonadFinance m => T.Text -> Income -> SqlPersistT m (EitherErrs insertIncome name i@Income {incWhen, incCurrency, incFrom, incPretax, incPosttax, incTaxes, incToBal} = - whenHash CTIncome i (Right []) $ \c -> case (balanceIncome i) of - Left e -> return $ Left [e] - Right balance -> - fmap (fmap concat) $ withDates incWhen $ \day -> do - let meta = BudgetMeta c day incCurrency name - let fromAllos b = concatMap (fromAllo meta incFrom (Just b)) - let pre = fromAllos PreTax incPretax - let tax = fmap (fromTax meta incFrom) incTaxes - let post = fromAllos PostTax incPosttax - let bal = - TransferTx - { trxMeta = meta - , trxFrom = BudgetSplit incFrom $ Just PostTax - , trxTo = BudgetSplit incToBal Nothing - , trxValue = balance - , trxType = FixedAmt - , trxDesc = "balance after deductions" - } - return $ bal : (pre ++ tax ++ post) + whenHash CTIncome i (Right []) $ \c -> do + let balRes = balanceIncome i + fromRes <- lift $ checkAcntType IncomeT incFrom (\j -> BudgetSplit j . Just) + toRes <- lift $ expandTarget incToBal + case concatEither3 balRes fromRes toRes (,,) of + Left es -> return $ Left es + Right (balance, fromFun, to) -> + fmap (fmap (concat . concat)) $ + withDates incWhen $ \day -> do + let meta = BudgetMeta c day incCurrency name + let fromAllos b = + fmap (fmap concat . concatEitherL) + . mapM (lift . fromAllo meta (fromFun b)) + pre <- fromAllos PreTax incPretax + tax <- + concatEitherL + <$> mapM (lift . fromTax meta (fromFun IntraTax)) incTaxes + post <- fromAllos PostTax incPosttax + let bal = + TransferTx + { trxMeta = meta + , trxFrom = fromFun PostTax + , trxTo = to + , trxValue = balance + , trxType = FixedAmt + , trxDesc = "balance after deductions" + } + return $ concatEithersL [Right [bal], tax, pre, post] fromAllo - :: BudgetMeta - -> AcntID - -> Maybe IncomeBucket + :: MonadFinance m + => BudgetMeta + -> BudgetSplit IncomeBucket -> Allocation - -> [TransferTx] -fromAllo meta from ib Allocation {alloPath, alloAmts, alloBucket} = - fmap (toBT alloPath) alloAmts + -> m (EitherErr [TransferTx]) +fromAllo meta from Allocation {alloPath, alloAmts} = do + -- TODO this is going to be repeated a zillion times (might matter) + res <- expandTarget alloPath + return $ (\to -> fmap (toBT to) alloAmts) <$> res where toBT to (Amount desc v) = TransferTx - { trxFrom = BudgetSplit from ib - , trxTo = BudgetSplit to $ Just alloBucket + { trxFrom = from + , trxTo = to , trxValue = dec2Rat v , trxDesc = desc , trxType = FixedAmt , trxMeta = meta } -fromTax :: BudgetMeta -> AcntID -> Tax -> TransferTx +expandTarget :: MonadFinance m => TransferTarget -> m (EitherErr (BudgetSplit ExpenseBucket)) +expandTarget t = case t of + ExpenseTarget i b -> checkAcntType ExpenseT i $ (`BudgetSplit` (Just b)) + GenericTarget i -> checkAcntTypes (LiabilityT :| [AssetT, EquityT]) i $ (`BudgetSplit` Nothing) + +checkAcntType :: MonadFinance m => AcntType -> AcntID -> (AcntID -> a) -> m (EitherErr a) +checkAcntType t = checkAcntTypes (t :| []) + +checkAcntTypes :: MonadFinance m => NE.NonEmpty AcntType -> AcntID -> (AcntID -> a) -> m (EitherErr a) +checkAcntTypes ts i f = (go =<<) <$> lookupAccountType i + where + go t + | t `L.elem` ts = Right $ f i + | otherwise = Left $ AccountError i t + +fromTax + :: MonadFinance m + => BudgetMeta + -> BudgetSplit IncomeBucket + -> Tax + -> m (EitherErr TransferTx) fromTax meta from Tax {taxAcnt = to, taxValue = v} = - TransferTx - { trxFrom = BudgetSplit from (Just IntraTax) - , trxTo = BudgetSplit to (Just Fixed) - , trxValue = dec2Rat v - , trxDesc = "" - , trxType = FixedAmt - , trxMeta = meta - } + -- TODO this is going to be repeated a zillion times (might matter) + checkAcntType ExpenseT to $ \to_ -> + TransferTx + { trxFrom = from + , trxTo = BudgetSplit to_ (Just Fixed) + , trxValue = dec2Rat v + , trxDesc = "" + , trxType = FixedAmt + , trxMeta = meta + } balanceIncome :: Income -> EitherErr Rational balanceIncome @@ -234,7 +270,6 @@ expandTransfers name ts = do txs <- mapM (expandTransfer name) ts return $ L.sortOn (bmWhen . trxMeta) . concat <$> concatEithersL txs --- TODO the entire budget needs to have this process applied to it balanceTransfers :: [TransferTx] -> [BudgetTx] balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta) ts where @@ -268,30 +303,35 @@ balanceTransfers ts = snd $ L.mapAccumR go initBals $ L.sortOn (bmWhen . trxMeta expandTransfer :: MonadFinance m => T.Text -> Transfer -> SqlPersistT m (EitherErrs [TransferTx]) expandTransfer name t@Transfer {transAmounts, transTo, transCurrency, transFrom} = - whenHash CTExpense t (Right []) $ \key -> do - res <- forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> - withDates pat $ \day -> - let meta = - BudgetMeta - { bmWhen = day - , bmCur = transCurrency - , bmCommit = key - , bmName = name - } - in return $ - TransferTx - { trxMeta = meta - , trxFrom = BudgetSplit transFrom Nothing - , trxTo = BudgetSplit transTo Nothing - , trxValue = dec2Rat v - , trxType = atype - , trxDesc = desc - } - return $ concat <$> concatEithersL res + whenHash CTExpense t (Right []) $ \key -> + fmap (fmap concat . concatEithersL) $ + forM transAmounts $ \(TimeAmount (Amount desc v) atype pat) -> do + -- TODO this is going to be repeated a zillion times (might matter) + res <- lift $ expandTarget transTo + case res of + Left e -> return $ Left [e] + Right to -> withDates pat $ \day -> + let meta = + BudgetMeta + { bmWhen = day + , bmCur = transCurrency + , bmCommit = key + , bmName = name + } + tx = + TransferTx + { trxMeta = meta + , trxFrom = BudgetSplit transFrom Nothing + , trxTo = to + , trxValue = dec2Rat v + , trxType = atype + , trxDesc = desc + } + in return $ Right tx insertBudgetTx :: MonadFinance m => BudgetTx -> SqlPersistT m [InsertError] insertBudgetTx BudgetTx {btFrom, btTo, btMeta, btValue, btDesc} = do - res <- splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue + res <- lift $ splitPair (bsAcnt btFrom) (bsAcnt btTo) (bmCur btMeta) btValue unlessLefts_ res $ \(sFrom, sTo) -> do k <- insert $ TransactionR (bmCommit btMeta) (bmWhen btMeta) btDesc insertBudgetLabel name k IncomeBucketR sFrom btFrom @@ -318,7 +358,7 @@ splitPair -> AcntID -> CurID -> Rational - -> SqlPersistT m (EitherErrs (KeySplit, KeySplit)) + -> m (EitherErrs (KeySplit, KeySplit)) splitPair from to cur val = do s1 <- split from (-val) s2 <- split to val @@ -358,7 +398,7 @@ insertManual -- let days = expandDatePat bounds dp let dayRes = expandDatePat bounds dp unlessLefts dayRes $ \days -> do - txRes <- mapM tx days + txRes <- mapM (lift . tx) days unlessLefts_ (concatEithersL txRes) $ mapM_ (insertTx c) where tx day = txPair day from to u (dec2Rat v) e @@ -369,7 +409,7 @@ insertImport i = whenHash CTImport i [] $ \c -> do -- transactions will be desired recoverIO (lift $ readImport i) $ \r -> unlessLefts r $ \bs -> do bounds <- expandBounds <$> lift (askDBState kmStatementInterval) - res <- mapM resolveTx $ filter (inBounds bounds . txDate) bs + res <- mapM (lift . resolveTx) $ filter (inBounds bounds . txDate) bs unlessLefts_ (concatEithersL res) $ mapM_ (insertTx c) where recoverIO x rest = do @@ -391,7 +431,7 @@ txPair -> CurID -> Rational -> T.Text - -> SqlPersistT m (EitherErrs KeyTx) + -> m (EitherErrs KeyTx) txPair day from to cur val desc = resolveTx tx where split a v = Split {sAcnt = a, sValue = v, sComment = "", sCurrency = cur} @@ -403,12 +443,12 @@ txPair day from to cur val desc = resolveTx tx , txSplits = [split from (-val), split to val] } -resolveTx :: MonadFinance m => BalTx -> SqlPersistT m (EitherErrs KeyTx) +resolveTx :: MonadFinance m => BalTx -> m (EitherErrs KeyTx) resolveTx t@Tx {txSplits = ss} = do res <- concatEithersL <$> mapM resolveSplit ss return $ fmap (\kss -> t {txSplits = kss}) res -resolveSplit :: MonadFinance m => BalSplit -> SqlPersistT m (EitherErrs KeySplit) +resolveSplit :: MonadFinance m => BalSplit -> m (EitherErrs KeySplit) resolveSplit s@Split {sAcnt = p, sCurrency = c, sValue = v} = do aid <- lookupAccountKey p cid <- lookupCurrency c @@ -431,17 +471,20 @@ insertSplit :: MonadUnliftIO m => Key TransactionR -> KeySplit -> SqlPersistT m insertSplit t Split {sAcnt = aid, sCurrency = cid, sValue = v, sComment = c} = do insert $ SplitR t cid aid c v -lookupAccount :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR, AcntSign)) -lookupAccount p = lookupErr (DBKey AcntField) p <$> lift (askDBState kmAccount) +lookupAccount :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR, AcntSign, AcntType)) +lookupAccount p = lookupErr (DBKey AcntField) p <$> (askDBState kmAccount) -lookupAccountKey :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr (Key AccountR)) -lookupAccountKey = fmap (fmap fst) . lookupAccount +lookupAccountKey :: MonadFinance m => AcntID -> m (EitherErr (Key AccountR)) +lookupAccountKey = (fmap (fmap fstOf3)) . lookupAccount -lookupAccountSign :: MonadFinance m => AcntID -> SqlPersistT m (EitherErr AcntSign) -lookupAccountSign = fmap (fmap snd) . lookupAccount +lookupAccountSign :: MonadFinance m => AcntID -> m (EitherErr AcntSign) +lookupAccountSign = fmap (fmap sndOf3) . lookupAccount -lookupCurrency :: MonadFinance m => T.Text -> SqlPersistT m (EitherErr (Key CurrencyR)) -lookupCurrency c = lookupErr (DBKey CurField) c <$> lift (askDBState kmCurrency) +lookupAccountType :: MonadFinance m => AcntID -> m (EitherErr AcntType) +lookupAccountType = fmap (fmap thdOf3) . lookupAccount + +lookupCurrency :: MonadFinance m => T.Text -> m (EitherErr (Key CurrencyR)) +lookupCurrency c = lookupErr (DBKey CurField) c <$> (askDBState kmCurrency) -- TODO this hashes twice (not that it really matters) whenHash diff --git a/lib/Internal/Types.hs b/lib/Internal/Types.hs index 605d7be..e0ae9d7 100644 --- a/lib/Internal/Types.hs +++ b/lib/Internal/Types.hs @@ -34,6 +34,7 @@ makeHaskellTypesWith , MultipleConstructors "ExpenseBucket" "(./dhall/Types.dhall).ExpenseBucket" , MultipleConstructors "IncomeBucket" "(./dhall/Types.dhall).IncomeBucket" , MultipleConstructors "AmountType" "(./dhall/Types.dhall).AmountType" + , MultipleConstructors "TransferTarget" "(./dhall/Types.dhall).TransferTarget" , SingleConstructor "Currency" "Currency" "(./dhall/Types.dhall).Currency" , SingleConstructor "Gregorian" "Gregorian" "(./dhall/Types.dhall).Gregorian" , SingleConstructor "GregorianM" "GregorianM" "(./dhall/Types.dhall).GregorianM" @@ -50,8 +51,8 @@ makeHaskellTypesWith , SingleConstructor "TimeAmount" "TimeAmount" "(./dhall/Types.dhall).TimeAmount" , SingleConstructor "Allocation" "Allocation" "(./dhall/Types.dhall).Allocation" , SingleConstructor "Income" "Income" "(./dhall/Types.dhall).Income" - , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer" , SingleConstructor "Budget" "Budget" "(./dhall/Types.dhall).Budget" + , SingleConstructor "Transfer" "Transfer" "(./dhall/Types.dhall).Transfer" ] ------------------------------------------------------------------------------- @@ -300,6 +301,10 @@ deriving instance Eq TimeAmount deriving instance Hashable TimeAmount +deriving instance Eq TransferTarget + +deriving instance Hashable TransferTarget + deriving instance Eq Transfer deriving instance Hashable Transfer @@ -582,6 +587,7 @@ data PatternSuberr = ZeroLength | ZeroRepeats deriving (Show) data InsertError = RegexError !T.Text | MatchValPrecisionError !Natural !Natural + | AccountError !AcntID !AcntType | InsertIOError !T.Text | ParseError !T.Text | ConversionError !T.Text diff --git a/lib/Internal/Utils.hs b/lib/Internal/Utils.hs index eda228c..a4c493e 100644 --- a/lib/Internal/Utils.hs +++ b/lib/Internal/Utils.hs @@ -9,10 +9,13 @@ module Internal.Utils , leftToMaybe , dec2Rat , concatEithers2 + , concatEithers3 , concatEither3 , concatEither2 , concatEitherL , concatEithersL + , concatEither2M + , concatEithers2M , parseRational , showError , unlessLeft_ @@ -23,7 +26,8 @@ module Internal.Utils , showT , lookupErr , gregorians - , uncurry3 + -- , uncurry3 + , xGregToDay , plural , compileMatch @@ -313,6 +317,8 @@ showError other = (: []) $ case other of where showGreg (Just g) = showGregorian_ g showGreg Nothing = "Inf" + -- TODO define + (AccountError _ _) -> undefined (PatternError s b r p) -> T.unwords [msg, "in pattern: ", pat] where pat = @@ -478,6 +484,11 @@ concatEither2 a b fun = case (a, b) of (Right a_, Right b_) -> Right $ fun a_ b_ _ -> Left $ catMaybes [leftToMaybe a, leftToMaybe b] +concatEither2M :: Monad m => Either x a -> Either x b -> (a -> b -> m c) -> m (Either [x] c) +concatEither2M a b fun = case (a, b) of + (Right a_, Right b_) -> Right <$> fun a_ b_ + _ -> return $ Left $ catMaybes [leftToMaybe a, leftToMaybe b] + concatEither3 :: Either x a -> Either x b -> Either x c -> (a -> b -> c -> d) -> Either [x] d concatEither3 a b c fun = case (a, b, c) of (Right a_, Right b_, Right c_) -> Right $ fun a_ b_ c_ @@ -486,13 +497,21 @@ concatEither3 a b c fun = case (a, b, c) of concatEithers2 :: Either [x] a -> Either [x] b -> (a -> b -> c) -> Either [x] c concatEithers2 a b = merge . concatEither2 a b --- concatEithers3 --- :: Either [x] a --- -> Either [x] b --- -> Either [x] c --- -> (a -> b -> c -> d) --- -> Either [x] d --- concatEithers3 a b c = merge . concatEither3 a b c +concatEithers2M + :: Monad m + => Either [x] a + -> Either [x] b + -> (a -> b -> m c) + -> m (Either [x] c) +concatEithers2M a b = fmap merge . concatEither2M a b + +concatEithers3 + :: Either [x] a + -> Either [x] b + -> Either [x] c + -> (a -> b -> c -> d) + -> Either [x] d +concatEithers3 a b c = merge . concatEither3 a b c concatEitherL :: [Either x a] -> Either [x] [a] concatEitherL as = case partitionEithers as of