From 151cf4d90f652fb8057534ef66a47103d21b0237 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Wed, 17 Sep 2025 12:02:38 +0800 Subject: [PATCH 1/2] update --- shell.nix | 1 + src/Deal/DealCollection.hs | 13 ++++++++----- src/Deal/DealRun.hs | 8 +++++--- src/Types.hs | 6 +++--- 4 files changed, 17 insertions(+), 11 deletions(-) diff --git a/shell.nix b/shell.nix index 022b7370..fd40c0e1 100644 --- a/shell.nix +++ b/shell.nix @@ -5,6 +5,7 @@ pkgs.mkShell { cabal2nix haskell.compiler.ghc912 haskell-language-server + python313Packages.towncrier ghciwatch just ]; diff --git a/src/Deal/DealCollection.hs b/src/Deal/DealCollection.hs index 4cd85075..0e7733a9 100644 --- a/src/Deal/DealCollection.hs +++ b/src/Deal/DealCollection.hs @@ -26,9 +26,12 @@ import Util import Lib import Control.Lens hiding (element) -data CollectionRule = Collect (Maybe [PoolId]) PoolSource AccountName -- ^ collect a pool source from pool collection and deposit to an account - | CollectByPct (Maybe [PoolId]) PoolSource [(Rate,AccountName)] -- ^ collect a pool source from pool collection and deposit to multiple accounts with percentages - deriving (Show,Generic,Eq,Ord) +data CollectionRule + -- | collect a pool source from pool collection and deposit to an account + = Collect (Maybe [PoolId]) PoolSource AccountName + -- | collect a pool source from pool collection and deposit to multiple accounts with percentages + | CollectByPct (Maybe [PoolId]) PoolSource [(Rate,AccountName)] + deriving (Show,Generic,Eq,Ord) readProceeds :: PoolSource -> CF.TsRow -> Either ErrorRep Balance @@ -55,7 +58,7 @@ extractTxnsFromFlowFrameMap mPids pflowMap = -- ^ deposit cash to account by collection rule -depositInflow :: Date -> CollectionRule -> Map.Map PoolId CF.PoolCashflow -> Map.Map AccountName A.Account -> Either String (Map.Map AccountName A.Account) +depositInflow :: Date -> CollectionRule -> Map.Map PoolId CF.PoolCashflow -> Map.Map AccountName A.Account -> Either ErrorRep (Map.Map AccountName A.Account) depositInflow d (Collect mPids s an) pFlowMap amap = do amts <- traverse (readProceeds s) txns @@ -81,7 +84,7 @@ depositInflow d (CollectByPct mPids s splitRules) pFlowMap amap --TODO need t -- ^ deposit cash to account by pool map CF and rules -depositPoolFlow :: [CollectionRule] -> Date -> Map.Map PoolId CF.PoolCashflow -> Map.Map String A.Account -> Either String (Map.Map String A.Account) +depositPoolFlow :: [CollectionRule] -> Date -> Map.Map PoolId CF.PoolCashflow -> Map.Map String A.Account -> Either ErrorRep (Map.Map String A.Account) depositPoolFlow rules d pFlowMap amap = foldM (\acc rule -> depositInflow d rule pFlowMap acc) amap rules diff --git a/src/Deal/DealRun.hs b/src/Deal/DealRun.hs index 55bbe0f8..72c22682 100644 --- a/src/Deal/DealRun.hs +++ b/src/Deal/DealRun.hs @@ -311,15 +311,17 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= poolFlowMap collectedFlow = Map.map (bimap fst ((\xs -> [ fst x | x <- xs ]) <$>)) cutOffPoolFlowMap outstandingFlow = Map.map (bimap snd ((\xs -> [ snd x | x <- xs ]) <$>)) cutOffPoolFlowMap - + cutFutureCf = cutBy Exc Future d -- deposit cashflow to SPV from external pool cf in do accs <- depositPoolFlow (collects t) d collectedFlow accMap let dAfterDeposit = (appendCollectedCF d t collectedFlow) {accounts=accs} let newPt = case pool dAfterDeposit of - MultiPool pm -> MultiPool $ (over (mapped . P.poolFutureScheduleCf . _Just . _1 . CF.cashflowTxn) (cutBy Exc Future d)) pm - ResecDeal dMap -> ResecDeal $ (over (mapped . uDealFutureScheduleCf . _Just . CF.cashflowTxn) (cutBy Exc Future d)) dMap + MultiPool pm -> + MultiPool $ (over (mapped . P.poolFutureScheduleCf . _Just . _1 . CF.cashflowTxn) cutFutureCf) pm + ResecDeal dMap -> + ResecDeal $ (over (mapped . uDealFutureScheduleCf . _Just . CF.cashflowTxn) cutFutureCf) dMap let runContext = RunContext outstandingFlow rAssump rates (dRunWithTrigger0, rc1, ads2, newLogs0) <- runTriggers (dAfterDeposit {pool = newPt},runContext,ads) d EndCollection let eopActionsLog = DL.fromList [ RunningWaterfall d W.EndOfPoolCollection | Map.member W.EndOfPoolCollection waterfallM ] diff --git a/src/Types.hs b/src/Types.hs index a876f3c5..aba7f6d1 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -205,8 +205,8 @@ data DayCount = DC_30E_360 -- ^ ISMA European 30S/360 Special German Eurob data DateType = ClosingDate -- ^ deal closing day | CutoffDate -- ^ after which, the pool cashflow was aggregated to SPV | FirstPayDate -- ^ first payment day for bond/waterfall to run with - | NextPayDate - | NextCollectDate + | NextPayDate -- ^ next payment day for bond/waterfall to run + | NextCollectDate -- ^ next collection day for pool | FirstCollectDate -- ^ first collection day for pool | LastCollectDate -- ^ last collection day for pool | LastPayDate -- ^ last payment day for bond/waterfall @@ -249,7 +249,7 @@ data Period = Daily | Quarterly | SemiAnnually | Annually - deriving (Show,Eq,Generic,Ord) + deriving (Show, Eq, Generic, Ord) type DateVector = (Date, DatePattern) From 2cd4130d25e0c54665878e53adfc13710b8157eb Mon Sep 17 00:00:00 2001 From: yellowbean Date: Thu, 18 Sep 2025 00:18:54 +0800 Subject: [PATCH 2/2] UT for refactor on ledger booking --- src/Accounts.hs | 6 +- src/Asset.hs | 14 +++-- src/Call.hs | 33 ++++++---- src/Cashflow.hs | 2 - src/Deal/DealAction.hs | 18 +++--- src/Deal/DealQuery.hs | 17 +++-- src/Deal/DealRun.hs | 6 +- src/Ledger.hs | 140 +++++++++++++++++++---------------------- src/Pool.hs | 13 ++-- src/Stmt.hs | 15 +++-- src/Types.hs | 2 +- test/MainTest.hs | 2 + test/UT/LedgerTest.hs | 77 +++++++++++++++++++++++ 13 files changed, 217 insertions(+), 128 deletions(-) create mode 100644 test/UT/LedgerTest.hs diff --git a/src/Accounts.hs b/src/Accounts.hs index 0272253c..164a8fb8 100644 --- a/src/Accounts.hs +++ b/src/Accounts.hs @@ -52,14 +52,14 @@ data ReserveAmount data Account = Account { accBalance :: Balance -- ^ account current balance - ,accName :: String -- ^ account name + ,accName :: AccountName -- ^ account name ,accInterest :: Maybe InterestInfo -- ^ account reinvestment interest ,accType :: Maybe ReserveAmount -- ^ target info if a reserve account ,accStmt :: Maybe Statement -- ^ transactional history } deriving (Show, Generic, Eq, Ord) -- | build interest earn actions -buildEarnIntAction :: [Account] -> Date -> [(String,Dates)] -> [(String,Dates)] +buildEarnIntAction :: [Account] -> Date -> [(AccountName,Dates)] -> [(AccountName,Dates)] buildEarnIntAction [] ed r = r buildEarnIntAction (acc:accs) ed r = case accInterest acc of @@ -69,6 +69,8 @@ buildEarnIntAction (acc:accs) ed r = Just (InvestmentAccount _ _ dp _ lastAccDate _) -> buildEarnIntAction accs ed [(accName acc, genSerialDatesTill2 NO_IE lastAccDate dp ed)]++r + +-- | accrue interest from last reset date to today accrueInt :: Date -> Account -> Balance accrueInt _ (Account _ _ Nothing _ _) = 0 -- ^ bank account type interest diff --git a/src/Asset.hs b/src/Asset.hs index b0d16c8f..ee3783c8 100644 --- a/src/Asset.hs +++ b/src/Asset.hs @@ -157,11 +157,15 @@ applyExtraStress Nothing _ ppy def = (ppy,def) applyExtraStress (Just ExtraStress{A.defaultFactors= mDefFactor ,A.prepaymentFactors = mPrepayFactor}) ds ppy def = case (mPrepayFactor,mDefFactor) of - (Nothing,Nothing) -> (ppy,def) - (Nothing,Just defFactor) -> (ppy ,getTsVals $ multiplyTs Exc (zipTs ds def) defFactor) - (Just ppyFactor,Nothing) -> (getTsVals $ multiplyTs Exc (zipTs ds ppy) ppyFactor, def) - (Just ppyFactor,Just defFactor) -> (getTsVals $ multiplyTs Exc (zipTs ds ppy) ppyFactor - ,getTsVals $ multiplyTs Exc (zipTs ds def) defFactor) + (Nothing,Nothing) + -> (ppy,def) + (Nothing,Just defFactor) + -> (ppy ,getTsVals $ multiplyTs Exc (zipTs ds def) defFactor) + (Just ppyFactor,Nothing) + -> (getTsVals $ multiplyTs Exc (zipTs ds ppy) ppyFactor, def) + (Just ppyFactor,Just defFactor) + -> (getTsVals $ multiplyTs Exc (zipTs ds ppy) ppyFactor + ,getTsVals $ multiplyTs Exc (zipTs ds def) defFactor) -- ^ convert annual CPR to single month mortality cpr2smm :: Rate -> Rate diff --git a/src/Call.hs b/src/Call.hs index 9f2ba84e..21fbe017 100644 --- a/src/Call.hs +++ b/src/Call.hs @@ -14,16 +14,27 @@ import Data.Aeson.TH import Data.Aeson.Types import GHC.Generics -data CallOption = PoolBalance Balance -- ^ triggered when pool perform balance below threshold - | BondBalance Balance -- ^ triggered when bond current balance below threshold - | PoolFactor Rate -- ^ triggered when pool factor (pool perform balance/origin balance) - | BondFactor Rate -- ^ triggered when bond factor (total bonds current balance / origin balance) - | OnDate Date -- ^ triggered at date - | AfterDate Date -- ^ triggered when after date - | And [CallOption] -- ^ triggered when all options were satisfied - | Or [CallOption] -- ^ triggered when any option is satisfied - | PoolPv Balance -- ^ Call when PV of pool fall below - | Pre Pre -- ^ triggered when predicate evaluates to be True - deriving (Show,Generic,Ord,Eq,Read) +data CallOption + -- | triggered when pool perform balance below threshold + = PoolBalance Balance + -- | triggered when bond current balance below threshold + | BondBalance Balance + -- | triggered when pool factor (pool perform balance/origin balance) + | PoolFactor Rate + -- | triggered when bond factor (total bonds current balance / origin balance) + | BondFactor Rate + -- | triggered at date + | OnDate Date + -- | triggered when after date + | AfterDate Date + -- | triggered when all options were satisfied + | And [CallOption] + -- | triggered when any option is satisfied + | Or [CallOption] + -- | Call when PV of pool fall below + | PoolPv Balance + -- | triggered when predicate evaluates to be True + | Pre Pre + deriving (Show,Generic,Ord,Eq,Read) $(deriveJSON defaultOptions ''CallOption) diff --git a/src/Cashflow.hs b/src/Cashflow.hs index 2c0ad7fc..2980d8e0 100644 --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -110,7 +110,6 @@ type NewDepreciation = Balance type AccuredFee = Balance type FeePaid = Balance -startOfTime = T.fromGregorian 1900 1 1 data TsRow = CashFlow Date Amount | BondFlow Date Balance Principal Interest @@ -120,7 +119,6 @@ data TsRow = CashFlow Date Amount | LeaseFlow Date Balance Rental Default | FixedFlow Date Balance NewDepreciation Depreciation Balance Balance -- unit cash | ReceivableFlow Date Balance AccuredFee Principal FeePaid Default Recovery Loss (Maybe CumulativeStat) - -- | MixedCashflow Date Balance Principal Interest Prepayment deriving(Show,Eq,Ord,Generic,NFData) instance Semigroup TsRow where diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index 22a47c78..fe1a0eb9 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -468,7 +468,9 @@ drawExtraSupport d amt (W.SupportAccount an (Just (dr, ln))) t@TestDeal{accounts let drawAmt = min (A.accBalance acc) amt let oustandingAmt = amt - drawAmt newAccMap <- adjustM (A.draw d drawAmt Types.SupportDraw) an accMap - return (t {accounts = newAccMap ,ledgers = Just $ Map.adjust (LD.entryLog drawAmt d (TxnDirection dr)) ln ledgerMap} , oustandingAmt) + return (t {accounts = newAccMap + ,ledgers = Just $ Map.adjust (LD.entryLogByDr (dr,drawAmt) d Nothing) ln ledgerMap} + , oustandingAmt) -- ^ draw account support drawExtraSupport d amt (W.SupportAccount an Nothing) t@TestDeal{accounts=accMap} @@ -790,7 +792,7 @@ performAction d t@TestDeal{accounts=accMap, ledgers = Just ledgerM} targetAcc <- lookupM an2 accMap (transferAmt,accDrawAmt,_) <- calcAvailAfterLimit t d sourceAcc Nothing (A.accBalance sourceAcc) mLimit (sourceAcc', targetAcc') <- A.transfer (sourceAcc,targetAcc) d transferAmt - let newLedgerM = Map.adjust (LD.entryLog transferAmt d (TxnDirection dr)) lName ledgerM + let newLedgerM = Map.adjust (LD.entryLogByDr (dr, transferAmt) d Nothing) lName ledgerM return t {accounts = Map.insert an1 sourceAcc' (Map.insert an2 targetAcc' accMap) , ledgers = Just newLedgerM} @@ -815,13 +817,13 @@ performAction d t@TestDeal{ledgers= Just ledgerM} (W.BookBy (W.Till ledger dr ds targetAmt <- queryCompound t d ds ledgerI <- lookupM ledger ledgerM let (bookDirection, amtToBook) = LD.bookToTarget ledgerI (dr, fromRational targetAmt) - let newLedgerM = Map.adjust (LD.entryLogByDr bookDirection amtToBook d Nothing) ledger ledgerM + let newLedgerM = Map.adjust (LD.entryLogByDr (bookDirection,amtToBook) d Nothing) ledger ledgerM return $ t {ledgers = Just newLedgerM } performAction d t@TestDeal{ledgers= Just ledgerM} (W.BookBy (W.ByDS ledger dr ds)) = do amtToBook <- queryCompound t d ds - let newLedgerM = Map.adjust (LD.entryLogByDr dr (fromRational amtToBook) d Nothing) ledger ledgerM + let newLedgerM = Map.adjust (LD.entryLogByDr (dr,(fromRational amtToBook)) d Nothing) ledger ledgerM return $ t {ledgers = Just newLedgerM } -- ^ it will book ledgers by order with mandatory caps which describes by a @@ -836,7 +838,7 @@ performAction d t@TestDeal{ledgers= Just ledgerM} (W.BookBy (W.PDL dr ds ledgers ledgCaps <- sequenceA [ queryCompound t d ledgerCap | ledgerCap <- snd <$> ledgersList ] let amtBookedToLedgers = paySeqLiabilitiesAmt (fromRational amtToBook) (fromRational <$> ledgCaps) let newLedgerM = foldr - (\(ln,amt) acc -> Map.adjust (LD.entryLogByDr dr amt d Nothing) ln acc) + (\(ln,amt) acc -> Map.adjust (LD.entryLogByDr (dr,amt) d Nothing) ln acc) ledgerM (zip ledgerNames amtBookedToLedgers) --`debug` ("amts to book"++ show amtBookedToLedgers) return $ t {ledgers = Just newLedgerM} @@ -965,7 +967,7 @@ performAction d t@TestDeal{bonds=bndMap,accounts=accMap,ledgers= Just ledgerM} let totalDue = sum dueAmts (paidOutAmt,accPaidOut,supportPaidOut) <- calcAvailAfterLimit t d acc mSupport totalDue mLimit (bondsPaid,_) <- payProM d paidOutAmt qFn (pay d q) bndsList - let newLedgerM = Map.adjust (LD.entryLogByDr dr paidOutAmt d Nothing) lName ledgerM + let newLedgerM = Map.adjust (LD.entryLogByDr (dr,paidOutAmt) d Nothing) lName ledgerM newAccMap <- adjustM (A.draw d accPaidOut (PayInt bnds)) an accMap let dealAfterAcc = t {accounts = newAccMap @@ -1194,7 +1196,7 @@ performAction d t@TestDeal{bonds = bndMap, ledgers = Just ledgerM } bndToWriteOff <- lookupM bnd bndMap let bndBal = L.bndBalance bndToWriteOff writeAmt <- applyLimit t d bndBal bndBal mLimit - let newLedgerM = Map.adjust (LD.entryLogByDr dr writeAmt d (Just (WriteOff bnd writeAmt))) lName ledgerM + let newLedgerM = Map.adjust (LD.entryLogByDr (dr,writeAmt) d (Just (WriteOff bnd writeAmt))) lName ledgerM bndWritedOff <- writeOff d DuePrincipal writeAmt bndToWriteOff return $ t {bonds = Map.fromList [(bnd,bndWritedOff)] <> bndMap, ledgers = Just newLedgerM} @@ -1220,7 +1222,7 @@ performAction d t@TestDeal{bonds=bndMap, ledgers = Just ledgerM} writeAmt <- applyLimit t d totalBondBal totalBondBal mLimit (bndWrited, _) <- paySeqM d writeAmt L.bndBalance (writeOff d DuePrincipal) (Right []) bndsToWriteOff let bndMapUpdated = lstToMapByFn L.bndName bndWrited - let newLedgerM = Map.adjust (LD.entryLogByDr dr writeAmt d Nothing) lName ledgerM + let newLedgerM = Map.adjust (LD.entryLogByDr (dr,writeAmt) d Nothing) lName ledgerM return t {bonds = bndMapUpdated <> bndMap, ledgers = Just newLedgerM} diff --git a/src/Deal/DealQuery.hs b/src/Deal/DealQuery.hs index 438f4923..7fc0362b 100644 --- a/src/Deal/DealQuery.hs +++ b/src/Deal/DealQuery.hs @@ -405,7 +405,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f Nothing -> Left ("Date:"++show d++"No ledgers were modeled , failed to find ledger:"++show ans ) Just ledgersM -> do - lgBals <- lookupAndApplies LD.ledgBalance "Ledger Balance" ans ledgersM + lgBals <- lookupAndApplies (snd . LD.ledgBalance) "Ledger Balance" ans ledgersM return $ (toRational . sum) lgBals LedgerBalanceBy dr ans -> @@ -415,9 +415,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f do lgdsM <- selectInMap "Look up ledgers" ans ledgersM let ldgL = Map.elems lgdsM - let bs Credit = filter (\x -> LD.ledgBalance x < 0) ldgL - let bs Debit = filter (\x -> LD.ledgBalance x >= 0) ldgL - return $ toRational $ abs $ sum $ LD.ledgBalance <$> bs dr + return $ toRational $ sum $ (snd . LD.ledgBalance) <$> ldgL FutureCurrentPoolBalance mPns -> case (mPns,pt) of @@ -643,7 +641,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f in case mCmt of Just cmt -> Right . toRational $ sum [ queryTxnAmt lg cmt | lg <- lgs ] - Nothing -> Right . toRational $ sum [ LD.ledgBalance lg | lg <- lgs ] + Nothing -> Right . toRational $ sum [ (snd . LD.ledgBalance) lg | lg <- lgs ] BondBalanceGapAt d bName -> queryCompound t d (Excess [CurrentBondBalanceOf [bName], BondBalanceTarget [bName]]) @@ -817,7 +815,7 @@ queryDealBool t@TestDeal{triggers= trgs,bonds = bndMap,fees= feeMap Just triggerMatCycle -> case Map.lookup tName triggerMatCycle of Nothing -> Left ("Date:"++show d++"no trigger for this deal" ++ show tName ++ " in cycle " ++ show triggerMatCycle) - Just trigger -> Right $ Trg.trgStatus trigger + Just trigger -> return $ Trg.trgStatus trigger Nothing -> Left $ "Date:"++show d++"no trigger for this deal" IsMostSenior bn bns -> @@ -882,7 +880,6 @@ queryDealBool t@TestDeal{triggers= trgs,bonds = bndMap,fees= feeMap TestNot ds -> do not <$> (queryDealBool t ds d) - -- TestAny b dss -> b `elem` [ queryDealBool t ds d | ds <- dss ] TestAny b dss -> anyM (\ x -> (== b) <$> queryDealBool t x d ) dss TestAll b dss -> allM (\ x -> (== b) <$> queryDealBool t x d ) dss @@ -968,9 +965,9 @@ testPre d t p = q1 <- (queryCompound t d (ps s1)) q2 <- (queryCompound t d (ps s2)) return (toCmp cmp q1 q2) - IfDealStatus st -> Right $ status t == st -- `debug` ("current date"++show d++">> stutus"++show (status t )++"=="++show st) + IfDealStatus st -> return $ status t == st -- `debug` ("current date"++show d++">> stutus"++show (status t )++"=="++show st) - Always b -> Right b + Always b -> return b IfNot _p -> not <$> testPre d t _p where toCmp x = case x of @@ -1027,5 +1024,5 @@ preToStr t d p = where ps = patchDateToStats d -testPre2 :: P.Asset a => Date -> TestDeal a -> Pre -> (String, Either String Bool) +testPre2 :: P.Asset a => Date -> TestDeal a -> Pre -> (String, Either ErrorRep Bool) testPre2 d t p = (preToStr t d p, testPre d t p) diff --git a/src/Deal/DealRun.hs b/src/Deal/DealRun.hs index 72c22682..8927dcb9 100644 --- a/src/Deal/DealRun.hs +++ b/src/Deal/DealRun.hs @@ -315,7 +315,9 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= -- deposit cashflow to SPV from external pool cf in do + -- depsoit collected cashflow to accounts accs <- depositPoolFlow (collects t) d collectedFlow accMap + -- new deal = update accounts and pool collected cashflow let dAfterDeposit = (appendCollectedCF d t collectedFlow) {accounts=accs} let newPt = case pool dAfterDeposit of MultiPool pm -> @@ -594,8 +596,6 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= ostBal = L.getCurBalance bnd prinToPay = min pv ostBal intToPay = max 0 (pv - prinToPay) - -- bnd1 = L.payPrin d prinToPay bnd - -- bnd1 = L.payYield d intToPay bnd in (pay d DuePrincipal prinToPay) =<< (pay d DueResidual intToPay bnd)) bndMap @@ -700,7 +700,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= let runContext = RunContext poolFlowMap rAssump rates newStLogs - | null cleanUpActions = DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call"] + | null cleanUpActions = DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call"] | otherwise = DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call", RunningWaterfall d W.CleanUp] in do diff --git a/src/Ledger.hs b/src/Ledger.hs index ad66ca04..c06e07a3 100644 --- a/src/Ledger.hs +++ b/src/Ledger.hs @@ -2,8 +2,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} -module Ledger (Ledger(..),entryLog,LedgerName,queryGap,clearLedgersBySeq - ,queryDirection,entryLogByDr,bookToTarget) +module Ledger (Ledger(..),LedgerName,queryGap,clearLedgersBySeq + ,entryLogByDr,bookToTarget,bookToClear) where import qualified Data.Time as T import Stmt @@ -25,95 +25,87 @@ debug = flip trace type LedgerName = String +type EntryAmount = (BookDirection, Amount) +type LedgerBalance = (BookDirection, Amount) + +rev :: BookDirection -> BookDirection +rev Credit = Debit +rev Debit = Credit + data Ledger = Ledger { ledgName :: String -- ^ ledger account name - ,ledgBalance :: Balance -- ^ current balance of ledger + ,ledgBalance :: LedgerBalance -- ^ current balance of ledger ,ledgStmt :: Maybe Statement -- ^ ledger transaction history } deriving (Show, Generic,Ord, Eq) --- | Book an entry with date,amount and transaction to a ledger -entryLog :: Amount -> Date -> TxnComment -> Ledger -> Ledger -entryLog amt d cmt ledg@Ledger{ledgStmt = mStmt, ledgBalance = bal} - | isTxnDirection Credit cmt = let - newBal = bal - amt - txn = EntryTxn d newBal amt cmt - in - ledg { ledgStmt = appendStmt txn mStmt,ledgBalance = newBal } - | otherwise = let - newBal = bal + amt - txn = EntryTxn d newBal amt cmt - in - ledg { ledgStmt = appendStmt txn mStmt ,ledgBalance = newBal } - --- TODO-- need to ensure there is no direction in input -entryLogByDr :: BookDirection -> Amount -> Date -> Maybe TxnComment -> Ledger -> Ledger -entryLogByDr dr amt d Nothing = entryLog amt d (TxnDirection dr) -entryLogByDr dr amt d (Just cmt) - | not (hasTxnDirection cmt) = entryLog amt d (TxnComments [TxnDirection dr,cmt]) - | isTxnDirection dr cmt = entryLog amt d cmt - | otherwise = error $ "Suppose direction"++ show dr++"but got from comment"++ show cmt - -entryLogByDr Credit amt d (Just (TxnComments cms)) = entryLog amt d (TxnComments ((TxnDirection Credit):cms)) -entryLogByDr Debit amt d (Just (TxnComments cms)) = entryLog amt d (TxnComments ((TxnDirection Debit):cms)) + +entryLogByDr :: EntryAmount -> Date -> Maybe TxnComment -> Ledger -> Ledger +entryLogByDr (dr, amt) d mCmt ledg@Ledger{ledgStmt = mStmt, ledgBalance = (curDr, curBal)} + = let + cmt = case mCmt of + Nothing -> TxnDirection dr + Just c -> if hasTxnDirection c then c else TxnComments [TxnDirection dr,c] + (newBalAmt, newDr) = case (curDr, dr, amt > curBal ) of + (Debit, Debit, _ ) -> (curBal + amt, Debit) + (Credit, Credit, _) -> (curBal + amt, Credit) + (Debit, Credit, True ) -> (amt - curBal, Credit) + (Debit, Credit, False ) -> (curBal - amt, Debit) + (Credit, Debit, True ) -> (amt - curBal, Debit ) + (Credit, Debit, False ) -> (curBal - amt, Credit) + + txn = EntryTxn d (newDr, newBalAmt) (dr, amt) cmt + in + ledg { ledgStmt = appendStmt txn mStmt ,ledgBalance = (newDr, newBalAmt) } hasTxnDirection :: TxnComment -> Bool hasTxnDirection (TxnDirection _) = True hasTxnDirection (TxnComments txns) = any hasTxnDirection txns hasTxnDirection _ = False -isTxnDirection :: BookDirection -> TxnComment -> Bool -isTxnDirection Credit (TxnDirection Credit) = True -isTxnDirection Debit (TxnDirection Debit) = True -isTxnDirection Credit (TxnComments txns) = any (isTxnDirection Credit) txns -isTxnDirection Debit (TxnComments txns) = any (isTxnDirection Debit) txns -isTxnDirection _ _ = False - --- ^ credit is negative amount -queryDirection :: Ledger -> (BookDirection ,Balance) -queryDirection (Ledger _ bal _) - | bal >= 0 = (Debit, bal) - | bal < 0 = (Credit, negate bal) - -bookToTarget :: Ledger -> (BookDirection,Amount) -> (BookDirection,Amount) -bookToTarget Ledger{ledgBalance = bal} (dr, targetBal) - = case (bal > 0, dr) of - (True, Debit) -> - if (targetBal > bal) then - (Debit,targetBal - bal) - else - (Credit,bal - targetBal) - (False, Credit) -> - if (targetBal > abs bal) then - (Credit,targetBal - abs bal) - else - (Debit, abs bal - targetBal) - (True, Credit) -> - (Credit,targetBal + bal) - (False, Debit) -> - (Debit,targetBal + abs bal) +-- ^ backout book txn from a target amount +bookToTarget :: Ledger -> (BookDirection, Amount) -> (BookDirection, Amount) +bookToTarget Ledger{ledgBalance = (curDr,curBal) } (targetDr, targetBal) + = let + a = 1 + in + case (curDr == targetDr , targetBal >= curBal) of + (True, True) -> + (curDr, targetBal - curBal) + (True, False) -> + (rev curDr, curBal - targetBal) + (False, _) -> + (targetDr, targetBal + curBal) + +bookToClear :: EntryAmount -> Date -> Ledger -> (EntryAmount, Ledger) +bookToClear (_,0) d ledg = ((Credit,0),ledg ) +bookToClear (dr,amt) d ledg@Ledger{ledgBalance = (curDr, curBal)} + | curDr == dr = ((dr, amt), ledg) + | otherwise + = let + bookAmt + | amt > curBal = curBal + | otherwise = amt + remainAmt = amt - bookAmt + newLedger = entryLogByDr (dr, bookAmt) d (Just (TxnDirection dr)) ledg + in + ((dr,remainAmt), newLedger) -- ^ return ledger's bookable amount (for netting off to zero ) with direction input -queryGap :: BookDirection -> Ledger -> Balance -queryGap dr Ledger{ledgBalance = bal} - = case (bal > 0, dr) of - (True, Debit) -> 0 - (True, Credit) -> bal - (False, Debit) -> negate bal - (False, Credit) -> 0 - -clearLedgersBySeq :: BookDirection -> Date -> Amount -> [Ledger] -> [Ledger] -> ([Ledger],Amount) -clearLedgersBySeq dr d 0 rs unAllocLedgers = (rs++unAllocLedgers,0) -clearLedgersBySeq dr d amtToAlloc rs [] = (rs,amtToAlloc) -clearLedgersBySeq dr d amtToAlloc rs (ledger@Ledger{ledgBalance = bal}:ledgers) +queryGap :: Ledger -> LedgerBalance +queryGap Ledger{ledgBalance = (Credit, bal)} = (Debit, bal) -- credit balance can be booked by debit +queryGap Ledger{ledgBalance = (Debit, bal)} = (Credit, bal) -- debit balance can be booked by credit + +-- ^ book an amount to a list of ledgers by sequence +clearLedgersBySeq :: EntryAmount -> Date -> [Ledger] -> [Ledger] -> ([Ledger],EntryAmount) +clearLedgersBySeq (dr,0) d rs unAllocLedgers = ( (reverse rs)++unAllocLedgers,(dr,0)) +clearLedgersBySeq (dr,amtToAlloc) d rs [] = (reverse rs,(dr,amtToAlloc)) +clearLedgersBySeq (dr,amtToAlloc) d rs (ledger:ledgers) = let - deductAmt = queryGap dr ledger - allocAmt = min deductAmt amtToAlloc - remainAmt = amtToAlloc - allocAmt - newLedger = entryLog allocAmt d (TxnDirection dr) ledger + ((newDr, remainAmt), newLedger) = bookToClear (dr,amtToAlloc) d ledger in - clearLedgersBySeq dr d remainAmt (newLedger:rs) ledgers + clearLedgersBySeq (newDr,remainAmt) d (newLedger:rs) ledgers instance QueryByComment Ledger where queryStmt (Ledger _ _ Nothing) tc = [] diff --git a/src/Pool.hs b/src/Pool.hs index e338c238..68143e39 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -195,9 +195,9 @@ pricingPoolFlow d pool@Pool{ futureCf = Just (mCollectedCf,_), issuanceStat = mS in AN.pv21 discountRate d futureDates futureCfCash - -- | run a pool of assets ,use asOfDate of Pool to cutoff cashflow yields from assets with assumptions supplied +-- | run a pool of assets ,use asOfDate of Pool to cutoff cashflow yields from assets with assumptions supplied runPool :: Asset a => Pool a -> Maybe A.ApplyAssumptionType -> Maybe [RateAssumption] - -> Either String [(CF.CashFlowFrame, Map.Map CutoffFields Balance)] + -> Either ErrorRep [(CF.CashFlowFrame, Map.Map CutoffFields Balance)] -- use interest rate assumption runPool (Pool as _ _ asof _ _) Nothing mRates = do @@ -259,15 +259,16 @@ runPool (Pool as _ Nothing asof _ _) (Just (A.ByObligor obligorRules)) mRates = let matchRuleFn (A.FieldIn fv fvals) Nothing = False matchRuleFn (A.FieldIn fv fvals) (Just fm) = case Map.lookup fv fm of - Just (Left v) -> v `elem` fvals - Nothing -> False + Just (Left v) -> v `elem` fvals + Nothing -> False matchRuleFn (A.FieldCmp fv cmp dv) (Just fm) = case Map.lookup fv fm of - Just (Right v) -> case cmp of + Just (Right v) + -> case cmp of G -> v > dv L -> v < dv GE -> v >= dv LE -> v <= dv - Nothing -> False + Nothing -> False matchRuleFn (A.FieldInRange fv rt dv1 dv2) (Just fm) = case Map.lookup fv fm of Just (Right v) -> case rt of diff --git a/src/Stmt.hs b/src/Stmt.hs index 275b1b8b..2de6afc8 100644 --- a/src/Stmt.hs +++ b/src/Stmt.hs @@ -62,7 +62,7 @@ scaleTxn r (ExpTxn d b a b0 t) = ExpTxn d (mulBR b r) (mulBR a r) (mulBR b0 r) t scaleTxn r (SupportTxn d Unlimit b0 i p c t) = SupportTxn d Unlimit (mulBR b0 r) (mulBR i r) (mulBR p r) (mulBR c r) t scaleTxn r (SupportTxn d (ByAvailAmount b) b0 i p c t) = SupportTxn d (ByAvailAmount (mulBR b r)) (mulBR b0 r) (mulBR i r) (mulBR p r) (mulBR c r) t scaleTxn r (IrsTxn d b a i0 i1 b0 t) = IrsTxn d (mulBR b r) (mulBR a r) i0 i1 (mulBR b0 r) t -scaleTxn r (EntryTxn d b a t) = EntryTxn d (mulBR b r) (mulBR a r) t +scaleTxn r (EntryTxn d (cd,b) (cd',a) t) = EntryTxn d (cd,(mulBR b r)) (cd',(mulBR a r)) t scaleByFactor :: Rate -> [Txn] -> [Txn] scaleByFactor r [] = [] @@ -85,7 +85,7 @@ getTxnBalance (BondTxn _ t _ _ _ _ _ _ _ _) = t getTxnBalance (AccTxn _ t _ _ ) = t getTxnBalance (ExpTxn _ t _ _ _ ) = t getTxnBalance (SupportTxn _ _ t _ _ _ _ ) = t -- drawed balance -getTxnBalance (EntryTxn _ t _ _) = t +getTxnBalance (EntryTxn _ (_,t) _ _) = t -- | SupportTxn Date (Maybe Balance) Balance DueInt DuePremium Cash TxnComment @@ -93,7 +93,10 @@ getTxnBegBalance :: Txn -> Balance getTxnBegBalance (BondTxn _ t _ p _ _ _ _ _ _) = t + p getTxnBegBalance (AccTxn _ b a _ ) = b - a getTxnBegBalance (SupportTxn _ _ a b _ _ _) = b + a -getTxnBegBalance (EntryTxn _ a b _) = a + b +getTxnBegBalance (EntryTxn _ (curDr,a) (bkDr,b) _) + | curDr == bkDr && b > a = b - a + | curDr == bkDr && b <= a = a - b + | curDr /= bkDr = a + b getTxnPrincipal :: Txn -> Balance getTxnPrincipal (BondTxn _ _ _ t _ _ _ _ _ _) = t @@ -104,7 +107,7 @@ getTxnAmt (AccTxn _ _ t _ ) = t getTxnAmt (ExpTxn _ _ t _ _ ) = t getTxnAmt (SupportTxn _ _ _ _ _ t _) = t getTxnAmt (IrsTxn _ _ t _ _ _ _ ) = t -getTxnAmt (EntryTxn _ _ t _) = t +getTxnAmt (EntryTxn _ _ t _) = snd t getTxnAmt TrgTxn {} = 0.0 getTxnAsOf :: [Txn] -> Date -> Maybe Txn @@ -116,7 +119,7 @@ emptyTxn AccTxn {} d = AccTxn d 0 0 Empty emptyTxn ExpTxn {} d = ExpTxn d 0 0 0 Empty emptyTxn SupportTxn {} d = SupportTxn d Unlimit 0 0 0 0 Empty emptyTxn IrsTxn {} d = IrsTxn d 0 0 0 0 0 Empty -emptyTxn EntryTxn {} d = EntryTxn d 0 0 Empty +emptyTxn EntryTxn {} d = EntryTxn d (Credit,0) (Credit,0) Empty emptyTxn TrgTxn {} d = TrgTxn d False Empty isEmptyTxn :: Txn -> Bool @@ -125,7 +128,7 @@ isEmptyTxn (AccTxn _ 0 0 Empty) = True isEmptyTxn (ExpTxn _ 0 0 0 Empty) = True isEmptyTxn (SupportTxn _ _ 0 0 0 0 Empty) = True isEmptyTxn (IrsTxn _ 0 0 0 0 0 Empty) = True -isEmptyTxn (EntryTxn _ 0 0 Empty) = True +isEmptyTxn (EntryTxn _ (_,0) (_,0) Empty) = True isEmptyTxn _ = False viewBalanceAsOf :: Date -> [Txn] -> Balance diff --git a/src/Types.hs b/src/Types.hs index aba7f6d1..f7cb4d75 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -618,7 +618,7 @@ data Txn = BondTxn Date Balance Interest Principal IRate Cash DueInt DueIoI (May | ExpTxn Date FeeDue Amount FeeArrears TxnComment -- ^ expense transaction record | SupportTxn Date SupportAvailType Balance DueInt DuePremium Cash TxnComment -- ^ liquidity provider transaction record | IrsTxn Date Balance Amount IRate IRate Balance TxnComment -- ^ interest swap transaction record - | EntryTxn Date Balance Amount TxnComment -- ^ ledger book entry + | EntryTxn Date (BookDirection,Balance) (BookDirection,Amount) TxnComment -- ^ ledger book entry | TrgTxn Date Bool TxnComment deriving (Show, Generic, Eq, Read) diff --git a/test/MainTest.hs b/test/MainTest.hs index b657d07c..21729d67 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -19,6 +19,7 @@ import qualified UT.AnalyticsTest as AnalyticsT import qualified UT.InterestRateTest as IRT import qualified UT.RateHedgeTest as RHT import qualified UT.CeTest as CET +import qualified UT.LedgerTest as LeT import qualified DealTest.DealTest as DealTest @@ -117,4 +118,5 @@ tests = testGroup "Tests" [AT.mortgageTests ,DealMultiTest.mPoolbaseTests ,RHT.capRateTests ,CET.liqTest + ,LeT.bookTest ] diff --git a/test/UT/LedgerTest.hs b/test/UT/LedgerTest.hs new file mode 100644 index 00000000..7b4257c1 --- /dev/null +++ b/test/UT/LedgerTest.hs @@ -0,0 +1,77 @@ +module UT.LedgerTest(bookTest) +where + +import Test.Tasty +import Test.Tasty.HUnit +import Accounts +import Lib +import Stmt +import Util +import DateUtil +import Types +import Deal +import Deal.DealQuery (queryCompound) +import Deal.DealBase +import Control.Lens hiding (element,Empty) +import Control.Lens.TH +import Data.Map.Lens +import qualified Ledger as LD + + +import qualified Data.Time as T +import qualified Data.DList as DL +import qualified Data.Map as Map + +bookTest = + let + leg1 = LD.Ledger "L1" (Debit, 200) Nothing + leg2 = LD.Ledger "L2" (Debit, 100) Nothing + + btoClear = LD.bookToClear (Credit, 50) (toDate "20220101") leg1 + btoClear' = LD.bookToClear (Credit, 250) (toDate "20220101") leg1 + bySeq = LD.clearLedgersBySeq (Credit, 240) (toDate "20220101") [] [leg1,leg2] + bySeq' = LD.clearLedgersBySeq (Credit, 350) (toDate "20220101") [] [leg1,leg2] + in + testGroup "Booking Ledger Test" + [ + testCase "Booking Ledger Test:01" $ + assertEqual "01" + (Debit, 250) + (LD.ledgBalance (LD.entryLogByDr (Debit,50) (toDate "20220101") Nothing leg1)) + ,testCase "Booking Ledger Test:02" $ + assertEqual "02" + (Credit, 50) + (LD.ledgBalance (LD.entryLogByDr (Credit,250) (toDate "20220101") Nothing leg1)) + ,testCase "Booking Ledger Test:03" $ + assertEqual "03" + (Debit, 150) + (LD.ledgBalance (LD.entryLogByDr (Credit,50) (toDate "20220101") Nothing leg1)) + ,testCase "Booking Ledger Test:04" $ + assertEqual "04" + (Credit, 250) + (LD.bookToTarget leg1 (Credit,50)) + ,testCase "Booking Ledger Test:05" $ + assertEqual "05" + (Debit, 150) + (LD.bookToTarget leg1 (Debit,350)) + ,testCase "Booking Ledger Test:06" $ + assertEqual "06" + (Credit, 50) + (LD.bookToTarget leg1 (Debit,150)) + ,testCase "Booking Ledger Test:07" $ + assertEqual "07" + ((Debit, 150), 0) + ((LD.ledgBalance . snd) btoClear, (snd . fst) btoClear) + ,testCase "Booking Ledger Test:08" $ + assertEqual "08" + ((Debit, 0), (Credit, 50)) + ((LD.ledgBalance . snd) btoClear', fst btoClear') + ,testCase "Booking Ledger Test:09" $ + assertEqual "09" + [(Debit, 60),(Debit, 0), (Credit, 0)] + [LD.ledgBalance ((fst bySeq) !! 1), LD.ledgBalance ((fst bySeq) !! 0), snd bySeq] + ,testCase "Booking Ledger Test:10" $ + assertEqual "10" + [(Debit, 0),(Debit, 0), (Credit, 50)] + [LD.ledgBalance ((fst bySeq') !! 1), LD.ledgBalance ((fst bySeq') !! 0), snd bySeq'] + ]