From a13ce3bfff07b5cbcbf068867ff38beb6cc57fca Mon Sep 17 00:00:00 2001 From: Shawn Zhang Date: Thu, 12 Dec 2024 14:03:25 +0800 Subject: [PATCH] 0.41.x (#245) * fix : order of pay sequence when remain amt is 0 * add cmt * Fix on step up & floater bond * add asset-assumption mismatch error * refactor on PDL * expose query LedgerBalanceBy * fix ledger query by direction always return positive * remove legacy DealQuery * Add utils * patch dates to Errors * expose changeStatus action * Ensure result of is above zero * update validation on liqSupport --- .github/workflows/docker-image-dev-by-tag.yml | 6 +- .github/workflows/docker-image.yml | 2 +- CHANGELOG.md | 17 +- Hastructure.cabal | 6 +- app/Main.hs | 8 +- package.yaml | 4 +- src/Accounts.hs | 11 +- src/AssetClass/AssetCashflow.hs | 2 +- src/AssetClass/Installment.hs | 2 + src/AssetClass/Lease.hs | 2 + src/AssetClass/Loan.hs | 2 +- src/AssetClass/ProjectedCashFlow.hs | 2 + src/AssetClass/Receivable.hs | 2 + src/Cashflow.hs | 19 +- src/Deal.hs | 912 +++++++++--------- src/Deal/DealAction.hs | 633 ++++++------ src/Deal/DealBase.hs | 35 +- src/Deal/DealQuery.hs | 736 +++++++------- src/Deal/DealValidation.hs | 14 +- src/Ledger.hs | 40 +- src/Liability.hs | 6 +- src/Pool.hs | 4 +- src/Reports.hs | 71 +- src/Stmt.hs | 1 + src/Types.hs | 38 +- src/Util.hs | 54 +- src/Waterfall.hs | 12 +- swagger.json | 497 +++++----- test/DealTest/DealTest.hs | 7 +- test/DealTest/ResecDealTest.hs | 6 +- test/MainTest.hs | 2 + test/UT/AccountTest.hs | 15 +- test/UT/AssetTest.hs | 39 +- test/UT/DealTest.hs | 159 ++- test/UT/DealTest2.hs | 19 +- test/UT/LibTest.hs | 22 +- test/UT/RateHedgeTest.hs | 10 +- 37 files changed, 1876 insertions(+), 1541 deletions(-) diff --git a/.github/workflows/docker-image-dev-by-tag.yml b/.github/workflows/docker-image-dev-by-tag.yml index 12b291d5..7c1aa521 100644 --- a/.github/workflows/docker-image-dev-by-tag.yml +++ b/.github/workflows/docker-image-dev-by-tag.yml @@ -27,11 +27,13 @@ jobs: - name: Extract metadata (tags, labels) for Docker id: meta - uses: docker/metadata-action@9ec57ed1fcdbf14dcef7dfbe97b2010124a938b7 + uses: docker/metadata-action@v5 with: images: yellowbean/hastructure tags: | - type=raw,value=latest,enable=${{ github.ref == format('refs/heads/{0}', 'master') }} + type=match,pattern=(a\d+.\d+.\d+),group=1 + flavor: | + latest=false - name: 'Cleanup build folder' run: | diff --git a/.github/workflows/docker-image.yml b/.github/workflows/docker-image.yml index b26d2f83..f9091f7d 100644 --- a/.github/workflows/docker-image.yml +++ b/.github/workflows/docker-image.yml @@ -135,7 +135,7 @@ jobs: - name: Extract metadata (tags, labels) for Docker id: meta - uses: docker/metadata-action@9ec57ed1fcdbf14dcef7dfbe97b2010124a938b7 + uses: docker/metadata-action@v5 with: images: yellowbean/hastructure diff --git a/CHANGELOG.md b/CHANGELOG.md index 29d76cc6..783a6490 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,17 +3,28 @@ +## 0.40.9 +### 2024-12-11 +* ENHANCE: Ensure always return positive ,otherwise engine will throw error +* NEW: add new action `changeStatus` in waterfall, with optional `Pre` as condition to trigger the status change + + +## 0.40.6 +### 2024-12-06 +* NEW: new formula `ledgerBalanceBy`, which return either `Credit` or `Debit` balance of a ledger +* FIX: step-up coupon bond which has a floater index will increase forever +* ENHANCE: refactor on `PDL` book type. + + ## 0.40.1 ### 2024-11-05 * NEW: break changes on API ,now the engine is able to throw out error message instead of just hanging. ## 0.31.0 - ### 2024-11-05 * NEW: new Call options assumption ,which specifies `dates` to be tested -* NEW: -* ENHANCE: transform financial report to a Tree from a Table +* ENHANCE: transform financial report to a `Tree` from a `Table` ## 0.30.5 ### 2024-11-02 diff --git a/Hastructure.cabal b/Hastructure.cabal index df2c0422..d14b2a0e 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack name: Hastructure -version: 0.26.5 +version: 0.40.11 description: Please see the README on GitHub at category: StructuredFinance;Securitisation;Cashflow homepage: https://github.com/yellowbean/Hastructure#readme @@ -18,7 +18,7 @@ license-file: LICENSE build-type: Simple extra-source-files: README.md - ChangeLog.md + CHANGELOG.md source-repository head type: git diff --git a/app/Main.hs b/app/Main.hs index 246bd1c8..1e41867f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -92,11 +92,11 @@ import qualified DateUtil as DU import Data.Scientific (fromRationalRepetend,formatScientific, Scientific,FPFormat(Fixed)) import Control.Lens -import Debug.Trace import qualified Types as W import Cashflow (patchCumulative) +import Debug.Trace debug = flip Debug.Trace.trace @@ -115,7 +115,7 @@ $(deriveJSON defaultOptions ''Version) instance ToSchema Version version1 :: Version -version1 = Version "0.40.1" +version1 = Version "0.40.11" @@ -304,7 +304,7 @@ wrapRun (PDeal d) mAssump mNonPerfAssump (_d,_pflow,_rs,_p) <- D.runDeal d D.DealPoolFlowPricing mAssump mNonPerfAssump return (PDeal _d,_pflow,_rs,_p) -wrapRun x _ _ = error $ "RunDeal Failed ,due to unsupport deal type "++ show x +wrapRun x _ _ = Left $ "RunDeal Failed ,due to unsupport deal type "++ show x data PoolTypeWrap = LPool (DB.PoolType AB.Loan) @@ -337,7 +337,7 @@ wrapRunPoolType (FPool pt) assump mRates = D.runPoolType pt assump $ Just (AP.No wrapRunPoolType (VPool pt) assump mRates = D.runPoolType pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) wrapRunPoolType (PPool pt) assump mRates = D.runPoolType pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) wrapRunPoolType (UPool pt) assump mRates = D.runPoolType pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType x _ _ = error $ "RunPool Failed ,due to unsupport pool type "++ show x +wrapRunPoolType x _ _ = Left $ "RunPool Failed ,due to unsupport pool type "++ show x data RunAssetReq = RunAssetReq Date [AB.AssetUnion] (Maybe AP.ApplyAssumptionType) (Maybe [RateAssumption]) (Maybe PricingMethod) diff --git a/package.yaml b/package.yaml index 81c412cb..519e374c 100644 --- a/package.yaml +++ b/package.yaml @@ -1,5 +1,5 @@ name: Hastructure -version: 0.26.5 +version: 0.40.11 github: "yellowbean/Hastructure" license: BSD3 author: "Xiaoyu" @@ -8,7 +8,7 @@ copyright: "2024 Xiaoyu, Zhang" extra-source-files: - README.md -- ChangeLog.md +- CHANGELOG.md # Metadata used when publishing your package # synopsis: Short description of your package diff --git a/src/Accounts.hs b/src/Accounts.hs index 5b61a607..a6a319c4 100644 --- a/src/Accounts.hs +++ b/src/Accounts.hs @@ -98,11 +98,10 @@ depositInt ed a@(Account bal _ (Just intType) _ stmt) newStmt = appendStmt stmt newTxn -- | move cash from account A to account B -transfer :: Account -> Amount -> Date -> Account -> (Account, Account) -transfer sourceAcc@(Account sBal san _ _ sStmt) - amount +transfer :: (Account,Account) -> Date -> Amount -> (Account, Account) +transfer (sourceAcc@(Account sBal san _ _ sStmt), targetAcc@(Account tBal tan _ _ tStmt)) d - targetAcc@(Account tBal tan _ _ tStmt) + amount = (sourceAcc {accBalance = newSBal, accStmt = sourceNewStmt} ,targetAcc {accBalance = newTBal, accStmt = targetNewStmt}) where @@ -121,7 +120,9 @@ deposit amount d source acc@(Account bal _ _ _ maybeStmt) = -- | draw cash from account with a comment draw :: Amount -> Date -> TxnComment -> Account -> Account -draw amount = deposit (- amount) +draw amount d txn acc@Account{ accBalance = bal ,accName = an} + | bal >= amount = deposit (- amount) d txn acc + | otherwise = error $ "Date:"++ show d ++" Failed to draw "++ show amount ++" from account" ++ an -- | draw cash from account with a comment,return shortfall and acccount tryDraw :: Amount -> Date -> TxnComment -> Account -> ((Amount,Amount),Account) diff --git a/src/AssetClass/AssetCashflow.hs b/src/AssetClass/AssetCashflow.hs index 5da03756..6c0214cb 100644 --- a/src/AssetClass/AssetCashflow.hs +++ b/src/AssetClass/AssetCashflow.hs @@ -84,7 +84,7 @@ applyHaircut (Just A.ExtraStress{A.poolHairCut = Just haircuts}) (CF.CashFlowFra patchPrepayPenaltyFlow :: (Int,Maybe PrepayPenaltyType) -> CF.CashFlowFrame -> CF.CashFlowFrame patchPrepayPenaltyFlow (ot,mPpyPen) mflow@(CF.CashFlowFrame st trs) = let - (startDate,endDate) = CF.getDateRangeCashFlowFrame mflow + --(startDate,endDate) = CF.getDateRangeCashFlowFrame mflow prepaymentFlow = CF.mflowPrepayment <$> trs flowSize = CF.sizeCashFlowFrame mflow in diff --git a/src/AssetClass/Installment.hs b/src/AssetClass/Installment.hs index 7571e670..9d6092b9 100644 --- a/src/AssetClass/Installment.hs +++ b/src/AssetClass/Installment.hs @@ -175,6 +175,8 @@ instance Asset Installment where projCashflow inst@(Installment _ cb rt (Defaulted Nothing)) asOfDay assumps _ = Right $ (CF.CashFlowFrame (cb, asOfDay, Nothing) $ [CF.LoanFlow asOfDay cb 0 0 0 0 0 0 (getOriginRate inst) Nothing],Map.empty) + projCashflow a b c d = Left $ "Failed to match when proj mortgage with assumption >>" ++ show a ++ show b ++ show c ++ show d + splitWith (Installment (LoanOriginalInfo ob or ot p sd _type _obligor) cb rt st) rs = [ Installment (LoanOriginalInfo (mulBR ob ratio) or ot p sd _type _obligor) (mulBR cb ratio) rt st | ratio <- rs ] diff --git a/src/AssetClass/Lease.hs b/src/AssetClass/Lease.hs index ab01cc44..7a640fe7 100644 --- a/src/AssetClass/Lease.hs +++ b/src/AssetClass/Lease.hs @@ -239,6 +239,8 @@ instance Asset Lease where begBal = CF.buildBegBal allTxns + projCashflow a b c d = Left $ "Failed to match when proj lease with assumption >>" ++ show a ++ show b ++ show c ++ show d + getCurrentBal l = case l of StepUpLease _ _ bal _ _ -> bal RegularLease _ bal _ _-> bal diff --git a/src/AssetClass/Loan.hs b/src/AssetClass/Loan.hs index 91df41d0..45f9cd31 100644 --- a/src/AssetClass/Loan.hs +++ b/src/AssetClass/Loan.hs @@ -166,7 +166,7 @@ instance Asset Loan where projCashflow m@(PersonalLoan (LoanOriginalInfo ob or ot p sd prinPayType _) cb cr rt (Defaulted Nothing)) asOfDay assumps _ = Right $ (CF.CashFlowFrame (cb,asOfDay,Nothing) [CF.LoanFlow asOfDay 0 0 0 0 0 0 0 cr Nothing],Map.empty) - projCashflow a b c d = Left $ "failed to match projCashflow"++show a++show b++show c++show d + projCashflow a b c d = Left $ "failed to match projCashflow for Loan "++show a++show b++show c++show d splitWith l@(PersonalLoan (LoanOriginalInfo ob or ot p sd prinPayType obr) cb cr rt st) rs = [ PersonalLoan (LoanOriginalInfo (mulBR ob ratio) or ot p sd prinPayType obr) (mulBR cb ratio) cr rt st | ratio <- rs ] diff --git a/src/AssetClass/ProjectedCashFlow.hs b/src/AssetClass/ProjectedCashFlow.hs index 224a2ac8..e4bb5463 100644 --- a/src/AssetClass/ProjectedCashFlow.hs +++ b/src/AssetClass/ProjectedCashFlow.hs @@ -194,6 +194,8 @@ instance Ast.Asset ProjectedCashflow where Right $ (foldl CF.combine fixedCashFlow floatedCashFlow, Map.empty) --(fixedCashFlow, Map.empty) + projCashflow a b c d = Left $ "Failed to match when proj projected flow with assumption >>" ++ show a ++ show b ++ show c ++ show d + getBorrowerNum f = 0 splitWith f rs = [f] diff --git a/src/AssetClass/Receivable.hs b/src/AssetClass/Receivable.hs index 9c821983..e54b5238 100644 --- a/src/AssetClass/Receivable.hs +++ b/src/AssetClass/Receivable.hs @@ -163,3 +163,5 @@ instance Asset Receivable where txns = [initTxn, CF.ReceivableFlow payDate 0 0 principal feePaid defaultAmt 0 realizedLoss Nothing] (futureTxns,historyM) = CF.cutoffTrs asOfDay $ txns++(buildRecoveryCfs payDate defaultAmt amr) -- `debug` ("recovery flow"++ show (buildRecoveryCfs payDate defaultAmt amr)) + + projCashflow a b c d = Left $ "Failed to match when proj receivable with assumption >>" ++ show a ++ show b ++ show c ++ show d diff --git a/src/Cashflow.hs b/src/Cashflow.hs index 5fffa015..c51aa668 100644 --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -3,17 +3,17 @@ module Cashflow (CashFlowFrame(..),Principals,Interests,Amount ,combine,mergePoolCf,sumTsCF,tsSetDate,tsSetLoss,tsSetRecovery - ,sizeCashFlowFrame,aggTsByDates, getTsCashFlowFrame + ,sizeCashFlowFrame,aggTsByDates ,mflowInterest,mflowPrincipal,mflowRecovery,mflowPrepayment ,mflowRental,mflowRate,sumPoolFlow,splitTrs,aggregateTsByDate ,mflowDefault,mflowLoss,mflowDate - ,getSingleTsCashFlowFrame,getDatesCashFlowFrame,getDateRangeCashFlowFrame + ,getSingleTsCashFlowFrame,getDatesCashFlowFrame ,lookupSource,lookupSourceM,combineTss ,mflowBalance,mflowBegBalance,tsDefaultBal ,mflowBorrowerNum,mflowPrepaymentPenalty ,emptyTsRow,mflowAmortAmount ,tsTotalCash, setPrepaymentPenalty, setPrepaymentPenaltyFlow - ,getDate,getTxnLatestAsOf + ,getDate,getTxnLatestAsOf,totalPrincipal ,mflowWeightAverageBalance ,addFlowBalance,totalLoss,totalDefault,totalRecovery,firstDate ,shiftCfToStartDate,cfInsertHead,buildBegTsRow,insertBegTsRow @@ -221,14 +221,12 @@ instance Show CashFlowFrame where sizeCashFlowFrame :: CashFlowFrame -> Int sizeCashFlowFrame (CashFlowFrame _ ts) = length ts -getTsCashFlowFrame :: CashFlowFrame -> [TsRow] -getTsCashFlowFrame (CashFlowFrame _ ts) = ts - getDatesCashFlowFrame :: CashFlowFrame -> [Date] getDatesCashFlowFrame (CashFlowFrame _ ts) = getDates ts -getDateRangeCashFlowFrame :: CashFlowFrame -> (Date,Date) -getDateRangeCashFlowFrame (CashFlowFrame _ trs) = (getDate (head trs), getDate (last trs)) +-- getDateRangeCashFlowFrame :: CashFlowFrame -> (Date,Date) --TODO what if it is empty ? +-- getDateRangeCashFlowFrame (CashFlowFrame _ [tr]) = (getDate tr, getDate tr) +-- getDateRangeCashFlowFrame (CashFlowFrame _ trs) = (getDate (head trs), getDate (last trs)) getBegBalCashFlowFrame :: CashFlowFrame -> Balance getBegBalCashFlowFrame (CashFlowFrame _ []) = 0 @@ -825,6 +823,9 @@ totalDefault (CashFlowFrame _ rs) = sum $ mflowDefault <$> rs totalRecovery :: CashFlowFrame -> Balance totalRecovery (CashFlowFrame _ rs) = sum $ mflowRecovery <$> rs +totalPrincipal :: CashFlowFrame -> Balance +totalPrincipal (CashFlowFrame _ rs) = sum $ mflowPrincipal <$> rs + -- ^ merge two cashflow frame but no patching beg balance mergePoolCf :: CashFlowFrame -> CashFlowFrame -> CashFlowFrame mergePoolCf cf (CashFlowFrame _ []) = cf @@ -1187,5 +1188,7 @@ txnCumulativeStats = lens getter setter setter x _ = x + + $(deriveJSON defaultOptions ''TsRow) $(deriveJSON defaultOptions ''CashFlowFrame) diff --git a/src/Deal.hs b/src/Deal.hs index 523b93d6..cf16d14c 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -6,12 +6,13 @@ {-# LANGUAGE GADTs #-} module Deal (run,runPool,getInits,runDeal,ExpectReturn(..) - ,performAction,queryDeal + ,performAction ,populateDealDates,accrueRC ,calcTargetAmount,updateLiqProvider ,projAssetUnion,priceAssetUnion - ,removePoolCf,setFutureCF,runPoolType,PoolType + ,removePoolCf,runPoolType,PoolType ,ActionOnDate(..),DateDesp(..),OverrideType(..) + ,changeDealStatus ) where import qualified Accounts as A @@ -82,25 +83,62 @@ debug = flip trace -- ^ update bond interest rate from rate assumption setBondNewRate :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> L.Bond -> Either String L.Bond -setBondNewRate t d ras b@(L.Bond _ _ _ ii (Just (L.PassDateSpread _ spd)) bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) - = Right $ b { L.bndRate = currentRate + spd, L.bndDueInt = dueInt + accrueInt, L.bndDueIntDate = Just d} +setBondNewRate t d ras b@(L.Bond _ _ L.OriginalInfo{ L.originDate = od} ii _ bal currentRate _ dueInt _ Nothing _ _ _) + = setBondNewRate t d ras b {L.bndDueIntDate = Just od} + + +-- ^ Floater rate+step up(once) +setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Floater br idx _spd rset dc mf mc) (Just (L.PassDateSpread resetDay spd)) bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) + | resetDay == d = Right $ b { L.bndRate = currentRate + spd, L.bndDueInt = dueInt + accrueInt + , L.bndDueIntDate = Just d + , L.bndInterestInfo = L.Floater br idx (_spd+spd) rset dc mf mc} + | otherwise = Right $ b { L.bndRate = applyFloatRate ii d ras + , L.bndDueInt = dueInt + accrueInt, L.bndDueIntDate = Just d} + where + (Just dc) = getDayCountFromInfo ii + accrueInt = calcInt (bal + dueInt) dueIntDate d currentRate dc + +-- ^ Floater rate+step up(ladder) TODO ,it's not ladder +setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Floater br idx _spd rset dc mf mc) (Just (L.PassDateSpread resetDay spd)) bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) + | resetDay == d = Right $ b { L.bndRate = currentRate + spd, L.bndDueInt = dueInt + accrueInt + , L.bndDueIntDate = Just d + , L.bndInterestInfo = L.Floater br idx (_spd+spd) rset dc mf mc} + | otherwise = Right $ b { L.bndRate = applyFloatRate ii d ras + , L.bndDueInt = dueInt + accrueInt, L.bndDueIntDate = Just d} + where + (Just dc) = getDayCountFromInfo ii + accrueInt = calcInt (bal + dueInt) dueIntDate d currentRate dc + +-- ^ Fix rate+step up(once) +setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Fix {}) (Just (L.PassDateSpread resetDay spd)) bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) + | resetDay == d = Right $ b { L.bndRate = currentRate + spd, L.bndDueInt = dueInt + accrueInt, L.bndDueIntDate = Just d} + | otherwise = Right b where (Just dc) = getDayCountFromInfo ii accrueInt = calcInt (bal + dueInt) dueIntDate d currentRate dc -setBondNewRate t d ras b@(L.Bond _ _ _ ii (Just (L.PassDateLadderSpread _ spd _)) bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) +-- ^ Fix rate+step up(ladder) +setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Fix {}) (Just (L.PassDateLadderSpread _ spd _)) bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) = Right $ b { L.bndRate = currentRate + spd, L.bndDueInt = dueInt + accrueInt, L.bndDueIntDate = Just d} where (Just dc) = getDayCountFromInfo ii accrueInt = calcInt (bal + dueInt) dueIntDate d currentRate dc -setBondNewRate t d ras b@(L.Bond _ _ _ (L.RefRate sr ds factor _) _ _ _ _ _ _ _ _ _ _) +-- ^ Ref rate +setBondNewRate t d ras b@(L.Bond _ _ _ (L.RefRate sr ds factor _) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) = do rate <- queryCompound t d (patchDateToStats d ds) - return b {L.bndRate = fromRational (toRational rate * toRational factor) } - -setBondNewRate t d ras b@(L.Bond _ _ _ ii _ _ _ _ _ _ _ _ _ _) - = Right $ b { L.bndRate = applyFloatRate ii d ras } + let accrueInt = calcInt (bal + dueInt) dueIntDate d (fromRational rate) DC_ACT_365F + return b {L.bndRate = fromRational (rate * toRational factor) + ,L.bndDueInt = dueInt + accrueInt, L.bndDueIntDate = Just d} + +-- ^ floater bond +setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Floater br idx _spd rset dc mf mc) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) + = Right $ b { L.bndRate = applyFloatRate ii d ras + , L.bndDueInt = dueInt + accrueInt, L.bndDueIntDate = Just d} + where + (Just dc) = getDayCountFromInfo ii + accrueInt = calcInt (bal + dueInt) dueIntDate d currentRate dc setBondNewRate t d ras bg@(L.BondGroup bMap) = do @@ -113,18 +151,17 @@ updateSrtRate t d ras srt@HE.SRT{HE.srtPremiumType = rt} = srt { HE.srtPremiumRate = applyFloatRate2 rt d ras } -accrueSrt :: Ast.Asset a => TestDeal a -> Date -> HE.SRT -> HE.SRT +accrueSrt :: Ast.Asset a => TestDeal a -> Date -> HE.SRT -> Either String HE.SRT accrueSrt t d srt@HE.SRT{ HE.srtDuePremium = duePrem, HE.srtRefBalance = bal, HE.srtPremiumRate = rate , HE.srtDuePremiumDate = mDueDate, HE.srtType = st , HE.srtStart = sd } - = srt { HE.srtRefBalance = newBal, HE.srtDuePremium = newPremium, HE.srtDuePremiumDate = Just d} - where - newBal = case st of - HE.SrtByEndDay ds dp -> queryDeal t (patchDateToStats d ds) - _ -> error "not support new bal type for Srt" - newPremium = duePrem + calcInt newBal (fromMaybe sd mDueDate) d rate DC_ACT_365F - accrueInt = calcInt (HE.srtRefBalance srt + duePrem) (fromMaybe d (HE.srtDuePremiumDate srt)) d (HE.srtPremiumRate srt) DC_ACT_365F - dueInt = HE.srtDuePremium + = do + newBal <- case st of + HE.SrtByEndDay ds dp -> queryCompound t d (patchDateToStats d ds) + _ -> Left "not support new bal type for Srt" + let newPremium = duePrem + calcInt (fromRational newBal) (fromMaybe sd mDueDate) d rate DC_ACT_365F + let accrueInt = calcInt (HE.srtRefBalance srt + duePrem) (fromMaybe d (HE.srtDuePremiumDate srt)) d (HE.srtPremiumRate srt) DC_ACT_365F + return srt { HE.srtRefBalance = fromRational newBal, HE.srtDuePremium = newPremium, HE.srtDuePremiumDate = Just d} updateLiqProviderRate :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> CE.LiqFacility -> CE.LiqFacility @@ -195,45 +232,49 @@ updateRateSwapRate rAssumps d rs@HE.RateSwap{ HE.rsType = rt } HE.FixedToFloating r flter -> (r , getRate flter) getRate x = AP.lookupRate rAssumps x d -updateRateSwapBal :: Ast.Asset a => TestDeal a -> Date -> HE.RateSwap -> HE.RateSwap +updateRateSwapBal :: Ast.Asset a => TestDeal a -> Date -> HE.RateSwap -> Either String HE.RateSwap updateRateSwapBal t d rs@HE.RateSwap{ HE.rsNotional = base } = case base of - HE.Fixed _ -> rs - HE.Base ds -> rs { HE.rsRefBalance = queryDeal t (patchDateToStats d ds) } -- `debug` ("query Result"++ show (patchDateToStats d ds) ) - HE.Schedule ts -> rs { HE.rsRefBalance = fromRational (getValByDate ts Inc d) } + HE.Fixed _ -> Right rs + HE.Schedule ts -> Right $ rs { HE.rsRefBalance = fromRational (getValByDate ts Inc d) } + HE.Base ds -> + do + v <- queryCompound t d (patchDateToStats d ds) + return rs { HE.rsRefBalance = fromRational v} -- `debug` ("query Result"++ show (patchDateToStats d ds) ) -- ^ accure rate cap -accrueRC :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> RateCap -> RateCap +accrueRC :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> RateCap -> Either String RateCap accrueRC t d rs rc@RateCap{rcNetCash = amt, rcStrikeRate = strike,rcIndex = index ,rcStartDate = sd, rcEndDate = ed, rcNotional = notional ,rcLastStlDate = mlsd ,rcStmt = mstmt} - | d > ed || d < sd = rc - | otherwise = rc { rcLastStlDate = Just d ,rcNetCash = newAmt, - rcStmt = newStmt } - where + | d > ed || d < sd = Right rc + | otherwise = let r = lookupRate0 rs index d - balance = case notional of - Fixed bal -> bal - Base ds -> queryDeal t (patchDateToStats d ds) - Schedule ts -> fromRational $ getValByDate ts Inc d - - accRate = max 0 $ r - fromRational (getValByDate strike Inc d) -- `debug` ("Rate from curve"++show (getValByDate strike Inc d)) - addAmt = case mlsd of - Nothing -> calcInt balance sd d accRate DC_ACT_365F - Just lstD -> calcInt balance lstD d accRate DC_ACT_365F - - newAmt = amt + addAmt -- `debug` ("Accrue AMT"++ show addAmt) - newStmt = appendStmt mstmt $ IrsTxn d newAmt addAmt 0 0 0 SwapAccrue + in + do + balance <- case notional of + Fixed bal -> Right . toRational $ bal + Base ds -> queryCompound t d (patchDateToStats d ds) + Schedule ts -> Right $ getValByDate ts Inc d + + let accRate = max 0 $ r - fromRational (getValByDate strike Inc d) -- `debug` ("Rate from curve"++show (getValByDate strike Inc d)) + let addAmt = case mlsd of + Nothing -> calcInt (fromRational balance) sd d accRate DC_ACT_365F + Just lstD -> calcInt (fromRational balance) lstD d accRate DC_ACT_365F + + let newAmt = amt + addAmt -- `debug` ("Accrue AMT"++ show addAmt) + let newStmt = appendStmt mstmt $ IrsTxn d newAmt addAmt 0 0 0 SwapAccrue + return $ rc { rcLastStlDate = Just d ,rcNetCash = newAmt, rcStmt = newStmt } -- ^ test if a clean up call should be fired testCall :: Ast.Asset a => TestDeal a -> Date -> C.CallOption -> Either String Bool testCall t d opt = case opt of - C.PoolBalance x -> Right $ queryDeal t (FutureCurrentPoolBalance Nothing) < x - C.BondBalance x -> Right $ queryDeal t CurrentBondBalance < x - C.PoolFactor x -> (< x) <$> (queryCompound t d (FutureCurrentPoolFactor d Nothing)) -- `debug` ("D "++show d++ "Pool Factor query ->" ++ show (queryDealRate t (FutureCurrentPoolFactor d))) - C.BondFactor x -> (< x) <$> (queryCompound t d BondFactor) + C.PoolBalance x -> (< x) <$> fromRational <$> queryCompound t d (FutureCurrentPoolBalance Nothing) + C.BondBalance x -> (< x) <$> fromRational <$> queryCompound t d CurrentBondBalance + C.PoolFactor x -> (< x) <$> queryCompound t d (FutureCurrentPoolFactor d Nothing) -- `debug` ("D "++show d++ "Pool Factor query ->" ++ show (queryDealRate t (FutureCurrentPoolFactor d))) + C.BondFactor x -> (< x) <$> queryCompound t d BondFactor C.OnDate x -> Right $ x == d C.AfterDate x -> Right $ d > x C.And xs -> allM (testCall t d) xs @@ -241,12 +282,7 @@ testCall t d opt = -- C.And xs -> (all id) <$> sequenceA $ [testCall t d x | x <- xs] -- C.Or xs -> (any id) <$> sequenceA $ [testCall t d x | x <- xs] C.Pre pre -> testPre d t pre - _ -> error ("failed to find call options"++ show opt) - --- ^ if any of the call options are satisfied --- testCalls :: Ast.Asset a => TestDeal a -> Date -> [C.CallOption] -> Bool --- testCalls t d [] = False --- testCalls t d opts = any (testCall t d) opts + _ -> Left ("failed to find call options"++ show opt) queryTrigger :: Ast.Asset a => TestDeal a -> DealCycle -> [Trigger] @@ -283,49 +319,43 @@ runEffects (t@TestDeal{accounts = accMap, fees = feeMap ,status=st, bonds = bond Warehousing nextSt = st -- issue bonds newBonds = Map.map (L.setBondOrigDate closingDate) bondMap - --- TODO for floater rate bond ,need to update rate in the bond - draftBondBals = queryDeal t CurrentBondBalance - - ---- determine the balance of issuance - totalIssuanceBalance = case mIssuanceBal of - Nothing -> draftBondBals - Just fml -> queryDeal t fml - scaleFactor = toRational $ totalIssuanceBalance / draftBondBals - scaledBndMap = Map.map (L.scaleBond scaleFactor) newBonds - - accAfterIssue = Map.adjust (A.deposit totalIssuanceBalance d (IssuanceProceeds "ALL")) accName accMap - -- sell assets - ----- valuation on pools - assetVal = case pt of - SoloPool p -> P.calcLiquidationAmount pm p closingDate - MultiPool pMap -> sum $ Map.map (\p -> P.calcLiquidationAmount pm p closingDate) pMap - assetBal = queryDeal t (FutureCurrentPoolBalance Nothing) - accAfterBought = Map.adjust (A.draw assetVal d (PurchaseAsset "ALL" assetBal)) accName accMap - - -- reset pool flow flow - dealPoolFlowMap = Map.map (maybe 0 ((CF.mflowBalance . head) . (view CF.cashflowTxn))) - $ view dealCashflow t - newPt = patchIssuanceBalance st dealPoolFlowMap pt - ---- reset pool stats - newPt2 = case newPt of - SoloPool _pt -> SoloPool $ over (P.poolFutureCf2 . CF.cashflowTxn) (CF.patchCumulative (0,0,0,0,0,0) []) _pt - MultiPool pm -> MultiPool $ Map.map (over (P.poolFutureCf2 . CF.cashflowTxn) (CF.patchCumulative (0,0,0,0,0,0) [])) pm - x -> x - -- build actions dates firstPayDate = T.addDays (toInteger offset0) closingDate firstCollectDate = T.addDays (toInteger offset1) closingDate - distributionDays = [ RunWaterfall _d "" | _d <- genSerialDatesTill2 IE firstPayDate bDp endDate] poolCollectionDays = [ PoolCollection _d "" | _d <- genSerialDatesTill2 IE firstCollectDate pDp endDate] newActions = (DealClosed closingDate):(sortBy sortActionOnDate (distributionDays++poolCollectionDays)) - in - Right (t {status = fromMaybe Amortizing nextSt, bonds = scaledBndMap, accounts=accAfterBought, pool = newPt2 - ,collects = fromMaybe collRules mCollectRules} - , rc - , cutBy Inc Past d actions ++ newActions - , logs) --TODO add actions to close deal + --- TODO for floater rate bond ,need to update rate in the bond + in + do + draftBondBals <- queryCompound t d CurrentBondBalance + totalIssuanceBalance <- case mIssuanceBal of + Nothing -> Right draftBondBals + Just fml -> queryCompound t d fml + let scaleFactor = toRational $ totalIssuanceBalance / draftBondBals + let scaledBndMap = Map.map (L.scaleBond scaleFactor) newBonds + let accAfterIssue = Map.adjust (A.deposit (fromRational totalIssuanceBalance) d (IssuanceProceeds "ALL")) accName accMap + + let assetVal = case pt of + MultiPool pMap -> sum $ Map.map (\p -> P.calcLiquidationAmount pm p closingDate) pMap + assetBal <- queryCompound t d (FutureCurrentPoolBalance Nothing) + let accAfterBought = Map.adjust (A.draw assetVal d (PurchaseAsset "ALL" (fromRational assetBal))) accName accMap + + -- reset pool flow flow + let dealPoolFlowMap = Map.map (maybe 0 ((CF.mflowBalance . head) . (view CF.cashflowTxn))) + $ view dealCashflow t + let newPt = patchIssuanceBalance st dealPoolFlowMap pt + ---- reset pool stats + let newPt2 = case newPt of + MultiPool pm -> MultiPool $ Map.map (over (P.poolFutureCf2 . CF.cashflowTxn) (CF.patchCumulative (0,0,0,0,0,0) [])) pm + x -> x + -- build actions dates + return (t {status = fromMaybe Amortizing nextSt, bonds = scaledBndMap, accounts=accAfterBought, pool = newPt2 + ,collects = fromMaybe collRules mCollectRules} + , rc + , cutBy Inc Past d actions ++ newActions + , logs) --TODO add actions to close deal DoNothing -> Right (t, rc, actions, []) - _ -> error $ "Failed to match trigger effects: "++show te + _ -> Left $ "Date:"++ show d++" Failed to match trigger effects: "++show te -- ^ test triggers in the deal and add a log if deal status changed runTriggers :: Ast.Asset a => (TestDeal a, RunContext a, [ActionOnDate]) -> Date -> DealCycle -> Either String (TestDeal a, RunContext a, [ActionOnDate], [ResultComponent]) @@ -340,14 +370,19 @@ runTriggers (t@TestDeal{status=oldStatus, triggers = Just trgM},rc, actions) d d let triggeredEffects = [ trgEffects _trg | _trg <- Map.elems triggeredTrgs, (trgStatus _trg) ] (newDeal, newRc, newActions, logsFromTrigger) <- foldM (`runEffects` d) (t,rc,actions,[]) triggeredEffects let newStatus = status newDeal - let newLogs = [DealStatusChangeTo d oldStatus newStatus | newStatus /= oldStatus] -- `debug` (">>"++show d++"trigger : new st"++ show newStatus++"old st"++show oldStatus) + let newLogs = [DealStatusChangeTo d oldStatus newStatus "By trigger"| newStatus /= oldStatus] -- `debug` (">>"++show d++"trigger : new st"++ show newStatus++"old st"++show oldStatus) let newTriggers = Map.union triggeredTrgs trgsMap return (newDeal {triggers = Just (Map.insert dcycle newTriggers trgM)} , newRc , newActions , newLogs++logsFromTrigger) -- `debug` ("New logs from trigger"++ show d ++">>>"++show newLogs) - + +changeDealStatus:: Ast.Asset a => (Date,String)-> DealStatus -> TestDeal a -> (Maybe ResultComponent, TestDeal a) +-- ^ no status change for deal already ended +changeDealStatus _ _ t@TestDeal{status=Ended} = (Nothing, t) +changeDealStatus (d,why) newSt t@TestDeal{status=oldSt} = (Just (DealStatusChangeTo d oldSt newSt why), t {status=newSt}) + run :: Ast.Asset a => TestDeal a -> Map.Map PoolId CF.CashFlowFrame -> Maybe [ActionOnDate] -> Maybe [RateAssumption] -> Maybe ([Pre],[Pre]) -> Maybe (Map.Map String (RevolvingPool,AP.ApplyAssumptionType))-> [ResultComponent] -> Either String (TestDeal a,[ResultComponent]) run t@TestDeal{status=Ended} pCfM ads _ _ _ log = Right (prepareDeal t,log++[EndRun Nothing "By Status:Ended"]) @@ -356,321 +391,322 @@ run t pCfM (Just [HitStatedMaturity d]) _ _ _ log = Right (prepareDeal t,log++[ run t pCfM (Just (StopRunFlag d:_)) _ _ _ log = Right (prepareDeal t,log++[EndRun (Just d) "Stop Run Flag"]) run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status=dStatus,waterfall=waterfallM,name=dealName,pool=pt} poolFlowMap (Just (ad:ads)) rates calls rAssump log - | all (== 0) futureCashToCollect && (queryDeal t AllAccBalance == 0) && (dStatus /= Revolving) && (dStatus /= Warehousing Nothing) --TODO need to use prsim here to cover all warehouse status + | all (== 0) futureCashToCollect && (queryCompound t (getDate ad) AllAccBalance == Right 0) && (dStatus /= Revolving) && (dStatus /= Warehousing Nothing) --TODO need to use prsim here to cover all warehouse status = do - -- finalDeal = foldl (performAction (getDate ad)) t cleanUpActions let runContext = RunContext poolFlowMap rAssump rates (finalDeal,_,newLogs) <- foldM (performActionWrap (getDate ad)) (t,runContext,log) cleanUpActions return (prepareDeal finalDeal,newLogs++[EndRun (Just (getDate ad)) "No Pool Cashflow/All Account is zero/Not revolving"]) -- `debug` ("End of pool collection with logs with length "++ show (length log)) | otherwise - = case ad of - PoolCollection d _ -> - if any (> 0) remainCollectionNum then - let - cutOffPoolFlowMap = Map.map (\pflow -> CF.splitCashFlowFrameByDate pflow d EqToLeft) poolFlowMap - collectedFlow = Map.map fst cutOffPoolFlowMap - -- outstandingFlow = Map.map (CF.insertBegTsRow d . snd) cutOffPoolFlowMap - outstandingFlow = Map.map snd cutOffPoolFlowMap - -- deposit cashflow to SPV from external pool cf - accs = depositPoolFlow (collects t) d collectedFlow accMap -- `debug` ("d"++ show d++">>>"++ show collectedFlow++"\n") - - dAfterDeposit = (appendCollectedCF d t collectedFlow) {accounts=accs} -- `debug` ("Collected flow"++ show collectedFlow) - - -- newScheduleFlowMap = Map.map (over CF.cashflowTxn (cutBy Exc Future d)) (fromMaybe Map.empty (getScheduledCashflow t Nothing)) - dealAfterUpdateScheduleFlow = over dealScheduledCashflow - (Map.map (\mflow -> over CF.cashflowTxn (cutBy Exc Future d) <$> mflow)) - dAfterDeposit - - runContext = RunContext outstandingFlow rAssump rates - - in - do - (dRunWithTrigger0, rc1,ads2, newLogs0) <- runTriggers (dealAfterUpdateScheduleFlow,runContext,ads) d EndCollection - let eopActionsLog = [ RunningWaterfall d W.EndOfPoolCollection | Map.member W.EndOfPoolCollection waterfallM ] -- `debug` ("new logs from trigger 1"++ show newLogs0) - let waterfallToExe = Map.findWithDefault [] W.EndOfPoolCollection (waterfall t) -- `debug` ("new logs from trigger 1"++ show newLogs0) - (dAfterAction,rc2,newLogs) <- foldM (performActionWrap d) (dRunWithTrigger0 ,rc1 ,log ) waterfallToExe -- `debug` ("End collection action"++ show waterfallToExe) - (dRunWithTrigger1,rc3,ads3,newLogs1) <- runTriggers (dAfterAction,rc2,ads2) d EndCollectionWF -- `debug` ("new logs from waterfall 2"++ show newLogs) - run dRunWithTrigger1 (runPoolFlow rc3) (Just ads3) rates calls rAssump (newLogs0++newLogs++ eopActionsLog ++newLogs1) -- `debug` ("Run logs pool collection "++ show (length (log++newLogs0++newLogs++newLogs1))) -- `debug` ("last log"++ show (last ads)) -- `debug` ("End :after new pool flow"++ show (runPoolFlow rc)) - else - run t poolFlowMap (Just ads) rates calls rAssump log + = case ad of + PoolCollection d _ -> + if any (> 0) remainCollectionNum then + let + cutOffPoolFlowMap = Map.map (\pflow -> CF.splitCashFlowFrameByDate pflow d EqToLeft) poolFlowMap + collectedFlow = Map.map fst cutOffPoolFlowMap -- `debug` ("PoolCollection : "++ show d ++ " splited"++ show cutOffPoolFlowMap++"\n input pflow"++ show poolFlowMap) + -- outstandingFlow = Map.map (CF.insertBegTsRow d . snd) cutOffPoolFlowMap + outstandingFlow = Map.map snd cutOffPoolFlowMap + -- deposit cashflow to SPV from external pool cf + in + do + let accs = depositPoolFlow (collects t) d collectedFlow accMap -- `debug` ("PoolCollection: deposit >>"++ show d++">>>"++ show collectedFlow++"\n") + let dAfterDeposit = (appendCollectedCF d t collectedFlow) {accounts=accs} -- `debug` ("Collected flow"++ show collectedFlow) + -- newScheduleFlowMap = Map.map (over CF.cashflowTxn (cutBy Exc Future d)) (fromMaybe Map.empty (getScheduledCashflow t Nothing)) + let dealAfterUpdateScheduleFlow = over dealScheduledCashflow + (Map.map (\mflow -> over CF.cashflowTxn (cutBy Exc Future d) <$> mflow)) + dAfterDeposit + let runContext = RunContext outstandingFlow rAssump rates -- `debug` ("PoolCollection: before rc >>"++ show d++">>>"++ show (pool dAfterDeposit)) + (dRunWithTrigger0, rc1,ads2, newLogs0) <- runTriggers (dealAfterUpdateScheduleFlow,runContext,ads) d EndCollection -- `debug` ("PoolCollection: after update schedule flow >>"++ show d++">>"++show (pool dealAfterUpdateScheduleFlow)) + let eopActionsLog = [ RunningWaterfall d W.EndOfPoolCollection | Map.member W.EndOfPoolCollection waterfallM ] -- `debug` ("new logs from trigger 1"++ show newLogs0) + let waterfallToExe = Map.findWithDefault [] W.EndOfPoolCollection (waterfall t) -- `debug` ("new logs from trigger 1"++ show newLogs0) + (dAfterAction,rc2,newLogs) <- foldM (performActionWrap d) (dRunWithTrigger0 ,rc1 ,log ) waterfallToExe -- `debug` ("Pt 03"++ show d++">> context flow"++show (pool dRunWithTrigger0))-- `debug` ("End collection action"++ show waterfallToExe) + (dRunWithTrigger1,rc3,ads3,newLogs1) <- runTriggers (dAfterAction,rc2,ads2) d EndCollectionWF -- `debug` ("PoolCollection: Pt 04"++ show d++">> context flow"++show (runPoolFlow rc2))-- `debug` ("End collection action"++ show waterfallToExe) + run dRunWithTrigger1 (runPoolFlow rc3) (Just ads3) rates calls rAssump (newLogs0++newLogs++ eopActionsLog ++newLogs1) -- `debug` ("PoolCollection: Pt 05>> "++ show d++">> context flow>> "++show (runPoolFlow rc3)) + else + run t poolFlowMap (Just ads) rates calls rAssump log -- `debug` ("PoolCollection: hit zero pool length"++ show d++"pool"++ (show poolFlowMap)++"collected cf"++ show pt) - RunWaterfall d _ -> - let - runContext = RunContext poolFlowMap rAssump rates - - -- ads1 should be replace in the future - -- newLogs0 -> record the deal status change info ,incremental - -- warning if not waterfall distribution found - waterfallKey = if Map.member (W.DistributionDay dStatus) waterfallM then - W.DistributionDay dStatus - else - W.DefaultDistribution - - waterfallToExe = Map.findWithDefault [] waterfallKey waterfallM - callTest = fst $ fromMaybe ([]::[Pre],[]::[Pre]) calls - in - do - (dRunWithTrigger0, rc1, ads1, newLogs0) <- runTriggers (t, runContext, ads) d BeginDistributionWF - let logsBeforeDist = newLogs0++[ WarningMsg (" No waterfall distribution found on date "++show d++" with waterfall key "++show waterfallKey) - | Map.notMember waterfallKey waterfallM ] - flag <- anyM (testPre d dRunWithTrigger0) callTest - if flag then - do - let newStLogs = if null cleanUpActions then - [DealStatusChangeTo d dStatus Called] - else - [DealStatusChangeTo d dStatus Called, RunningWaterfall d W.CleanUp] - (dealAfterCleanUp, rc_, newLogWaterfall_ ) <- foldM (performActionWrap d) (dRunWithTrigger0, rc1,log) cleanUpActions - endingLogs <- Rpt.patchFinancialReports dealAfterCleanUp d newLogWaterfall_ - return (prepareDeal dealAfterCleanUp, endingLogs ++ logsBeforeDist ++newStLogs++[EndRun (Just d) "Clean Up"]) -- `debug` ("Called ! "++ show d) - else - do - (dAfterWaterfall, rc2, newLogsWaterfall) <- foldM (performActionWrap d) (dRunWithTrigger0,rc1,log) waterfallToExe - (dRunWithTrigger1, rc3, ads2, newLogs2) <- runTriggers (dAfterWaterfall,rc2,ads1) d EndDistributionWF - run dRunWithTrigger1 (runPoolFlow rc3) (Just ads2) rates calls rAssump (newLogsWaterfall++newLogs2++logsBeforeDist++[RunningWaterfall d waterfallKey]) - - EarnAccInt d accName -> - let - newAcc = Map.adjust (A.depositInt d) accName accMap - in - run (t {accounts = newAcc}) poolFlowMap (Just ads) rates calls rAssump log - - AccrueFee d feeName -> - let - fToAcc = feeMap Map.! feeName - in - do - newF <- calcDueFee t d fToAcc - let newFeeMap = (Map.fromList [(feeName,newF)]) <> feeMap - run (t{fees=newFeeMap}) poolFlowMap (Just ads) rates calls rAssump log + RunWaterfall d _ -> + let + runContext = RunContext poolFlowMap rAssump rates + waterfallKey = if Map.member (W.DistributionDay dStatus) waterfallM then + W.DistributionDay dStatus + else + W.DefaultDistribution + + waterfallToExe = Map.findWithDefault [] waterfallKey waterfallM + callTest = fst $ fromMaybe ([]::[Pre],[]::[Pre]) calls + in + do + (dRunWithTrigger0, rc1, ads1, newLogs0) <- runTriggers (t, runContext, ads) d BeginDistributionWF -- `debug` ("In RunWaterfall Date"++show d++"before run trigger>> collected"++ show (pool t)) + let logsBeforeDist = newLogs0++[ WarningMsg (" No waterfall distribution found on date "++show d++" with waterfall key "++show waterfallKey) + | Map.notMember waterfallKey waterfallM ] + flag <- anyM (testPre d dRunWithTrigger0) callTest -- `debug` ( "In RunWaterfall status after before waterfall trigger >>"++ show (status dRunWithTrigger0) ) + if flag then + do + let newStLogs = if null cleanUpActions then + [DealStatusChangeTo d dStatus Called "Call by triggers before waterfall distribution"] + else + [DealStatusChangeTo d dStatus Called "Call by triggers before waterfall distribution", RunningWaterfall d W.CleanUp] + (dealAfterCleanUp, rc_, newLogWaterfall_ ) <- foldM (performActionWrap d) (dRunWithTrigger0, rc1,log) cleanUpActions + endingLogs <- Rpt.patchFinancialReports dealAfterCleanUp d newLogWaterfall_ + return (prepareDeal dealAfterCleanUp, endingLogs ++ logsBeforeDist ++newStLogs++[EndRun (Just d) "Clean Up"]) -- `debug` ("Called ! "++ show d) + else + do + (dAfterWaterfall, rc2, newLogsWaterfall) <- foldM (performActionWrap d) (dRunWithTrigger0,rc1,log) waterfallToExe -- `debug` ("In RunWaterfall Date"++show d++">>> status "++show (status dRunWithTrigger0)++"before run waterfall collected >>"++ show (pool dRunWithTrigger0)) + (dRunWithTrigger1, rc3, ads2, newLogs2) <- runTriggers (dAfterWaterfall,rc2,ads1) d EndDistributionWF -- `debug` ("In RunWaterfall Date"++show d++"after run waterfall >>"++ show (runPoolFlow rc2)++" collected >>"++ show (pool dAfterWaterfall)) + run dRunWithTrigger1 (runPoolFlow rc3) (Just ads2) rates calls rAssump (newLogsWaterfall++newLogs2++logsBeforeDist++[RunningWaterfall d waterfallKey]) -- `debug` ("In RunWaterfall Date"++show d++"after run waterfall 3>>"++ show (pool dRunWithTrigger1)++" status>>"++ show (status dRunWithTrigger1)) + + EarnAccInt d accName -> + let + newAcc = Map.adjust (A.depositInt d) accName accMap + in + run (t {accounts = newAcc}) poolFlowMap (Just ads) rates calls rAssump log + + AccrueFee d feeName -> + let + fToAcc = feeMap Map.! feeName + in + do + newF <- calcDueFee t d fToAcc + let newFeeMap = (Map.fromList [(feeName,newF)]) <> feeMap + run (t{fees=newFeeMap}) poolFlowMap (Just ads) rates calls rAssump log - ResetLiqProvider d liqName -> - case liqProvider t of - Nothing -> run t poolFlowMap (Just ads) rates calls rAssump log - (Just mLiqProvider) - -> let -- update credit - newLiqMap = Map.adjust (updateLiqProvider t d) liqName mLiqProvider - in - run (t{liqProvider = Just newLiqMap}) poolFlowMap (Just ads) rates calls rAssump log - - ResetLiqProviderRate d liqName -> - case liqProvider t of - Nothing -> run t poolFlowMap (Just ads) rates calls rAssump log - (Just mLiqProvider) - -> let -- update rate - newLiqMap = Map.adjust (updateLiqProviderRate t d (fromMaybe [] rates)) liqName mLiqProvider - in - run (t{liqProvider = Just newLiqMap}) poolFlowMap (Just ads) rates calls rAssump log + ResetLiqProvider d liqName -> + case liqProvider t of + Nothing -> run t poolFlowMap (Just ads) rates calls rAssump log + (Just mLiqProvider) + -> let -- update credit + newLiqMap = Map.adjust (updateLiqProvider t d) liqName mLiqProvider + in + run (t{liqProvider = Just newLiqMap}) poolFlowMap (Just ads) rates calls rAssump log + + ResetLiqProviderRate d liqName -> + case liqProvider t of + Nothing -> run t poolFlowMap (Just ads) rates calls rAssump log + (Just mLiqProvider) + -> let -- update rate + newLiqMap = Map.adjust (updateLiqProviderRate t d (fromMaybe [] rates)) liqName mLiqProvider + in + run (t{liqProvider = Just newLiqMap}) poolFlowMap (Just ads) rates calls rAssump log - DealClosed d -> - let - newSt = case dStatus of - (PreClosing st) -> st - _ -> error $ "DealClosed action is not in PreClosing status but got"++ show dStatus - w = Map.findWithDefault [] W.OnClosingDay (waterfall t) -- `debug` ("DDD0") - rc = RunContext poolFlowMap rAssump rates - logForClosed = [RunningWaterfall d W.OnClosingDay| not (null w)] -- `debug` ("DDD1")] - in - do - (newDeal, newRc, newLog) <- foldM (performActionWrap d) (t, rc, log) w -- `debug` ("ClosingDay Action:"++show w) - run newDeal{status=newSt} (runPoolFlow newRc) (Just ads) rates calls rAssump (newLog++[DealStatusChangeTo d (PreClosing newSt) newSt]++logForClosed) -- `debug` ("new st at closing"++ show newSt) - - ChangeDealStatusTo d s -> run (t{status=s}) poolFlowMap (Just ads) rates calls rAssump log - - ResetIRSwapRate d sn -> - let - _rates = fromMaybe [] rates - newRateSwap_rate = Map.adjust (updateRateSwapRate _rates d) sn <$> rateSwap t - newRateSwap_bal = Map.adjust (updateRateSwapBal t d) sn <$> newRateSwap_rate - newRateSwap_acc = Map.adjust (HE.accrueIRS d) sn <$> newRateSwap_bal - in - run (t{rateSwap = newRateSwap_acc}) poolFlowMap (Just ads) rates calls rAssump log - - AccrueCapRate d cn -> - let - _rates = fromMaybe [] rates - newRateCap = Map.adjust (accrueRC t d _rates) cn <$> rateCap t - in - run (t{rateCap = newRateCap}) poolFlowMap (Just ads) rates calls rAssump log - - InspectDS d dss -> - do - newlog <- inspectListVars t d dss - run t poolFlowMap (Just ads) rates calls rAssump $ log++newlog -- `debug` ("Add log"++show newlog) - - ResetBondRate d bn -> - let - rateList = fromMaybe [] rates - bnd = bndMap Map.! bn - in - do - newBnd <- setBondNewRate t d rateList bnd - run t{bonds = Map.fromList [(bn,newBnd)] <> bndMap} poolFlowMap (Just ads) rates calls rAssump log - - ResetAccRate d accName -> - let - newAccMap = Map.adjust - (\a@(A.Account _ _ (Just (A.InvestmentAccount idx spd dp dp1 lastDay _)) _ _) - -> let - newRate = AP.lookupRate (fromMaybe [] rates) (idx,spd) d - newAccInt = Just (A.InvestmentAccount idx spd dp dp1 lastDay newRate) - in - a { A.accInterest = newAccInt} - ) - accName accMap - in - run t{accounts = newAccMap} poolFlowMap (Just ads) rates calls rAssump log - - BuildReport sd ed -> - let - cashReport = Rpt.buildCashReport t sd ed - in - do - bsReport <- Rpt.buildBalanceSheet t ed -- `debug` ("bs report"++ show ed) - let newlog = FinancialReport sd ed bsReport cashReport - run t poolFlowMap (Just ads) rates calls rAssump $ log++[newlog] -- `debug` ("new log"++ show ed++ show newlog) - - FireTrigger d cyc n -> - let - triggerFired = case mTrgMap of - Nothing -> error "trigger is empty for override" - Just tm -> Map.adjust (Map.adjust (set trgStatusLens True) n) cyc tm - triggerEffects = case mTrgMap of - Nothing -> Nothing - Just tm -> case Map.lookup cyc tm of - Nothing -> Nothing - Just cycM -> case Map.lookup n cycM of - Nothing -> Nothing - Just trg -> Just $ trgEffects trg - - runContext = RunContext poolFlowMap rAssump rates - in - do - (newT, rc@(RunContext newPool _ _),adsFromTrigger, newLogsFromTrigger) - <- case triggerEffects of - Nothing -> Right (t, runContext, ads, []) -- `debug` "Nothing found on effects" - Just efs -> runEffects (t, runContext, ads, []) d efs - let (oldStatus,newStatus) = (status t,status newT) - let stChangeLogs = [DealStatusChangeTo d oldStatus newStatus | oldStatus /= newStatus] - let newLog = WarningMsg $ "Trigger Overrided to True "++ show(d,cyc,n) - run newT {triggers = Just triggerFired} newPool (Just ads) rates calls rAssump $ log++[newLog]++stChangeLogs++newLogsFromTrigger - - MakeWhole d spd walTbl -> - let - schedulePoolFlowMap = Map.map (fromMaybe (CF.CashFlowFrame (0,epocDate,Nothing) [])) $ view dealScheduledCashflow t - factor = divideBB (queryDeal t (FutureCurrentPoolBegBalance Nothing)) (queryDeal t (FutureCurrentSchedulePoolBegBalance Nothing)) - reduceCfs = Map.map (over CF.cashflowTxn (\xs -> (CF.scaleTsRow factor) <$> xs)) schedulePoolFlowMap -- need to apply with factor and trucate with date - in - do - (runDealWithSchedule,_) <- run t reduceCfs (Just ads) rates calls rAssump $ log - let bondWal = Map.map (L.calcWalBond d) (bonds runDealWithSchedule) -- `debug` ("Bond schedule flow"++ show (bonds runDealWithSchedule)) - let bondSprd = Map.map - (\x -> (spd + (fromMaybe 0 (lookupTable walTbl Up (fromRational x >))))) - bondWal - let bondPricingCurve = Map.map - (\x -> IRateCurve [ TsPoint d x,TsPoint (getDate (last ads)) x] ) - bondSprd - let bondPricingResult = Map.intersectionWithKey (\k v1 v2 -> L.priceBond d v2 v1) (bonds runDealWithSchedule) bondPricingCurve - let depositBondFlow = Map.intersectionWith - (\bnd (PriceResult pv _ _ _ _ _ _) -> - let - ostBal = L.getCurBalance bnd - prinToPay = min pv ostBal - intToPay = max 0 (pv - prinToPay) - bnd1 = L.payPrin d prinToPay bnd - in - L.payYield d intToPay bnd1) - (bonds t) - bondPricingResult - run t {bonds = depositBondFlow, status = Ended } poolFlowMap (Just []) rates calls rAssump $ log++[EndRun (Just d) "MakeWhole call"] - - IssueBond d Nothing bGroupName accName bnd mBal mRate -> - run t poolFlowMap (Just ((IssueBond d (Just (Always True)) bGroupName accName bnd mBal mRate):ads)) rates calls rAssump log - - IssueBond d (Just p) bGroupName accName bnd mBal mRate -> - do - flag <- testPre d t p - case flag of - False -> run t poolFlowMap (Just ads) rates calls rAssump (log ++ [WarningMsg ("Failed to issue to bond group"++ bGroupName++ ":" ++show p)]) - True -> let - newBndName = L.bndName bnd - newBalance = case mBal of - Just _q -> queryDeal t (patchDateToStats d _q) - Nothing -> L.originBalance (L.bndOriginInfo bnd) - in - do - newRate <- case mRate of - Just _q -> queryCompound t d (patchDateToStats d _q) - Nothing -> Right $ L.originRate (L.bndOriginInfo bnd) - let newBonds = case Map.lookup bGroupName bndMap of - Nothing -> bndMap - Just L.Bond {} -> bndMap - Just (L.BondGroup bndGrpMap) -> let - bndOInfo = (L.bndOriginInfo bnd) {L.originDate = d, L.originRate = newRate, L.originBalance = newBalance } - bndToInsert = bnd {L.bndOriginInfo = bndOInfo, - L.bndDueIntDate = Just d, - L.bndLastIntPay = Just d, - L.bndLastPrinPay = Just d, - L.bndRate = fromRational newRate, - L.bndBalance = newBalance} - in - Map.insert bGroupName - (L.BondGroup (Map.insert newBndName bndToInsert bndGrpMap)) - bndMap - - let issuanceProceeds = newBalance - let newAcc = Map.adjust (A.deposit issuanceProceeds d (IssuanceProceeds newBndName)) - accName - accMap - run t{bonds = newBonds, accounts = newAcc} poolFlowMap (Just ads) rates calls rAssump log - RefiBondRate d accName bName iInfo -> - let - -- settle accrued interest - -- TODO rebuild bond rate reset actions - lstDate = getDate (last ads) - in - do - nBnd <- calcDueInt t d Nothing Nothing $ bndMap Map.! bName - let isResetActionEvent (ResetBondRate _ bName) = False - let isResetActionEvent _ = True - let filteredAds = filter isResetActionEvent ads - let newRate = L.getBeginRate iInfo - let dueIntToPay = L.totalDueInt nBnd - let ((shortfall,drawAmt),newAcc) = A.tryDraw dueIntToPay d (PayInt [bName]) (accMap Map.! accName) - let newBnd = set L.bndIntLens iInfo $ L.payInt d drawAmt nBnd - let resetDates = L.buildRateResetDates newBnd d lstDate - let bResetActions = [ ResetBondRate d bName | d <- resetDates ] - let newAccMap = Map.insert accName newAcc accMap - let newBndMap = Map.insert bName (newBnd {L.bndRate = newRate, L.bndDueIntDate = Just d - ,L.bndLastIntPay = Just d}) bndMap - let newAds = sortBy sortActionOnDate $ filteredAds ++ bResetActions - run t{bonds = newBndMap, accounts = newAccMap} poolFlowMap (Just newAds) rates calls rAssump log - - RefiBond d accName bnd -> undefined + DealClosed d -> + let + w = Map.findWithDefault [] W.OnClosingDay (waterfall t) -- `debug` ("DDD0") + rc = RunContext poolFlowMap rAssump rates + logForClosed = [RunningWaterfall d W.OnClosingDay| not (null w)] -- `debug` ("DDD1")] + in + do + newSt <- case dStatus of + (PreClosing st) -> Right st + _ -> Left $ "DealClosed action is not in PreClosing status but got"++ show dStatus + (newDeal, newRc, newLog) <- foldM (performActionWrap d) (t, rc, log) w -- `debug` ("ClosingDay Action:"++show w) + run newDeal{status=newSt} (runPoolFlow newRc) (Just ads) rates calls rAssump (newLog++[DealStatusChangeTo d (PreClosing newSt) newSt "By Deal Close"]++logForClosed) -- `debug` ("new st at closing"++ show newSt) + + ChangeDealStatusTo d s -> run (t{status=s}) poolFlowMap (Just ads) rates calls rAssump log + + ResetIRSwapRate d sn -> + case rateSwap t of + Nothing -> Left $ " No rate swap found for "++ sn + Just rSwap -> + let + _rates = fromMaybe [] rates + newRateSwap_rate = Map.adjust (updateRateSwapRate _rates d) sn rSwap + in + do + newRateSwap_bal <- adjustM (updateRateSwapBal t d) sn newRateSwap_rate + let newRateSwap_acc = Map.adjust (HE.accrueIRS d) sn $ newRateSwap_bal + run (t{rateSwap = Just newRateSwap_acc}) poolFlowMap (Just ads) rates calls rAssump log + + AccrueCapRate d cn -> + case rateCap t of + Nothing -> Left $ " No rate cap found for "++ cn + Just rCap -> + let + _rates = fromMaybe [] rates + in + do + newRateCap <- adjustM (accrueRC t d _rates) cn rCap + run (t{rateCap = Just newRateCap}) poolFlowMap (Just ads) rates calls rAssump log + + InspectDS d dss -> + do + newlog <- inspectListVars t d dss + run t poolFlowMap (Just ads) rates calls rAssump $ log++newlog -- `debug` ("Add log"++show newlog) + + ResetBondRate d bn -> + let + rateList = fromMaybe [] rates + bnd = bndMap Map.! bn + in + do + newBnd <- setBondNewRate t d rateList bnd + run t{bonds = Map.fromList [(bn,newBnd)] <> bndMap} poolFlowMap (Just ads) rates calls rAssump log + + ResetAccRate d accName -> + let + newAccMap = Map.adjust + (\a@(A.Account _ _ (Just (A.InvestmentAccount idx spd dp dp1 lastDay _)) _ _) + -> let + newRate = AP.lookupRate (fromMaybe [] rates) (idx,spd) d + newAccInt = Just (A.InvestmentAccount idx spd dp dp1 lastDay newRate) + in + a { A.accInterest = newAccInt}) + accName accMap + in + run t{accounts = newAccMap} poolFlowMap (Just ads) rates calls rAssump log - TestCall d -> - let - timeBasedTests::[Pre] = snd (fromMaybe ([],[]) calls) - in - do - flags::[Bool] <- sequenceA $ [ (testPre d t pre) | pre <- timeBasedTests ] - case any id flags of - True -> - let - runContext = RunContext poolFlowMap rAssump rates - newStLogs = if null cleanUpActions then - [DealStatusChangeTo d dStatus Called] - else - [DealStatusChangeTo d dStatus Called, RunningWaterfall d W.CleanUp] - in - do - (dealAfterCleanUp, rc_, newLogWaterfall_ ) <- foldM (performActionWrap d) (t, runContext, log) cleanUpActions - endingLogs <- Rpt.patchFinancialReports dealAfterCleanUp d newLogWaterfall_ - return (prepareDeal dealAfterCleanUp, endingLogs ++ newStLogs++[EndRun (Just d) "Clean Up"]) -- `debug` ("Called ! "++ show d) - _ -> run t poolFlowMap (Just ads) rates calls rAssump log + BuildReport sd ed -> + let + cashReport = Rpt.buildCashReport t sd ed + in + do + bsReport <- Rpt.buildBalanceSheet t ed -- `debug` ("bs report"++ show ed) + let newlog = FinancialReport sd ed bsReport cashReport + run t poolFlowMap (Just ads) rates calls rAssump $ log++[newlog] -- `debug` ("new log"++ show ed++ show newlog) - _ -> Left $ "Failed to match action on Date"++ show ad + FireTrigger d cyc n -> + let + triggerFired = case mTrgMap of + Nothing -> error "trigger is empty for override" + Just tm -> Map.adjust (Map.adjust (set trgStatusLens True) n) cyc tm + triggerEffects = case mTrgMap of + Nothing -> Nothing + Just tm -> case Map.lookup cyc tm of + Nothing -> Nothing + Just cycM -> case Map.lookup n cycM of + Nothing -> Nothing + Just trg -> Just $ trgEffects trg + + runContext = RunContext poolFlowMap rAssump rates + in + do + (newT, rc@(RunContext newPool _ _), adsFromTrigger, newLogsFromTrigger) + <- case triggerEffects of + Nothing -> Right (t, runContext, ads, []) -- `debug` "Nothing found on effects" + Just efs -> runEffects (t, runContext, ads, []) d efs + let (oldStatus,newStatus) = (status t,status newT) + let stChangeLogs = [DealStatusChangeTo d oldStatus newStatus "by Manual fireTrigger" | oldStatus /= newStatus] + let newLog = WarningMsg $ "Trigger Overrided to True "++ show(d,cyc,n) + run newT {triggers = Just triggerFired} newPool (Just ads) rates calls rAssump $ log++[newLog]++stChangeLogs++newLogsFromTrigger + + MakeWhole d spd walTbl -> + let + schedulePoolFlowMap = Map.map (fromMaybe (CF.CashFlowFrame (0,epocDate,Nothing) [])) $ view dealScheduledCashflow t + in + do + factor <- liftA2 + (/) + (queryCompound t d (FutureCurrentPoolBegBalance Nothing)) + (queryCompound t d (FutureCurrentSchedulePoolBegBalance Nothing)) + let reduceCfs = Map.map (over CF.cashflowTxn (\xs -> (CF.scaleTsRow factor) <$> xs)) schedulePoolFlowMap -- need to apply with factor and trucate with date + (runDealWithSchedule,_) <- run t reduceCfs (Just ads) rates calls rAssump $ log + let bondWal = Map.map (L.calcWalBond d) (bonds runDealWithSchedule) -- `debug` ("Bond schedule flow"++ show (bonds runDealWithSchedule)) + let bondSprd = Map.map + (\x -> (spd + (fromMaybe 0 (lookupTable walTbl Up (fromRational x >))))) + bondWal + let bondPricingCurve = Map.map + (\x -> IRateCurve [ TsPoint d x,TsPoint (getDate (last ads)) x] ) + bondSprd + let bondPricingResult = Map.intersectionWithKey (\k v1 v2 -> L.priceBond d v2 v1) (bonds runDealWithSchedule) bondPricingCurve + let depositBondFlow = Map.intersectionWith + (\bnd (PriceResult pv _ _ _ _ _ _) -> + let + ostBal = L.getCurBalance bnd + prinToPay = min pv ostBal + intToPay = max 0 (pv - prinToPay) + bnd1 = L.payPrin d prinToPay bnd + in + L.payYield d intToPay bnd1) + (bonds t) + bondPricingResult + run t {bonds = depositBondFlow, status = Ended } poolFlowMap (Just []) rates calls rAssump $ log++[EndRun (Just d) "MakeWhole call"] + + IssueBond d Nothing bGroupName accName bnd mBal mRate -> + run t poolFlowMap (Just ((IssueBond d (Just (Always True)) bGroupName accName bnd mBal mRate):ads)) rates calls rAssump log + + IssueBond d (Just p) bGroupName accName bnd mBal mRate -> + do + flag <- testPre d t p + case flag of + False -> run t poolFlowMap (Just ads) rates calls rAssump (log ++ [WarningMsg ("Failed to issue to bond group"++ bGroupName++ ":" ++show p)]) + True -> let + newBndName = L.bndName bnd + in + do + newBalance <- case mBal of + Just _q -> queryCompound t d (patchDateToStats d _q) + Nothing -> Right . toRational $ L.originBalance (L.bndOriginInfo bnd) + newRate <- case mRate of + Just _q -> queryCompound t d (patchDateToStats d _q) + Nothing -> Right $ L.originRate (L.bndOriginInfo bnd) + let newBonds = case Map.lookup bGroupName bndMap of + Nothing -> bndMap + Just L.Bond {} -> bndMap + Just (L.BondGroup bndGrpMap) -> let + bndOInfo = (L.bndOriginInfo bnd) {L.originDate = d, L.originRate = newRate, L.originBalance = fromRational newBalance } + bndToInsert = bnd {L.bndOriginInfo = bndOInfo, + L.bndDueIntDate = Just d, + L.bndLastIntPay = Just d, + L.bndLastPrinPay = Just d, + L.bndRate = fromRational newRate, + L.bndBalance = fromRational newBalance} + in + Map.insert bGroupName + (L.BondGroup (Map.insert newBndName bndToInsert bndGrpMap)) + bndMap + + let issuanceProceeds = fromRational newBalance + let newAcc = Map.adjust (A.deposit issuanceProceeds d (IssuanceProceeds newBndName)) + accName + accMap + run t{bonds = newBonds, accounts = newAcc} poolFlowMap (Just ads) rates calls rAssump log + RefiBondRate d accName bName iInfo -> + let + -- settle accrued interest + -- TODO rebuild bond rate reset actions + lstDate = getDate (last ads) + in + do + nBnd <- calcDueInt t d Nothing Nothing $ bndMap Map.! bName + let isResetActionEvent (ResetBondRate _ bName) = False + let isResetActionEvent _ = True + let filteredAds = filter isResetActionEvent ads + let newRate = L.getBeginRate iInfo + let dueIntToPay = L.totalDueInt nBnd + let ((shortfall,drawAmt),newAcc) = A.tryDraw dueIntToPay d (PayInt [bName]) (accMap Map.! accName) + let newBnd = set L.bndIntLens iInfo $ L.payInt d drawAmt nBnd + let resetDates = L.buildRateResetDates newBnd d lstDate + let bResetActions = [ ResetBondRate d bName | d <- resetDates ] + let newAccMap = Map.insert accName newAcc accMap + let newBndMap = Map.insert bName (newBnd {L.bndRate = newRate, L.bndDueIntDate = Just d + ,L.bndLastIntPay = Just d}) bndMap + let newAds = sortBy sortActionOnDate $ filteredAds ++ bResetActions + run t{bonds = newBndMap, accounts = newAccMap} poolFlowMap (Just newAds) rates calls rAssump log + + RefiBond d accName bnd -> undefined + + TestCall d -> + let + timeBasedTests::[Pre] = snd (fromMaybe ([],[]) calls) + in + do + flags::[Bool] <- sequenceA $ [ (testPre d t pre) | pre <- timeBasedTests ] + case any id flags of + True -> + let + runContext = RunContext poolFlowMap rAssump rates + newStLogs = if null cleanUpActions then + [DealStatusChangeTo d dStatus Called "by Date-Based Call"] + else + [DealStatusChangeTo d dStatus Called "by Date-Based Call", RunningWaterfall d W.CleanUp] + in + do + (dealAfterCleanUp, rc_, newLogWaterfall_ ) <- foldM (performActionWrap d) (t, runContext, log) cleanUpActions + endingLogs <- Rpt.patchFinancialReports dealAfterCleanUp d newLogWaterfall_ + return (prepareDeal dealAfterCleanUp, endingLogs ++ newStLogs++[EndRun (Just d) "Clean Up"]) -- `debug` ("Called ! "++ show d) + _ -> run t poolFlowMap (Just ads) rates calls rAssump log + + _ -> Left $ "Failed to match action on Date"++ show ad where cleanUpActions = Map.findWithDefault [] W.CleanUp (waterfall t) -- `debug` ("Running AD"++show(ad)) @@ -754,25 +790,26 @@ runDeal t _ perfAssumps nonPerfAssumps@AP.NonPerfAssumption{AP.callWhen = opts ,AP.pricing = mPricing ,AP.revolving = mRevolving ,AP.interest = mInterest} - | not runFlag = Right $ (t, Nothing, Just valLogs, Nothing) --TODO should be left as warning errors to be sent back to user + -- | not runFlag = Right $ (t, Nothing, Just valLogs, Nothing) --TODO should be left as warning errors to be sent back to user + | not runFlag = Left $ intercalate ";" $ show <$> valLogs | otherwise = do - (newT, ads, pcf, unStressPcf) <- getInits t perfAssumps (Just nonPerfAssumps) - (finalDeal, logs) <- run (removePoolCf newT) - pcf - (Just ads) - mInterest - (readCallOptions <$> opts) - mRevolvingCtx - [] - let poolFlowUsed = Map.map (fromMaybe (CF.CashFlowFrame (0,toDate "19000101",Nothing) [])) (getAllCollectedFrame finalDeal Nothing) - let poolFlowUsedNoEmpty = Map.map (over CF.cashflowTxn CF.dropTailEmptyTxns) poolFlowUsed - -- bond pricing if any - let bndPricing = case mPricing of - Nothing -> Nothing - Just _bpi -> Just (priceBonds finalDeal _bpi) - - return (finalDeal, Just poolFlowUsedNoEmpty, Just (getRunResult finalDeal ++ V.validateRun finalDeal ++logs), bndPricing) -- `debug` ("Run Deal end with") + (newT, ads, pcf, unStressPcf) <- getInits t perfAssumps (Just nonPerfAssumps) + (finalDeal, logs) <- run (removePoolCf newT) + pcf + (Just ads) + mInterest + (readCallOptions <$> opts) + mRevolvingCtx + [] + let poolFlowUsed = Map.map (fromMaybe (CF.CashFlowFrame (0,toDate "19000101",Nothing) [])) (getAllCollectedFrame finalDeal Nothing) + let poolFlowUsedNoEmpty = Map.map (over CF.cashflowTxn CF.dropTailEmptyTxns) poolFlowUsed + -- bond pricing if any + let bndPricing = case mPricing of + Nothing -> Nothing + Just _bpi -> Just (priceBonds finalDeal _bpi) + + return (finalDeal, Just poolFlowUsedNoEmpty, Just (getRunResult finalDeal ++ V.validateRun finalDeal ++logs), bndPricing) -- `debug` ("Run Deal end with") where (runFlag, valLogs) = V.validateReq t nonPerfAssumps -- getinits() will get (new deal snapshot, actions, pool cashflows, unstressed pool cashflow) @@ -811,18 +848,6 @@ appendCollectedCF :: Ast.Asset a => Date -> TestDeal a -> Map.Map PoolId CF.Cash appendCollectedCF d t@TestDeal { pool = pt } poolInflowMap = let newPt = case pt of - SoloPool p -> - let - txnCollected::[CF.TsRow] = view CF.cashflowTxn (poolInflowMap Map.! PoolConsol) - balInCollected = case length txnCollected of - 0 -> 0 - _ -> CF.mflowBalance $ last txnCollected - currentStats = case view P.poolFutureTxn p of - [] -> P.poolBegStats p - txns -> fromMaybe (0,0,0,0,0,0) $ view CF.txnCumulativeStats (last txns) - txnToAppend = CF.patchCumulative currentStats [] txnCollected -- `debug` ("Start iwht current stats="++ show currentStats) - in - SoloPool $ over P.poolIssuanceStat (Map.insert RuntimeCurrentPoolBalance balInCollected) $ over P.poolFutureTxn (++ txnToAppend) p MultiPool poolM -> MultiPool $ Map.foldrWithKey @@ -835,11 +860,11 @@ appendCollectedCF d t@TestDeal { pool = pt } poolInflowMap 0 -> 0 _ -> CF.mflowBalance $ last txnCollected txnToAppend = CF.patchCumulative currentStats [] txnCollected - accUpdated = Map.adjust (over P.poolFutureTxn (++ txnToAppend)) k acc + accUpdated = Map.adjust (over P.poolFutureTxn (++ txnToAppend)) k acc in Map.adjust (over P.poolIssuanceStat (Map.insert RuntimeCurrentPoolBalance balInCollected)) - k accUpdated) + k accUpdated) poolM poolInflowMap ResecDeal uds -> @@ -856,21 +881,12 @@ removePoolCf :: Ast.Asset a => TestDeal a -> TestDeal a removePoolCf t@TestDeal{pool=pt} = let newPt = case pt of - SoloPool p -> SoloPool $ set P.poolFutureCf Nothing p MultiPool pM -> MultiPool $ Map.map (set P.poolFutureCf Nothing) pM ResecDeal uds -> ResecDeal uds _ -> error "not implement" in - t {pool=newPt} + t {pool = newPt} --- ^ TODO: need to set cashflow to different pool other than SoloPool -setFutureCF :: Ast.Asset a => TestDeal a -> CF.CashFlowFrame -> TestDeal a -setFutureCF t@TestDeal{pool = (SoloPool p )} cf - = let - newPool = p {P.futureCf = Just cf} - newPoolType = SoloPool newPool - in - t {pool = newPoolType } populateDealDates :: DateDesp -> DealStatus -> (Date,Date,Date,[ActionOnDate],[ActionOnDate],Date) populateDealDates (WarehousingDates begDate rampingPoolDp rampingBondDp statedDate) @@ -926,12 +942,9 @@ runPool (P.Pool [] (Just (CF.CashFlowFrame _ txn)) _ asof _ (Just dp)) (Just (AP -- use interest rate assumption runPool (P.Pool as _ _ asof _ _) Nothing mRates -- = Right $ map (\x -> (Ast.calcCashflow x asof mRates,Map.empty)) as - = let - cfs::(Either String [CF.CashFlowFrame]) = sequenceA $ map (\x -> Ast.calcCashflow x asof mRates) as - in - do - cf <- cfs - return [ (x, Map.empty) | x <- cf ] + = do + cf <- sequenceA $ map (\x -> Ast.calcCashflow x asof mRates) as + return [ (x, Map.empty) | x <- cf ] -- asset cashflow with credit stress ---- By pool level @@ -1033,7 +1046,6 @@ patchIssuanceBalance :: Ast.Asset a => DealStatus -> Map.Map PoolId Balance -> P patchIssuanceBalance (Warehousing _) balM pt = patchIssuanceBalance (PreClosing Amortizing) balM pt patchIssuanceBalance (PreClosing _ ) balM pt = case pt of - SoloPool p -> SoloPool $ over P.poolIssuanceStat (Map.insert IssuanceBalance (Map.findWithDefault 0.0 PoolConsol balM)) p -- `debug` ("Insert with issuance balance"++ show (Map.findWithDefault 0.0 PoolConsol balM)) MultiPool pM -> MultiPool $ Map.mapWithKey (\k v -> over P.poolIssuanceStat (Map.insert IssuanceBalance (Map.findWithDefault 0.0 k balM)) v) pM ResecDeal pM -> ResecDeal pM --TODO patch balance for resec deal @@ -1042,17 +1054,10 @@ patchIssuanceBalance _ bal p = p -- `debug` ("NO patching ?") patchScheduleFlow :: Ast.Asset a => Map.Map PoolId CF.CashFlowFrame -> PoolType a -> PoolType a patchScheduleFlow flowM pt = case pt of - SoloPool p -> case Map.lookup PoolConsol flowM of - Nothing -> error $ "Failed to find schedule flow of pool id of Pool Console in "++ show (Map.keys flowM) - Just scheduleCf -> SoloPool $ set P.poolFutureScheduleCf (Just scheduleCf) p MultiPool pM -> MultiPool $ Map.intersectionWith (set P.poolFutureScheduleCf) (Just <$> flowM) pM ResecDeal pM -> ResecDeal pM patchRuntimeBal :: Ast.Asset a => Map.Map PoolId Balance -> PoolType a -> PoolType a -patchRuntimeBal balMap (SoloPool p) = case Map.lookup PoolConsol balMap of - Nothing -> error "Failed to find beg bal for pool" - Just b -> SoloPool $ over P.poolIssuanceStat (\m -> Map.insert RuntimeCurrentPoolBalance b m) p - patchRuntimeBal balMap (MultiPool pM) = MultiPool $ Map.mapWithKey @@ -1065,10 +1070,6 @@ patchRuntimeBal balMap pt = pt runPoolType :: Ast.Asset a => PoolType a -> Maybe AP.ApplyAssumptionType -> Maybe AP.NonPerfAssumption -> Either String (Map.Map PoolId (CF.CashFlowFrame, Map.Map CutoffFields Balance)) -runPoolType (SoloPool p) mAssumps mNonPerfAssump - = sequenceA $ - Map.fromList [(PoolConsol - ,(P.aggPool (P.issuanceStat p)) <$> (runPool p mAssumps (AP.interest =<< mNonPerfAssump)))] runPoolType (MultiPool pm) (Just (AP.ByName assumpMap)) mNonPerfAssump = sequenceA $ Map.mapWithKey @@ -1317,9 +1318,10 @@ extractTxnsFromFlowFrameMap mPids pflowMap = Nothing -> extractTxns pflowMap Just pids -> extractTxns $ Map.filterWithKey (\k _ -> k `elem` pids) pflowMap where - extractTxns m = concat $ CF.getTsCashFlowFrame <$> Map.elems m - + extractTxns m = concat $ (view CF.cashflowTxn) <$> Map.elems m + -- extractTxns m = concatMap $ (view CF.cashflowTxn) $ Map.elems m +-- ^ deposit cash to account by collection rule depositInflow :: Date -> W.CollectionRule -> Map.Map PoolId CF.CashFlowFrame -> Map.Map AccountName A.Account -> Map.Map AccountName A.Account depositInflow d (W.Collect mPids s an) pFlowMap amap = Map.adjust (A.deposit amt d (PoolInflow mPids s)) an amap -- `debug` ("Date"++show d++"Deposit"++show amt++"Rule"++show s ++">>AN"++ show an) @@ -1341,7 +1343,7 @@ depositInflow d (W.CollectByPct mPids s splitRules) pFlowMap amap --TODO need depositInflow _ a _ _ = error $ "Failed to match collection rule"++ show a --- ^ deposit cash to account by pool map CF +-- ^ deposit cash to account by pool map CF and rules depositPoolFlow :: [W.CollectionRule] -> Date -> Map.Map PoolId CF.CashFlowFrame -> Map.Map String A.Account -> Map.Map String A.Account depositPoolFlow rules d pFlowMap amap = foldr (\rule acc -> depositInflow d rule pFlowMap acc) amap rules diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index 0a5eaa08..33de862f 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -297,50 +297,56 @@ calcDueInt t calc_date mBal mRate b@(L.Bond bn bt bo bi _ bond_bal bond_rate _ i let newDueInt = IR.calcInt overrideBal int_due_date calc_date overrideRate dc -- `debug` ("Using Rate"++show calc_date ++">>Bal"++ show overrideBal) return b {L.bndDueInt = newDueInt+intDue, L.bndDueIntDate = Just calc_date } -- `debug` ("Due INT"++show calc_date ++">>"++show(bn)++">>"++show int_due++">>"++show(new_due_int)) -calcDuePrin :: Ast.Asset a => TestDeal a -> T.Day -> L.Bond -> L.Bond -calcDuePrin t calc_date b@(L.BondGroup bMap) = L.BondGroup $ Map.map (calcDuePrin t calc_date) bMap +calcDuePrin :: Ast.Asset a => TestDeal a -> Date -> L.Bond -> Either String L.Bond +calcDuePrin t d b@(L.BondGroup bMap) + = do + m <- sequenceA $ Map.map (calcDuePrin t d) bMap + return $ L.BondGroup m -calcDuePrin t calc_date b@(L.Bond _ L.Sequential _ _ _ bondBal _ _ _ _ _ _ _ _) - = b {L.bndDuePrin = bondBal } +calcDuePrin t d b@(L.Bond _ L.Sequential _ _ _ bondBal _ _ _ _ _ _ _ _) + = Right $ b {L.bndDuePrin = bondBal } -calcDuePrin t calc_date b@(L.Bond bn (L.Lockout cd) bo bi _ bondBal _ _ _ _ _ _ _ _) - | cd > calc_date = b {L.bndDuePrin = 0} - | otherwise = b {L.bndDuePrin = bondBal } +calcDuePrin t d b@(L.Bond bn (L.Lockout cd) bo bi _ bondBal _ _ _ _ _ _ _ _) + | cd > d = Right $ b {L.bndDuePrin = 0} + | otherwise = Right $ b {L.bndDuePrin = bondBal } -calcDuePrin t calc_date b@(L.Bond bn (L.PAC schedule) _ _ _ bondBal _ _ _ _ _ _ _ _) = - b {L.bndDuePrin = duePrin} -- `debug` ("bn >> "++bn++"Due Prin set=>"++show(duePrin) ) +calcDuePrin t d b@(L.Bond bn (L.PAC schedule) _ _ _ bondBal _ _ _ _ _ _ _ _) + = Right $ b {L.bndDuePrin = duePrin} -- `debug` ("bn >> "++bn++"Due Prin set=>"++show(duePrin) ) where - scheduleDue = getValOnByDate schedule calc_date + scheduleDue = getValOnByDate schedule d duePrin = max (bondBal - scheduleDue) 0 -- `debug` ("In PAC ,target balance"++show(schedule)++show(calc_date)++show(scheduleDue)) -calcDuePrin t calc_date b@(L.Bond bn (L.PacAnchor schedule bns) _ _ _ bondBal _ _ _ _ _ _ _ _) = - b {L.bndDuePrin = duePrin} -- `debug` ("bn >> "++bn++"Due Prin set=>"++show(duePrin) ) - where - scheduleDue = getValOnByDate schedule calc_date - anchor_bond_balance = queryDeal t (CurrentBondBalanceOf bns) - duePrin = if anchor_bond_balance > 0 then - max (bondBal - scheduleDue) 0 - else - bondBal - -calcDuePrin t calc_date b@(L.Bond bn L.Z bo bi _ bond_bal bond_rate prin_arr int_arrears _ _ lstIntPay _ _) = - if all isZbond activeBnds then - b {L.bndDuePrin = bond_bal} -- `debug` ("bn >> "++bn++"Due Prin set=>"++show(duePrin) ) - else - b {L.bndDuePrin = 0, L.bndBalance = new_bal, L.bndLastIntPay=Just calc_date} -- `debug` ("bn >> "++bn++"Due Prin set=>"++show(duePrin) ) - where - isZbond (L.Bond _ L.Z _ _ _ _ _ _ _ _ _ _ _ _) = True - isZbond L.Bond {} = False - - activeBnds = filter (\x -> L.bndBalance x > 0) (Map.elems (bonds t)) - new_bal = bond_bal + dueInt - lastIntPayDay = case lstIntPay of - Just pd -> pd - Nothing -> getClosingDate (dates t) - dueInt = IR.calcInt bond_bal lastIntPayDay calc_date bond_rate DC_ACT_365F +calcDuePrin t d b@(L.Bond bn (L.PacAnchor schedule bns) _ _ _ bondBal _ _ _ _ _ _ _ _) + = let + scheduleDue = getValOnByDate schedule d + in + do + anchor_bond_balance <- queryCompound t d (CurrentBondBalanceOf bns) + let duePrin = if anchor_bond_balance > 0 then + max (bondBal - scheduleDue) 0 + else + bondBal + return $ b {L.bndDuePrin = duePrin} -- `debug` ("bn >> "++bn++"Due Prin set=>"++show(duePrin) ) + +calcDuePrin t calc_date b@(L.Bond bn L.Z bo bi _ bond_bal bond_rate prin_arr int_arrears _ _ lstIntPay _ _) + = Right $ + if all isZbond activeBnds then + b {L.bndDuePrin = bond_bal} -- `debug` ("bn >> "++bn++"Due Prin set=>"++show(duePrin) ) + else + b {L.bndDuePrin = 0, L.bndBalance = new_bal, L.bndLastIntPay=Just calc_date} -- `debug` ("bn >> "++bn++"Due Prin set=>"++show(duePrin) ) + where + isZbond (L.Bond _ L.Z _ _ _ _ _ _ _ _ _ _ _ _) = True + isZbond L.Bond {} = False + + activeBnds = filter (\x -> L.bndBalance x > 0) (Map.elems (bonds t)) + new_bal = bond_bal + dueInt + lastIntPayDay = case lstIntPay of + Just pd -> pd + Nothing -> getClosingDate (dates t) + dueInt = IR.calcInt bond_bal lastIntPayDay calc_date bond_rate DC_ACT_365F calcDuePrin t calc_date b@(L.Bond bn L.Equity bo bi _ bondBal _ _ _ _ _ _ _ _) - = b {L.bndDuePrin = bondBal } + = Right $ b {L.bndDuePrin = bondBal } priceAssetUnion :: ACM.AssetUnion -> Date -> PricingMethod -> AP.AssetPerf -> Maybe [RateAssumption] @@ -504,13 +510,19 @@ calcAvailFund :: Ast.Asset a => TestDeal a -> Date -> A.Account -> Maybe W.Extra calcAvailFund t d acc Nothing = Right $ A.accBalance acc calcAvailFund t d acc (Just support) = ((A.accBalance acc) +) <$> evalExtraSupportBalance d t support -applyLimit :: Ast.Asset a => TestDeal a -> Date -> Balance -> Balance -> (Maybe Limit) -> Balance -applyLimit t d availBal dueBal Nothing = availBal +-- ^ Deal, Date , cap balance, due balance +applyLimit :: Ast.Asset a => TestDeal a -> Date -> Balance -> Balance -> Maybe Limit -> Either String Balance +applyLimit t d availBal dueBal Nothing = Right $ min availBal dueBal applyLimit t d availBal dueBal (Just limit) = - case limit of - DueCapAmt amt -> min amt availBal - DS ds -> min (queryDeal t (patchDateToStats d ds)) availBal - DuePct pct -> min availBal $ mulBR dueBal pct + (min dueBal) <$> + case limit of + DueCapAmt amt -> Right $ min amt availBal + DS ds -> do + v <- queryCompound t d (patchDateToStats d ds) + return (min (fromRational v) availBal) + DuePct pct -> Right $ min availBal $ mulBR dueBal pct + + x -> Left $ "Date:"++show d ++" Unsupported limit found:"++ show x calcAvailAfterLimit :: Ast.Asset a => TestDeal a -> Date -> A.Account -> Maybe W.ExtraSupport -> Balance -> (Maybe Limit) -> Either String Balance @@ -520,13 +532,18 @@ calcAvailAfterLimit t d acc mSupport dueAmt mLimit Nothing -> Right $ A.accBalance acc Just support -> ((A.accBalance acc) +) <$> evalExtraSupportBalance d t support in - (min dueAmt) <$> - case mLimit of - Nothing -> availFund - Just (DueCapAmt amt) -> min amt <$> availFund - Just (DS ds) -> liftA2 min (fromRational <$> (queryCompound t d (patchDateToStats d ds))) availFund - Just (DuePct pct) -> min (mulBR dueAmt pct) <$> availFund - _ -> Left ("Failed to find type"++ show mLimit) + do + r <- (min dueAmt) <$> + case mLimit of + Nothing -> availFund + Just (DueCapAmt amt) -> min amt <$> availFund + Just (DS ds) -> liftA2 min (fromRational <$> (queryCompound t d (patchDateToStats d ds))) availFund + Just (DuePct pct) -> min (mulBR dueAmt pct) <$> availFund + _ -> Left ("Failed to find type"++ show mLimit) + if r < 0 then + (Left ("Negative value when calculates Limit:"++ show mLimit)) + else + return r updateSupport :: Ast.Asset a => Date -> Maybe W.ExtraSupport -> Balance -> TestDeal a -> TestDeal a @@ -545,7 +562,7 @@ performActionWrap d ,revolvingAssump=Just rMap ,revolvingInterestRateAssump = mRates} ,logs) - (W.BuyAssetFrom ml pricingMethod accName mRevolvingPoolName pId) + (W.BuyAssetFrom ml pricingMethod accName mRevolvingPoolName pId) = let revolvingPoolName = fromMaybe "Consol" mRevolvingPoolName @@ -556,7 +573,6 @@ performActionWrap d accBal = A.accBalance $ accsMap Map.! accName pIdToChange = fromMaybe PoolConsol pId --`debug` ("purchase date"++ show d++ "\n" ++ show assetBought) - in do limitAmt <- case ml of @@ -570,12 +586,11 @@ performActionWrap d (StaticAsset _) -> min availBal valuationOnAvailableAssets -- `debug` ("Valuation on rpool"++show valuationOnAvailableAssets) ConstantAsset _ -> availBal AssetCurve _ -> min availBal valuationOnAvailableAssets - let purchaseRatio = divideBB purchaseAmt valuationOnAvailableAssets -- `debug` ("Date"++ show d ++ " Purchase Amt"++show purchaseAmt++">> avail balance"++ show availBal ) - let (assetBought,poolAfterBought) = buyRevolvingPool d (toRational purchaseRatio) assetForSale -- `debug` ("date "++ show d ++ "purchase ratio"++ show purchaseRatio) - let boughtAssetBal = sum $ curBal <$> assetBought -- `debug` ("Asset bought 0 \n"++ show assetBought++ "pflow map\n"++ show pFlowMap++" p id to change\n"++ show pIdToChange) + let purchaseRatio = divideBB purchaseAmt valuationOnAvailableAssets -- `debug` ("In Buy >>> Date"++ show d ++ " Purchase Amt"++show purchaseAmt++">> avail value on availAsset"++ show valuationOnAvailableAssets ) + let (assetBought,poolAfterBought) = buyRevolvingPool d (toRational purchaseRatio) assetForSale -- `debug` ("In Buy >>> date "++ show d ++ "purchase ratio"++ show purchaseRatio) + let boughtAssetBal = sum $ curBal <$> assetBought -- `debug` ("In Buy >>> Asset bought 0 \n"++ show assetBought++ "pflow map\n"++ show pFlowMap++" p id to change\n"++ show pIdToChange) -- update runtime balance let newPt = case pt of - SoloPool p -> SoloPool $ over P.poolIssuanceStat (Map.adjust (+ boughtAssetBal) RuntimeCurrentPoolBalance) p MultiPool pm -> MultiPool $ Map.adjust (over P.poolIssuanceStat (Map.adjust (+ boughtAssetBal) RuntimeCurrentPoolBalance)) pIdToChange @@ -584,11 +599,11 @@ performActionWrap d let newAccMap = Map.adjust (A.draw purchaseAmt d (PurchaseAsset revolvingPoolName boughtAssetBal)) accName accsMap -- `debug` ("Asset bought total bal"++ show boughtAssetBal) cfFrameBought <- projAssetUnionList [updateOriginDate2 d ast | ast <- assetBought ] d perfAssumps mRates -- `debug` ("Date: " ++ show d ++ "Asset bought"++ show [updateOriginDate2 d ast | ast <- assetBought ]) - let cfBought = fst cfFrameBought + let cfBought = fst cfFrameBought -- `debug` ("In Buy>>>"++ show d ++"Cf bought"++ show (fst cfFrameBought)) let newPcf = Map.adjust (\cfOrigin@(CF.CashFlowFrame st trs) -> let dsInterval = getDate <$> trs -- `debug` ("Date"++ show d ++ "origin cf \n"++ show cfOrigin) - boughtCfDates = getDate <$> view CF.cashflowTxn cfBought -- `debug` ("Date"++ show d++ "Cf bought 0\n"++ show cfBought) + boughtCfDates = getDate <$> view CF.cashflowTxn cfBought -- `debug` ("In Buy>>>"++"Date"++ show d++ "Cf bought 0\n"++ show cfBought) newAggDates = case (dsInterval,boughtCfDates) of ([],[]) -> [] @@ -606,13 +621,13 @@ performActionWrap d mergedCf = CF.mergePoolCf2 cfOrigin cfBought -- `debug` ("Buy Date : "++show d ++ "CF bought \n"++ show (over CF.cashflowTxn (slice 0 30) cfBought) ) in - over CF.cashflowTxn (`CF.aggTsByDates` (dsInterval ++ newAggDates)) mergedCf ) -- `debug` ("Date "++show d++" Merged CF\n"++ show mergedCf)) + over CF.cashflowTxn (`CF.aggTsByDates` (dsInterval ++ newAggDates)) mergedCf )-- `debug` ("In Buy>>>"++"Date "++show d++" Merged CF\n"++ show mergedCf)) pIdToChange pFlowMap -- `debug` ("pid To change"++ show pIdToChange++ "P flow map"++ show pFlowMap) - let newRc = rc {runPoolFlow = newPcf -- `debug` (show d ++ "New run pool >> \n"++ show newPcf) + let newRc = rc {runPoolFlow = newPcf -- `debug` ("In Buy>>>"++show d ++ "New run pool >> \n"++ show newPcf) ,revolvingAssump = Just (Map.insert revolvingPoolName (poolAfterBought, perfAssumps) rMap)} - return (t { accounts = newAccMap , pool = newPt}, newRc, logs ) + return (t { accounts = newAccMap , pool = newPt}, newRc, logs) performActionWrap d (t @@ -621,7 +636,7 @@ performActionWrap d ,revolvingInterestRateAssump=mRates} ,logs) (W.BuyAsset ml pricingMethod accName _) - = Left $ "Missing revolving Assumption(asset assumption & asset to buy)" ++ name t + = Left $ "Date:"++ show d ++"Missing revolving Assumption(asset assumption & asset to buy)" ++ name t -- TODO need to set a limit to sell performActionWrap d @@ -637,14 +652,11 @@ performActionWrap d poolMapToLiq = case (pt, mPid) of (MultiPool pm, Nothing) -> pm - (SoloPool p, Nothing) -> Map.fromList [(PoolConsol,p)] (MultiPool pm,Just pids) -> let selectedPids = S.fromList pids selectedPoolMap = Map.filterWithKey (\k v -> S.member k selectedPids) pm in selectedPoolMap - (SoloPool p,Just [PoolConsol]) -> Map.fromList [(PoolConsol,p)] - (SoloPool p,Just _ ) -> error $ "Not able to sell "++ show mPid ++ " in solo pool" (ResecDeal _,_) -> error "Not implement on liquidate resec deal" @@ -656,22 +668,20 @@ performActionWrap d -- Update collected cashflow newPt = case (pt, mPid) of (MultiPool pm, Nothing) -> MultiPool $ Map.map liqFunction pm - (SoloPool p, Nothing) -> SoloPool $ liqFunction p - (MultiPool pm,Just pids) -> let + (MultiPool pm, Just pids) -> let selectedPids = S.fromList pids selectedPoolMap = Map.filterWithKey (\k v -> S.member k selectedPids) pm in MultiPool $ Map.union (Map.map liqFunction selectedPoolMap) pm - (SoloPool p,Just [PoolConsol]) -> SoloPool $ liqFunction p - (SoloPool p,Just _ ) -> error $ "Not able to sell "++ show mPid ++ " in solo pool" (ResecDeal _,_) -> error "Not implement on liquidate resec deal" liqComment = LiquidationProceeds (fromMaybe [] mPid) accMapAfterLiq = Map.adjust (A.deposit liqAmt d liqComment) an accMap -- REMOVE future cf newPfInRc = foldr (Map.adjust (set CF.cashflowTxn [])) pcf (Map.keys poolMapToLiq) - in - Right (t {accounts = accMapAfterLiq , pool = newPt} , rc {runPoolFlow = newPfInRc}, logs ) + -- Update current balance to zero + in + Right (t {accounts = accMapAfterLiq , pool = newPt} , rc {runPoolFlow = newPfInRc}, logs) performActionWrap d (t, rc, logs) (W.WatchVal ms dss) @@ -685,7 +695,7 @@ performActionWrap d (t, rc, logs) (W.ActionWithPre p actions) foldM (performActionWrap d) (t,rc,logs) actions else return (t, rc, logs) - + performActionWrap d (t, rc, logs) (W.ActionWithPre2 p actionsTrue actionsFalse) = do @@ -695,6 +705,18 @@ performActionWrap d (t, rc, logs) (W.ActionWithPre2 p actionsTrue actionsFalse) else foldM (performActionWrap d) (t,rc,logs) actionsFalse + +performActionWrap d (t, rc, logs) (W.ChangeStatus mPre newSt) + = case mPre of + Nothing -> return (t {status=newSt} , rc, logs) + Just p -> + do + flag <- testPre d t p + if flag then + return (t {status=newSt} , rc, logs) + else + return (t, rc, logs) + -- ^ go down to performAction performActionWrap d (t, rc, logs) a = do @@ -702,35 +724,31 @@ performActionWrap d (t, rc, logs) a return (dealAfterExe, rc, logs) performAction :: Ast.Asset a => Date -> TestDeal a -> W.Action -> Either String (TestDeal a) -performAction d t@TestDeal{accounts=accMap, ledgers = Just ledgerM} (W.Transfer (Just (ClearLedger dr ln)) an1 an2 mComment) = - Right $ t {accounts = accMapAfterDeposit, ledgers = Just newLedgerM} - where - sourceAcc = accMap Map.! an1 - targetAcc = accMap Map.! an2 - targetAmt = LD.queryGap dr (ledgerM Map.! ln) - transferAmt = min (A.accBalance sourceAcc) targetAmt - - accMapAfterDraw = Map.adjust (A.draw transferAmt d (TransferBy an1 an2 (ClearLedger dr ln))) an1 accMap -- `debug` (">>PDL >>Ledger bal"++show d ++ show targetAmt) - accMapAfterDeposit = Map.adjust (A.deposit transferAmt d (TransferBy an1 an2 (ClearLedger dr ln))) an2 accMapAfterDraw - - newLedgerM = Map.adjust (LD.entryLog transferAmt d (TxnDirection dr)) ln ledgerM - -performAction d t@TestDeal{accounts=accMap} (W.Transfer mLimit an1 an2 mComment) = - do - txnAmt <- transferAmt - let accMapAfterDraw = (Map.adjust (A.draw txnAmt d txnCom) an1) accMap - let accMapAfterDeposit = (Map.adjust (A.deposit txnAmt d txnCom) an2) accMapAfterDraw - return (t {accounts = accMapAfterDeposit}) - where - sourceAcc = accMap Map.! an1 - targetAcc = accMap Map.! an2 - txnCom = case mLimit of - Nothing -> Transfer an1 an2 - Just m -> TransferBy an1 an2 m - transferAmt = calcAvailAfterLimit t d sourceAcc Nothing (A.accBalance sourceAcc) mLimit - +performAction d t@TestDeal{accounts=accMap, ledgers = Just ledgerM} + (W.TransferAndBook mLimit an1 an2 (dr, lName) mComment) + = let + sourceAcc = accMap Map.! an1 + targetAcc = accMap Map.! an2 + actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an1) Nothing (A.accBalance sourceAcc) mLimit + in + do + transferAmt <- actualPaidOut + let accMapAfterDraw = Map.adjust (A.draw transferAmt d (TxnComments [Transfer an1 an2,(BookLedgerBy dr lName)])) an1 accMap -- `debug` (">>PDL >>Ledger bal"++show d ++ show targetAmt) + let accMapAfterDeposit = Map.adjust (A.deposit transferAmt d (TxnComments [Transfer an1 an2,(BookLedgerBy dr lName)])) an2 accMapAfterDraw + let newLedgerM = Map.adjust (LD.entryLog transferAmt d (TxnDirection dr)) lName ledgerM + return t {accounts = accMapAfterDeposit, ledgers = Just newLedgerM} --- foldM :: (Foldable t, Monad m) => (b -> a -> m b) -> b -> t a -> m b +performAction d t@TestDeal{accounts=accMap} (W.Transfer mLimit an1 an2 mComment) + = let + sourceAcc = accMap Map.! an1 + targetAcc = accMap Map.! an2 + actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an1) Nothing (A.accBalance sourceAcc) mLimit + in + do + transferAmt <- actualPaidOut + let accMapAfterDraw = Map.adjust (A.draw transferAmt d (Transfer an1 an2)) an1 accMap -- `debug` (">>PDL >>Ledger bal"++show d ++ show targetAmt) + let accMapAfterDeposit = Map.adjust (A.deposit transferAmt d (Transfer an1 an2)) an2 accMapAfterDraw + return t {accounts = accMapAfterDeposit} performAction d t@TestDeal{accounts=accMap} (W.TransferMultiple sourceAccList targetAcc mComment) = foldM (\acc (mLimit, sourceAccName) -> @@ -742,27 +760,26 @@ performAction d t@TestDeal{accounts=accMap} (W.TransferMultiple sourceAccList ta 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.entryLog (fromRational amtToBook) d (TxnDirection dr)) ledger ledgerM - return $ t {ledgers = Just newLedgerM} - -performAction d t@TestDeal{ledgers= Just ledgerM} (W.BookBy (W.PDL ds ledgersList)) = - Right $ t {ledgers = Just newLedgerM} - where - bookedLedger = [(queryDeal t ledgerCap - ,queryTxnAmt (ledgerM Map.! ledgerName) (TxnDirection Debit)) - | (ledgerName, ledgerCap) <- ledgersList ] + 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 +-- ^ ds -> value to book +-- ^ ledgersList -> list of ledgers to book +performAction d t@TestDeal{ledgers= Just ledgerM} (W.BookBy (W.PDL dr ds ledgersList)) = + let + ledgerCaps = sequenceA [ queryCompound t d ledgerCap | ledgerCap <- snd <$> ledgersList ] ledgerNames = fst <$> ledgersList - - amtToBook = queryDeal t ds - amtBooked = sum $ snd <$> bookedLedger - newAmtToBook = amtToBook - amtBooked - availableBalances = [ a-b | (a,b) <- bookedLedger] - amtBookedToLedgers = paySeqLiabilitiesAmt newAmtToBook availableBalances - - newLedgerM = foldr - (\(ln,amt) acc -> Map.adjust (LD.entryLog amt d (TxnDirection Debit)) ln acc) - ledgerM - (zip ledgerNames amtBookedToLedgers) + in + do + amtToBook <- queryCompound t d ds + ledgCaps <- ledgerCaps + let amtBookedToLedgers = paySeqLiabilitiesAmt (fromRational amtToBook) (fromRational <$> ledgCaps) --`debug` ("amt to book"++ show amtToBook) + let newLedgerM = foldr + (\(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} -- ^ pay fee sequentially performAction d t@TestDeal{fees=feeMap, accounts=accMap} (W.PayFeeBySeq mLimit an fns mSupport) = @@ -775,7 +792,7 @@ performAction d t@TestDeal{fees=feeMap, accounts=accMap} (W.PayFeeBySeq mLimit a do paidOutAmt <- actualPaidOut let (feesPaid, remainAmt) = paySequentially d paidOutAmt F.feeDue (F.payFee d) [] feesToPay - let accPaidOut = (min availAccBal paidOutAmt) + let accPaidOut = min availAccBal paidOutAmt let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (SeqPayFee fns)) an accMap ,fees = Map.fromList (zip fns feesPaid) <> feeMap} @@ -794,7 +811,7 @@ performAction d t@TestDeal{fees=feeMap, accounts=accMap} (W.PayFee mLimit an fns do paidOutAmt <- actualPaidOut let (feesPaid, remainAmt) = payProRata d paidOutAmt F.feeDue (F.payFee d) feesToPay - let accPaidOut = (min availAccBal paidOutAmt) + let accPaidOut = min availAccBal paidOutAmt let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (SeqPayFee fns)) an accMap ,fees = Map.fromList (zip fns feesPaid) <> feeMap} @@ -820,7 +837,7 @@ performAction d t@TestDeal{bonds=bndMap, accounts=accMap, liqProvider=liqMap} do paidOutAmt <- actualPaidOut let (bondsPaid, remainAmt) = paySequentially d paidOutAmt L.bndDueIntOverInt (L.payInt d) [] bndsList - let accPaidOut = (min availAccBal paidOutAmt) + let accPaidOut = min availAccBal paidOutAmt let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayInt bnds)) an accMap ,bonds = Map.fromList (zip bnds bondsPaid) <> bndMap} @@ -829,7 +846,8 @@ performAction d t@TestDeal{bonds=bndMap, accounts=accMap, liqProvider=liqMap} return $ updateSupport d mSupport supportPaidOut dealAfterAcc -performAction d t@TestDeal{bonds=bndMap, accounts=accMap, liqProvider=liqMap} (W.PayIntBySeq mLimit an bnds mSupport) +performAction d t@TestDeal{bonds=bndMap, accounts=accMap, liqProvider=liqMap} + (W.PayIntBySeq mLimit an bnds mSupport) = let availAccBal = A.accBalance (accMap Map.! an) bndsList = (Map.!) bndMap <$> bnds @@ -840,7 +858,7 @@ performAction d t@TestDeal{bonds=bndMap, accounts=accMap, liqProvider=liqMap} (W do paidOutAmt <- actualPaidOut let (bondsPaid, remainAmt) = paySequentially d paidOutAmt L.bndDueInt (L.payInt d) [] bndsList - let accPaidOut = (min availAccBal paidOutAmt) + let accPaidOut = min availAccBal paidOutAmt let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayInt bnds)) an accMap ,bonds = Map.fromList (zip bnds bondsPaid) <> bndMap} @@ -860,7 +878,7 @@ performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayIntOverInt mLimit do paidOutAmt <- actualPaidOut let (bondsPaid, remainAmt) = payProRata d paidOutAmt L.bndDueIntOverInt (L.payInt d) bndsList - let accPaidOut = (min availAccBal paidOutAmt) + let accPaidOut = min availAccBal paidOutAmt let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayInt bnds)) an accMap ,bonds = Map.fromList (zip bnds bondsPaid) <> bndMap} @@ -902,18 +920,19 @@ performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayIntResidual mLimi availBal = A.accBalance $ accMap Map.! an in do - let limitAmt = applyLimit t d availBal availBal mLimit + limitAmt <- applyLimit t d availBal availBal mLimit return $ t {accounts = Map.adjust (A.draw limitAmt d (PayYield bndName)) an accMap , bonds = Map.adjust (L.payYield d limitAmt) bndName bndMap} performAction d t@TestDeal{fees=feeMap,accounts=accMap} (W.PayFeeResidual mlimit an feeName) = - Right $ t {accounts = accMapAfterPay, fees = feeMapAfterPay} - where + let availBal = A.accBalance $ accMap Map.! an - paidOutAmt = applyLimit t d availBal availBal mlimit - accMapAfterPay = Map.adjust (A.draw paidOutAmt d (PayFeeYield feeName)) an accMap - feeMapAfterPay = Map.adjust (F.payResidualFee d paidOutAmt) feeName feeMap - + in + do + paidOutAmt <- applyLimit t d availBal availBal mlimit + let accMapAfterPay = Map.adjust (A.draw paidOutAmt d (PayFeeYield feeName)) an accMap + let feeMapAfterPay = Map.adjust (F.payResidualFee d paidOutAmt) feeName feeMap + return $ t {accounts = accMapAfterPay, fees = feeMapAfterPay} performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayPrinBySeq mLimit an bnds mSupport) @@ -922,15 +941,15 @@ performAction d t@TestDeal{bonds=bndMap,accounts=accMap} bndsList = (Map.!) bndMap <$> bnds bndsToPay = filter (not . L.isPaidOff) bndsList bndsToPayNames = L.bndName <$> bndsToPay - bndsWithDue = calcDuePrin t d <$> bndsToPay - bndsDueAmts = L.bndDuePrin <$> bndsWithDue - totalDue = sum bndsDueAmts - actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit in do + bndsWithDue <- sequenceA $ calcDuePrin t d <$> bndsToPay + let bndsDueAmts = L.bndDuePrin <$> bndsWithDue + let totalDue = sum bndsDueAmts + let actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit paidOutAmt <- actualPaidOut let (bondsPaid, remainAmt) = paySequentially d paidOutAmt L.bndDuePrin (L.payPrin d) [] bndsToPay - let accPaidOut = (min availAccBal paidOutAmt) + let accPaidOut = min availAccBal paidOutAmt let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayPrin bndsToPayNames)) an accMap ,bonds = Map.fromList (zip bndsToPayNames bondsPaid) <> bndMap} @@ -945,13 +964,12 @@ performAction d t@TestDeal{bonds=bndMap,accounts=accMap} L.BondGroup bndsMap = bndMap Map.! bndGrpName bndsToPay = Map.filter (not . L.isPaidOff) bndsMap bndsToPayNames = L.bndName <$> Map.elems bndsToPay - bndsWithDueMap = Map.map (calcDuePrin t d) bndsToPay - bndsDueAmtsMap = Map.map (\x -> (x, L.bndDuePrin x)) bndsWithDueMap - totalDue = sum $ snd <$> Map.elems bndsDueAmtsMap -- `debug` (">date"++show d++" due amt"++show bndsDueAmtsMap) - actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit - in do + bndsWithDueMap <- sequenceA $ Map.map (calcDuePrin t d) bndsToPay + let bndsDueAmtsMap = Map.map (\x -> (x, L.bndDuePrin x)) bndsWithDueMap + let totalDue = sum $ snd <$> Map.elems bndsDueAmtsMap -- `debug` (">date"++show d++" due amt"++show bndsDueAmtsMap) + let actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit paidOutAmt <- actualPaidOut let payOutPlan = allocAmtToBonds by paidOutAmt (Map.elems bndsDueAmtsMap) -- `debug` (">date"++ show payAmount) @@ -961,7 +979,7 @@ performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (\(bndName, _amt) acc -> Map.adjust (L.payPrin d _amt) bndName acc) bndsMap payOutPlanWithBondName -- `debug` (">date"++show d++"payoutPlan"++ show payOutPlanWithBondName) - let accPaidOut = (min availAccBal paidOutAmt) + let accPaidOut = min availAccBal paidOutAmt let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayGroupPrin bndsToPayNames)) an accMap ,bonds = Map.insert bndGrpName (L.BondGroup bndMapAfterPay) bndMap} @@ -1034,17 +1052,16 @@ performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayPrin mLimit an bn availAccBal = A.accBalance (accMap Map.! an) bndsToPay = getActiveBonds t bnds - bndsWithDue = calcDuePrin t d <$> bndsToPay - bndsDueAmts = L.bndDuePrin <$> bndsWithDue - - bndsToPayNames = L.bndName <$> bndsWithDue - totalDue = sum bndsDueAmts - actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit - in + in do + bndsWithDue <- sequenceA $ calcDuePrin t d <$> bndsToPay + let bndsDueAmts = L.bndDuePrin <$> bndsWithDue + let bndsToPayNames = L.bndName <$> bndsWithDue + let totalDue = sum bndsDueAmts + let actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit paidOutAmt <- actualPaidOut let (bondsPaid, remainAmt) = payProRata d paidOutAmt L.bndDuePrin (L.payPrin d) bndsWithDue - let accPaidOut = (min availAccBal paidOutAmt) + let accPaidOut = min availAccBal paidOutAmt let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayPrin bndsToPayNames)) an accMap ,bonds = Map.fromList (zip bndsToPayNames bondsPaid) <> bndMap} @@ -1075,81 +1092,58 @@ performAction d t@TestDeal{accounts=accMap, bonds=bndMap} (W.FundWith mlimit an fundAmt_ <- case mlimit of Just (DS ds) -> queryCompound t d (patchDateToStats d ds) Just (DueCapAmt amt) -> Right $ toRational amt - _ -> Left $ "Not valid limit for funding with bond"++ show bnd + _ -> Left $ "Date:"++show d ++"Not valid limit for funding with bond"++ show bnd let fundAmt = fromRational fundAmt_ let accMapAfterFund = Map.adjust (A.deposit fundAmt d (FundWith bnd fundAmt)) an accMap newBnd <- calcDueInt t d Nothing Nothing $ bndMap Map.! bnd let bndFunded = L.fundWith d fundAmt newBnd return $ t {accounts = accMapAfterFund, bonds= Map.fromList [(bnd,bndFunded)] <> bndMap } --- ^ clear a sequence of legders -performAction d t@TestDeal{bonds=bndMap, ledgers = Just ledgerM } (W.WriteOff (Just (ClearLedgerBySeq dr lns)) bnd) + +-- ^ write off bonds and book +performAction d t@TestDeal{bonds = bndMap, ledgers = Just ledgerM } + (W.WriteOffAndBook mLimit bnd (dr,lName)) = let - writeAmt = sum $ (LD.queryGap dr) <$> (ledgerM Map.!) <$> lns - writeAmtCapped = min writeAmt $ L.bndBalance $ bndMap Map.! bnd - newLedgerMap = lstToMapByFn LD.ledgName newLedgers - ledgerList = filter (\l -> LD.queryGap dr l > 0) $ (ledgerM Map.!) <$> lns - (newLedgers,_) = LD.clearLedgersBySeq dr d writeAmtCapped [] ledgerList - newLedgerM = newLedgerMap <> ledgerM + bndToWriteOff = bndMap Map.! bnd + bndBal = L.bndBalance bndToWriteOff in do - newBnd <- calcDueInt t d Nothing Nothing $ bndMap Map.! bnd - let bndWritedOff = L.writeOff d writeAmtCapped newBnd - + writeAmt <- applyLimit t d bndBal bndBal mLimit + let newLedgerM = Map.adjust (LD.entryLogByDr dr writeAmt d (Just (WriteOff bnd writeAmt))) lName ledgerM + newBnd <- calcDueInt t d Nothing Nothing bndToWriteOff + let bndWritedOff = L.writeOff d writeAmt newBnd return $ t {bonds = Map.fromList [(bnd,bndWritedOff)] <> bndMap, ledgers = Just newLedgerM} - -performAction d t@TestDeal{bonds=bndMap, ledgers = Just ledgerM } (W.WriteOff (Just (ClearLedger dr ln)) bnd) - = let - writeAmt = LD.queryGap dr (ledgerM Map.! ln) - writeAmtCapped = min writeAmt $ L.bndBalance $ bndMap Map.! bnd - newLedgerM = Map.adjust (LD.entryLog writeAmtCapped d (TxnDirection dr)) ln ledgerM - in - do - newBnd <- calcDueInt t d Nothing Nothing $ bndMap Map.! bnd - let bndWritedOff = L.writeOff d writeAmtCapped newBnd - return t {bonds = Map.fromList [(bnd,bndWritedOff)] <> bndMap, ledgers = Just newLedgerM} - performAction d t@TestDeal{bonds=bndMap} (W.WriteOff mlimit bnd) - = - do - writeAmt <- case mlimit of - Just (DS ds) -> queryCompound t d (patchDateToStats d ds) - Just (DueCapAmt amt) -> Right $ toRational amt - Nothing -> Right $ toRational . L.bndBalance $ bndMap Map.! bnd - x -> Left $ "not supported type to determine the amount to write off"++ show x - - let writeAmtCapped = min (fromRational writeAmt) $ L.bndBalance $ bndMap Map.! bnd - newBnd <- calcDueInt t d Nothing Nothing $ bndMap Map.! bnd - let bndWritedOff = L.writeOff d writeAmtCapped newBnd - return $ t {bonds = Map.fromList [(bnd,bndWritedOff)] <> bndMap} - -performAction d t@TestDeal{bonds=bndMap, ledgers = Just ledgerM} (W.WriteOffBySeq (Just (ClearLedger dr ln)) bnds) - = let - writeAmt = LD.queryGap dr (ledgerM Map.! ln) - in - do - bndsToWriteOff <- mapM (calcDueInt t d Nothing Nothing . (bndMap Map.!)) bnds - let totalBondBal = sum $ L.bndBalance <$> bndsToWriteOff - let writeAmtCapped = min writeAmt totalBondBal - - let (bndWrited, _) = paySequentially d writeAmtCapped L.bndBalance (L.writeOff d) [] bndsToWriteOff - let bndMapUpdated = lstToMapByFn L.bndName bndWrited - let newLedgerM = Map.adjust (LD.entryLog writeAmtCapped d (TxnDirection dr)) ln ledgerM - return t {bonds = bndMapUpdated <> bndMap, ledgers = Just newLedgerM} + = do + writeAmt <- case mlimit of + Just (DS ds) -> queryCompound t d (patchDateToStats d ds) + Just (DueCapAmt amt) -> Right $ toRational amt + Nothing -> Right $ toRational . L.bndBalance $ bndMap Map.! bnd + x -> Left $ "Date:"++show d ++"not supported type to determine the amount to write off"++ show x + + let writeAmtCapped = min (fromRational writeAmt) $ L.bndBalance $ bndMap Map.! bnd + newBnd <- calcDueInt t d Nothing Nothing $ bndMap Map.! bnd + let bndWritedOff = L.writeOff d writeAmtCapped newBnd + return $ t {bonds = Map.fromList [(bnd,bndWritedOff)] <> bndMap} + +performAction d t@TestDeal{bonds=bndMap, ledgers = Just ledgerM} + (W.WriteOffBySeqAndBook mLimit bnds (dr,lName)) + = do + bndsToWriteOff <- mapM (calcDueInt t d Nothing Nothing . (bndMap Map.!)) bnds + let totalBondBal = sum $ L.bndBalance <$> bndsToWriteOff + writeAmt <- applyLimit t d totalBondBal totalBondBal mLimit + let (bndWrited, _) = paySequentially d writeAmt L.bndBalance (L.writeOff d) [] bndsToWriteOff + let bndMapUpdated = lstToMapByFn L.bndName bndWrited + let newLedgerM = Map.adjust (LD.entryLogByDr dr writeAmt d Nothing) lName ledgerM + return t {bonds = bndMapUpdated <> bndMap, ledgers = Just newLedgerM} -performAction d t@TestDeal{bonds=bndMap } (W.WriteOffBySeq mlimit bnds) +performAction d t@TestDeal{bonds=bndMap } (W.WriteOffBySeq mLimit bnds) = do bondsToWriteOff <- mapM (calcDueInt t d Nothing Nothing . (bndMap Map.!)) bnds let totalBondBal = sum $ L.bndBalance <$> bondsToWriteOff - let writeAmt = case mlimit of - Just (DS ds) -> queryDeal t (patchDateToStats d ds) - Just (DueCapAmt amt) -> amt - Nothing -> totalBondBal - x -> error $ "not supported type to determine the amount to write off"++ show x - - let writeAmtCapped = min writeAmt totalBondBal - let (bndWrited, _) = paySequentially d writeAmtCapped L.bndBalance (L.writeOff d) [] bondsToWriteOff + writeAmt <- applyLimit t d totalBondBal totalBondBal mLimit + let (bndWrited, _) = paySequentially d writeAmt L.bndBalance (L.writeOff d) [] bondsToWriteOff let bndMapUpdated = lstToMapByFn L.bndName bndWrited return t {bonds = bndMapUpdated <> bndMap } @@ -1165,93 +1159,102 @@ performAction d t@TestDeal{bonds=bndMap} (W.CalcBondInt bns mBalDs mRateDs) -- ^ set due prin mannually performAction d t@TestDeal{bonds=bndMap} (W.CalcBondPrin2 mLimit bnds) - = Right $ t {bonds = newBndMap} -- `debug` ("New map after calc due"++ show (Map.mapWithKey (\k v -> (k, L.bndDuePrin v)) newBndMap)) - where - limitCap = case mLimit of - Just (DS ds) -> queryDeal t (patchDateToStats d ds) - Just (DueCapAmt amt) -> amt - Nothing -> 0 + = let + bndsToPay = filter (not . L.isPaidOff) $ map (bndMap Map.!) bnds + bndsToPayNames = L.bndName <$> bndsToPay + in + do + bndsDueAmts <- sequenceA $ (L.bndDuePrin <$>) <$> (calcDuePrin t d) <$> bndsToPay + let totalDue = sum bndsDueAmts + bookCap <- applyLimit t d totalDue totalDue mLimit + let bndsAmountToBook = zip bndsToPayNames $ prorataFactors bndsDueAmts bookCap + let newBndMap = foldr + (\(bn,amt) acc -> Map.adjust (\b -> b {L.bndDuePrin = amt}) bn acc) + bndMap + bndsAmountToBook -- `debug` ("Calc Bond Prin"++ show bndsAmountToBePaid) - bndsToPay = filter (not . L.isPaidOff) $ map (bndMap Map.!) bnds - bndsToPayNames = L.bndName <$> bndsToPay - bndsDueAmts = L.bndDuePrin . calcDuePrin t d <$> bndsToPay - - bndsAmountToBePaid = zip bndsToPayNames $ prorataFactors bndsDueAmts limitCap - - newBndMap = foldr - (\(bn,amt) acc -> Map.adjust (\b -> b {L.bndDuePrin = amt}) bn acc) - bndMap - bndsAmountToBePaid -- `debug` ("Calc Bond Prin"++ show bndsAmountToBePaid) + return $ t {bonds = newBndMap} -- `debug` ("New map after calc due"++ show (Map.mapWithKey (\k v -> (k, L.bndDuePrin v)) newBndMap)) performAction d t@TestDeal{bonds=bndMap, accounts = accMap} (W.CalcBondPrin mLimit accName bnds mSupport) - = do - availBal <- calcAvailFund t d (accMap Map.! accName) mSupport - let limitCap = applyLimit t d availBal (sum bndsDueAmts) mLimit - let payAmount = min limitCap availBal - let bndsAmountToBePaid = zip bndsToPayNames $ prorataFactors bndsDueAmts payAmount -- (bond, amt-allocated) - let newBndMap = foldr - (\(bn,amt) acc -> Map.adjust (\b -> b {L.bndDuePrin = amt}) bn acc) - bndMap - bndsAmountToBePaid -- `debug` ("Calc Bond Prin"++ show bndsAmountToBePaid) - return $ t {bonds = newBndMap} - where + = let accBal = A.accBalance $ accMap Map.! accName bndsToPay = filter (not . L.isPaidOff) $ map (bndMap Map.!) bnds bndsToPayNames = L.bndName <$> bndsToPay - bndsDueAmts = L.bndDuePrin . calcDuePrin t d <$> bndsToPay - + in + do + bndsDueAmts <- sequenceA $ (L.bndDuePrin <$>) <$> (calcDuePrin t d) <$> bndsToPay + availBal <- calcAvailFund t d (accMap Map.! accName) mSupport + limitCap <- applyLimit t d availBal (sum bndsDueAmts) mLimit + let payAmount = min limitCap availBal + let bndsAmountToBePaid = zip bndsToPayNames $ prorataFactors bndsDueAmts payAmount -- (bond, amt-allocated) + let newBndMap = foldr + (\(bn,amt) acc -> Map.adjust (\b -> b {L.bndDuePrin = amt}) bn acc) + bndMap + bndsAmountToBePaid -- `debug` ("Calc Bond Prin"++ show bndsAmountToBePaid) + return $ t {bonds = newBndMap} + -- ^ draw cash and deposit to account -performAction d t@TestDeal{accounts=accs, liqProvider = Just _liqProvider} (W.LiqSupport limit pName CE.LiqToAcc an) - = - do - _transferAmt <- case limit of - Nothing -> Right 0 -- `debug` ("limit on nothing"++ show limit) - Just (DS ds) -> queryCompound t d (patchDateToStats d ds) -- `debug` ("hit with ds"++ show ds) - _ -> Left $ "Failed on passed from action : liqSupport, only formula is supported but got "++ show limit -- `debug` ("limit on last"++ show limit) - let transferAmt = fromRational $ max 0 $ - case CE.liqCredit $ _liqProvider Map.! pName of - Nothing -> _transferAmt -- `debug` ("not loc"++ show newLiqMapUpdated) - Just _availBal -> min _transferAmt (toRational _availBal) -- `debug` ("transfer amt"++ show _transferAmt ++ "loc"++ show _availBal) - - return t { accounts = Map.adjust (A.deposit transferAmt d (LiquidationSupport pName)) an accs - , liqProvider = Just $ Map.adjust (CE.draw transferAmt d) pName _liqProvider - } +performAction d t@TestDeal{accounts=accs, liqProvider = Just _liqProvider} (W.LiqSupport mLimit pName CE.LiqToAcc ans) + | length ans == 1 + = let + liq = _liqProvider Map.! pName + [an] = ans + in + do + transferAmt <- case (CE.liqCredit liq, mLimit) of + (Nothing, Nothing) -> Left $ "Date:"++show d ++"Can't deposit unlimit cash to an account in LiqSupport(Account):"++ show pName ++ ":"++ show an + (Just av, Nothing) -> Right . toRational $ av + (Nothing, Just (DS ds)) -> queryCompound t d (patchDateToStats d ds) -- `debug` ("hit with ds"++ show ds) + (Just av, Just (DS ds)) -> (min (toRational av)) <$> queryCompound t d (patchDateToStats d ds) + (_ , Just _x) -> Left $ "Date:"++show d ++"Not support limit in LiqSupport(Account)"++ show _x + let dAmt = fromRational transferAmt + return t { accounts = Map.adjust (A.deposit dAmt d (LiquidationSupport pName)) an accs + , liqProvider = Just $ Map.adjust (CE.draw dAmt d) pName _liqProvider + } + | otherwise = Left $ "Date:"++show d ++"There should only one account for LiqToAcc of LiqSupport" + + +-- TODO : add pay fee by sequence +performAction d t@TestDeal{fees=feeMap,liqProvider = Just _liqProvider} (W.LiqSupport mLimit pName CE.LiqToFee fns) + = let + liq = _liqProvider Map.! pName + in + do + totalDueFee <- queryCompound t d (CurrentDueFee fns) + supportAmt <- applyLimit t d (fromRational totalDueFee) (fromRational totalDueFee) mLimit -performAction d t@TestDeal{fees=feeMap,liqProvider = Just _liqProvider} (W.LiqSupport limit pName CE.LiqToFee fn) - = Right $ t { fees = newFeeMap, liqProvider = Just newLiqMap } - where - _transferAmt = case limit of - Nothing -> 0 - Just (DS (CurrentDueFee [fn])) -> queryDeal t (CurrentDueFee [fn]) - _ -> 0 + let transferAmt = case (CE.liqCredit liq) of + Nothing -> supportAmt + (Just v) -> min supportAmt v + + let newFeeMap = payInMap d transferAmt F.feeDue (F.payFee d) fns ByProRata feeMap + let newLiqMap = Map.adjust (CE.draw transferAmt d) pName _liqProvider + return $ t { fees = newFeeMap, liqProvider = Just newLiqMap } - transferAmt = case CE.liqCredit $ _liqProvider Map.! pName of - Nothing -> _transferAmt - Just _availBal -> min _transferAmt _availBal +-- TODO : add pay int by sequence +-- TODO : may not work for bond group +performAction d t@TestDeal{bonds=bndMap,liqProvider = Just _liqProvider} (W.LiqSupport mLimit pName CE.LiqToBondInt bns) + = let + liq = _liqProvider Map.! pName + in + do + totalDueInt <- queryCompound t d (CurrentDueBondInt bns) + supportAmt <- applyLimit t d (fromRational totalDueInt) (fromRational totalDueInt) mLimit - newFeeMap = Map.adjust (F.payFee d transferAmt) fn feeMap - newLiqMap = Map.adjust (CE.draw transferAmt d ) pName _liqProvider + let transferAmt = case (CE.liqCredit liq) of + Nothing -> supportAmt + (Just v) -> min supportAmt v -performAction d t@TestDeal{bonds=bndMap,liqProvider = Just _liqProvider} (W.LiqSupport limit pName CE.LiqToBondInt bn) - = Right $ t { bonds = newBondMap, liqProvider = Just newLiqMap } - where - _transferAmt = case limit of - Nothing -> 0 - Just (DS (CurrentDueBondInt [bn])) -> queryDeal t (CurrentDueBondInt [bn]) - _ -> error $ "Not implement the limit"++ show limit++"For Pay Yield to liqProvider" - transferAmt = case CE.liqCredit $ _liqProvider Map.! pName of - Nothing -> _transferAmt - Just _availBal -> min _transferAmt _availBal - --transferAmt = min _transferAmt $ CE.liqBalance $ _liqProvider Map.! pName - newBondMap = Map.adjust (L.payInt d transferAmt ) bn bndMap - newLiqMap = Map.adjust (CE.draw transferAmt d ) pName _liqProvider + let newBondMap = payInMap d transferAmt L.totalDueInt (L.payInt d) bns ByProRata bndMap + let newLiqMap = Map.adjust (CE.draw transferAmt d) pName _liqProvider + return $ t { bonds = newBondMap, liqProvider = Just newLiqMap } -- ^ payout due interest / due fee / oustanding balance to liq provider -performAction d t@TestDeal{accounts=accs,liqProvider = Just _liqProvider} (W.LiqRepay limit rpt an pName) - = Right $ t { accounts = newAccMap, liqProvider = Just newLiqMap } - where +performAction d t@TestDeal{accounts=accs,liqProvider = Just _liqProvider} (W.LiqRepay mLimit rpt an pName) + = + let liqDueAmts CE.LiqBal = [ CE.liqBalance $ _liqProvider Map.! pName] liqDueAmts CE.LiqInt = [ CE.liqDueInt $ _liqProvider Map.! pName ] liqDueAmts CE.LiqPremium = [ CE.liqDuePremium $ _liqProvider Map.! pName] @@ -1266,29 +1269,26 @@ performAction d t@TestDeal{accounts=accs,liqProvider = Just _liqProvider} (W.Liq liqTotalDues = sum dueBreakdown cap = min liqTotalDues $ A.accBalance $ accs Map.! an + in + do + transferAmt <- applyLimit t d cap cap mLimit + let paidOutsToLiq = paySeqLiabilitiesAmt transferAmt dueBreakdown + let rptsToPair = case rpt of + CE.LiqRepayTypes lrts -> lrts + x -> [x] - transferAmt = case limit of - Just (DS ds) -> min cap $ queryDeal t (patchDateToStats d ds) -- `debug` ("Cap acc"++ show cap) - Nothing -> cap - _ -> error $ "Not implement the limit"++ show limit++"For Repay to liqProvider" - - paidOutsToLiq = paySeqLiabilitiesAmt transferAmt dueBreakdown - - rptsToPair = case rpt of - CE.LiqRepayTypes lrts -> lrts - x -> [x] - - paidOutWithType - | overDrawnBalance > 0 = zip (CE.LiqOD:rptsToPair) paidOutsToLiq - | otherwise = zip rptsToPair paidOutsToLiq -- `debug` ("rpts To pair"++ show rptsToPair) + let paidOutWithType + | overDrawnBalance > 0 = zip (CE.LiqOD:rptsToPair) paidOutsToLiq + | otherwise = zip rptsToPair paidOutsToLiq -- `debug` ("rpts To pair"++ show rptsToPair) - newAccMap = Map.adjust (A.draw transferAmt d (LiquidationSupport pName)) an accs -- `debug` ("repay liq amt"++ show transferAmt) - newLiqMap = foldl - (\acc (_rpt,_amt) -> Map.adjust (CE.repay _amt d _rpt ) pName acc) - _liqProvider - paidOutWithType -- `debug` ("paid out"++ show paidOutWithType) + let newAccMap = Map.adjust (A.draw transferAmt d (LiquidationSupport pName)) an accs -- `debug` ("repay liq amt"++ show transferAmt) + let newLiqMap = foldl + (\acc (_rpt,_amt) -> Map.adjust (CE.repay _amt d _rpt ) pName acc) + _liqProvider + paidOutWithType + return $ t { accounts = newAccMap, liqProvider = Just newLiqMap } -- paidOutWithType -- `debug` ("paid out"++ show paidOutWithType) -- ^ pay yield to liq provider performAction d t@TestDeal{accounts=accs,liqProvider = Just _liqProvider} (W.LiqYield limit an pName) @@ -1298,7 +1298,7 @@ performAction d t@TestDeal{accounts=accs,liqProvider = Just _liqProvider} (W.Liq transferAmt <- case limit of Nothing -> Right (toRational cap) Just (DS ds) -> (min (toRational cap)) <$> (queryCompound t d (patchDateToStats d ds)) - _ -> Left $ "Not implement the limit"++ show limit++"For Pay Yield to liqProvider" + _ -> Left $ "Date:"++show d ++"Not implement the limit"++ show limit++"For Pay Yield to liqProvider" let newAccMap = Map.adjust (A.draw (fromRational transferAmt) d (LiquidationSupport pName)) an accs let newLiqMap = Map.adjust (CE.repay (fromRational transferAmt) d CE.LiqResidual) pName _liqProvider @@ -1310,19 +1310,20 @@ performAction d t@TestDeal{liqProvider = Just _liqProvider} (W.LiqAccrue liqName updatedLiqProvider = mapWithinMap ((updateLiqProvider t d) . (CE.accrueLiqProvider d)) liqNames _liqProvider --- TODO fix query performAction d t@TestDeal{rateSwap = Just rtSwap } (W.SwapAccrue sName) - = Right $ t { rateSwap = Just newRtSwap } - where - refBal = case HE.rsNotional (rtSwap Map.! sName) of - (HE.Fixed b) -> b - (HE.Base ds) -> queryDeal t (patchDateToStats d ds) - (HE.Schedule ts) -> fromRational $ getValByDate ts Inc d - - newRtSwap = Map.adjust - (HE.accrueIRS d) - sName - (Map.adjust (set HE.rsRefBalLens refBal) sName rtSwap) + = + do + refBal <- case HE.rsNotional (rtSwap Map.! sName) of + (HE.Fixed b) -> Right b + (HE.Base ds) -> fromRational <$> queryCompound t d (patchDateToStats d ds) + (HE.Schedule ts) -> Right . fromRational $ getValByDate ts Inc d + + let newRtSwap = Map.adjust + (HE.accrueIRS d) + sName + (Map.adjust (set HE.rsRefBalLens refBal) sName rtSwap) + return $ t { rateSwap = Just newRtSwap } + performAction d t@TestDeal{rateSwap = Just rtSwap, accounts = accsMap } (W.SwapReceive accName sName) = Right $ t { rateSwap = Just newRtSwap, accounts = newAccMap } @@ -1331,6 +1332,7 @@ performAction d t@TestDeal{rateSwap = Just rtSwap, accounts = accsMap } (W.SwapR newRtSwap = Map.adjust (HE.receiveIRS d) sName rtSwap -- `debug` ("REceiv AMT"++ show receiveAmt) newAccMap = Map.adjust (A.deposit receiveAmt d SwapInSettle) accName accsMap + performAction d t@TestDeal{rateCap = Just rcM, accounts = accsMap } (W.CollectRateCap accName sName) = Right $ t { rateCap = Just newRcSwap, accounts = newAccMap } where @@ -1368,6 +1370,7 @@ performAction d t@TestDeal{ triggers = Just trgM } (W.RunTrigger loc tNames) (testTrigger t d) triggerList + performAction d t (W.Placeholder mComment) = Right t -performAction d t action = error $ "failed to match action>>"++show action++">>Deal"++show (name t) +performAction d t action = Left $ "failed to match action>>"++show action++">>Deal"++show (name t) diff --git a/src/Deal/DealBase.hs b/src/Deal/DealBase.hs index 49097ae6..3bc8782c 100644 --- a/src/Deal/DealBase.hs +++ b/src/Deal/DealBase.hs @@ -199,7 +199,7 @@ uDealFutureCf = lens getter setter uDealFutureTxn :: Ast.Asset a => Lens' (UnderlyingDeal a) [CF.TsRow] uDealFutureTxn = lens getter setter where - getter ud = fromMaybe [] $ CF.getTsCashFlowFrame <$> futureCf ud + getter ud = fromMaybe [] $ (view CF.cashflowTxn) <$> futureCf ud setter ud newTxn = let mOriginalCfFrame = futureCf ud @@ -210,11 +210,14 @@ uDealFutureTxn = lens getter setter Just (CF.CashFlowFrame (begBal,begDate,mInt) txns) -> ud {futureCf = Just (CF.CashFlowFrame (0,toDate "19000101",Nothing) newTxn) } -data PoolType a = SoloPool (P.Pool a) - | MultiPool (Map.Map PoolId (P.Pool a)) +data PoolType a = MultiPool (Map.Map PoolId (P.Pool a)) | ResecDeal (Map.Map PoolId (UnderlyingDeal a)) deriving (Generic, Eq, Ord, Show) + + + + data TestDeal a = TestDeal { name :: DealName ,status :: DealStatus ,dates :: DateDesp @@ -368,29 +371,26 @@ dealPool = lens getter setter setter d newPool = d {pool = newPool} - - poolTypePool :: Ast.Asset a => Lens' (PoolType a) (Map.Map PoolId (P.Pool a)) poolTypePool = lens getter setter where - getter = \case - SoloPool p -> Map.singleton PoolConsol p - MultiPool pm -> pm - setter (SoloPool p) newPm = SoloPool (newPm Map.! PoolConsol) + getter = \case MultiPool pm -> pm setter (MultiPool pm) newPm = MultiPool newPm +poolTypeUnderDeal :: Ast.Asset a => Lens' (PoolType a) (Map.Map PoolId (UnderlyingDeal a)) +poolTypeUnderDeal = lens getter setter + where + getter = \case ResecDeal dm -> dm + setter (ResecDeal dm) newDm = ResecDeal newDm + dealScheduledCashflow :: Ast.Asset a => Lens' (TestDeal a) (Map.Map PoolId (Maybe CF.CashFlowFrame)) dealScheduledCashflow = lens getter setter where getter d = case pool d of - SoloPool p -> Map.fromList [(PoolConsol,P.futureScheduleCf p)] MultiPool pm -> Map.map P.futureScheduleCf pm ResecDeal uds -> Map.map futureScheduleCf uds x -> error $ "Failed to match :" ++ show x setter d newCfMap = case pool d of - SoloPool p -> case Map.lookup PoolConsol newCfMap of - Just cf -> set dealPool (SoloPool (p {P.futureScheduleCf = cf})) d - Nothing -> error $ "can't set multi pool cf to a solo pool" MultiPool pm -> let newPm = Map.mapWithKey (\k p -> set P.poolFutureScheduleCf (newCfMap Map.! k) p) pm in @@ -406,13 +406,9 @@ dealCashflow :: Ast.Asset a => Lens' (TestDeal a) (Map.Map PoolId (Maybe CF.Cash dealCashflow = lens getter setter where getter d = case pool d of - SoloPool p -> Map.fromList [(PoolConsol,P.futureCf p)] MultiPool pm -> Map.map P.futureCf pm ResecDeal uds -> Map.map futureCf uds setter d newCfMap = case pool d of - SoloPool p -> case Map.lookup PoolConsol newCfMap of - Just cf -> set dealPool (SoloPool (p {P.futureCf = cf})) d - Nothing -> error $ "can't set multi pool cf to a solo pool" MultiPool pm -> let newPm = Map.mapWithKey (\k p -> set P.poolFutureCf (newCfMap Map.! k) p) pm in @@ -427,7 +423,6 @@ dealCashflow = lens getter setter getPoolIds :: Ast.Asset a => TestDeal a -> [PoolId] getPoolIds t@TestDeal{pool = pt} = case pt of - SoloPool _ -> [PoolConsol] MultiPool pm -> Map.keys pm ResecDeal pm -> Map.keys pm _ -> error "failed to match pool type in pool ids" @@ -447,7 +442,6 @@ getIssuanceStats t@TestDeal{pool = pt} mPoolId Just pns -> Map.filterWithKey (\k _ -> k `elem` pns ) uDeals in Map.map (fromMaybe Map.empty . issuanceStat) selecteduDeals - SoloPool p -> Map.fromList [(PoolConsol, fromMaybe Map.empty (P.issuanceStat p))] MultiPool pm -> let selectedPools = case mPoolId of Nothing -> pm @@ -466,7 +460,6 @@ getAllAsset :: TestDeal a -> Maybe [PoolId] -> Map.Map PoolId [a] getAllAsset t@TestDeal{pool = pt} mPns = let assetMap = case pt of - SoloPool p -> Map.fromList [(PoolConsol, P.assets p)] MultiPool pm -> Map.map P.assets pm ResecDeal _ -> Map.empty -- ResecDeal pm -> Map.mapWithKey (\(UnderlyingBond (bn,hpct,sd), d) -> getAllAsset d Nothing) pm @@ -484,7 +477,7 @@ getAllCollectedFrame t mPid = mCf = view dealCashflow t in case mPid of - Nothing -> mCf -- `debug` ("Nothing when collecting cfs"++show mCf) + Nothing -> mCf -- `debug` ("Nothing when collecting cfs"++show mCf) Just pids -> Map.filterWithKey (\k _ -> k `elem` pids) mCf -- `debug` ("Just when collecting cfs"++show mCf) getLatestCollectFrame :: Ast.Asset a => TestDeal a -> Maybe [PoolId] -> Map.Map PoolId (Maybe CF.TsRow) diff --git a/src/Deal/DealQuery.hs b/src/Deal/DealQuery.hs index f94596f9..77ae2a73 100644 --- a/src/Deal/DealQuery.hs +++ b/src/Deal/DealQuery.hs @@ -4,8 +4,8 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} -module Deal.DealQuery (queryDealBool,queryDeal - ,patchDateToStats,patchDatesToStats,testPre, calcTargetAmount, testPre2 +module Deal.DealQuery (queryDealBool ,patchDateToStats,patchDatesToStats,testPre + ,calcTargetAmount, testPre2 ,queryCompound) where @@ -55,9 +55,9 @@ calcTargetAmount t d (A.Account _ _ _ (Just r) _ ) = eval :: A.ReserveAmount -> Either String Balance eval ra = case ra of A.PctReserve ds _rate -> do - v <- (queryCompound t d (patchDateToStats d ds)) + v <- queryCompound t d (patchDateToStats d ds) return (fromRational (v * _rate)) - A.FixReserve amt -> Right $ amt + A.FixReserve amt -> Right amt A.Either p ra1 ra2 -> do q <- testPre d t p if q then @@ -69,41 +69,41 @@ calcTargetAmount t d (A.Account _ _ _ (Just r) _ ) = patchDateToStats :: Date -> DealStats -> DealStats patchDateToStats d t - = case t of - CurrentPoolBalance mPns -> FutureCurrentPoolBalance mPns - CurrentPoolBegBalance mPns -> FutureCurrentPoolBegBalance mPns - PoolFactor mPns -> FutureCurrentPoolFactor d mPns - LastBondIntPaid bns -> BondsIntPaidAt d bns - LastFeePaid fns -> FeesPaidAt d fns - LastBondPrinPaid bns -> BondsPrinPaidAt d bns - BondBalanceGap bn -> BondBalanceGapAt d bn - ReserveGap ans -> ReserveGapAt d ans - ReserveExcess ans -> ReserveExcessAt d ans - Sum _ds -> Sum $ map (patchDateToStats d) _ds - Substract _ds -> Substract $ map (patchDateToStats d) _ds - Subtract _ds -> Subtract $ map (patchDateToStats d) _ds - Min dss -> Min $ [ patchDateToStats d ds | ds <- dss ] - Max dss -> Max $ [ patchDateToStats d ds | ds <- dss ] - Factor _ds r -> Factor (patchDateToStats d _ds) r - FloorWithZero ds -> FloorWithZero (patchDateToStats d ds) - UseCustomData n -> CustomData n d - CurrentPoolBorrowerNum mPns -> FutureCurrentPoolBorrowerNum d mPns - FeeTxnAmt ns mCmt -> FeeTxnAmtBy d ns mCmt - BondTxnAmt ns mCmt -> BondTxnAmtBy d ns mCmt - AccTxnAmt ns mCmt -> AccTxnAmtBy d ns mCmt -- `debug` ("Hitttt") - PoolScheduleCfPv pm pns -> FuturePoolScheduleCfPv d pm pns - Excess dss -> Excess $ [ patchDateToStats d ds | ds <- dss ] - Abs ds -> Abs $ patchDateToStats d ds - Avg dss -> Avg $ [ patchDateToStats d ds | ds <- dss ] - Divide ds1 ds2 -> Divide (patchDateToStats d ds1) (patchDateToStats d ds2) - FloorAndCap f c s -> FloorAndCap (patchDateToStats d f) (patchDateToStats d c) (patchDateToStats d s) - Multiply dss -> Multiply $ [ patchDateToStats d ds | ds <- dss ] - FloorWith ds f -> FloorWith (patchDateToStats d ds) (patchDateToStats d f) - CapWith ds c -> CapWith (patchDateToStats d ds) (patchDateToStats d c) - Round ds rb -> Round (patchDateToStats d ds) rb - DivideRatio ds1 ds2 -> DivideRatio (patchDateToStats d ds1) (patchDateToStats d ds2) - AvgRatio ss -> AvgRatio $ [ patchDateToStats d ds | ds <- ss ] - _ -> t -- `debug` ("Failed to patch date to stats"++show t) + = case t of + CurrentPoolBalance mPns -> FutureCurrentPoolBalance mPns + CurrentPoolBegBalance mPns -> FutureCurrentPoolBegBalance mPns + PoolFactor mPns -> FutureCurrentPoolFactor d mPns + LastBondIntPaid bns -> BondsIntPaidAt d bns + LastFeePaid fns -> FeesPaidAt d fns + LastBondPrinPaid bns -> BondsPrinPaidAt d bns + BondBalanceGap bn -> BondBalanceGapAt d bn + ReserveGap ans -> ReserveGapAt d ans + ReserveExcess ans -> ReserveExcessAt d ans + Sum _ds -> Sum $ map (patchDateToStats d) _ds + Substract _ds -> Substract $ map (patchDateToStats d) _ds + Subtract _ds -> Subtract $ map (patchDateToStats d) _ds + Min dss -> Min $ [ patchDateToStats d ds | ds <- dss ] + Max dss -> Max $ [ patchDateToStats d ds | ds <- dss ] + Factor _ds r -> Factor (patchDateToStats d _ds) r + FloorWithZero ds -> FloorWithZero (patchDateToStats d ds) + UseCustomData n -> CustomData n d + CurrentPoolBorrowerNum mPns -> FutureCurrentPoolBorrowerNum d mPns + FeeTxnAmt ns mCmt -> FeeTxnAmtBy d ns mCmt + BondTxnAmt ns mCmt -> BondTxnAmtBy d ns mCmt + AccTxnAmt ns mCmt -> AccTxnAmtBy d ns mCmt -- `debug` ("Hitttt") + PoolScheduleCfPv pm pns -> FuturePoolScheduleCfPv d pm pns + Excess dss -> Excess $ [ patchDateToStats d ds | ds <- dss ] + Abs ds -> Abs $ patchDateToStats d ds + Avg dss -> Avg $ [ patchDateToStats d ds | ds <- dss ] + Divide ds1 ds2 -> Divide (patchDateToStats d ds1) (patchDateToStats d ds2) + FloorAndCap f c s -> FloorAndCap (patchDateToStats d f) (patchDateToStats d c) (patchDateToStats d s) + Multiply dss -> Multiply $ [ patchDateToStats d ds | ds <- dss ] + FloorWith ds f -> FloorWith (patchDateToStats d ds) (patchDateToStats d f) + CapWith ds c -> CapWith (patchDateToStats d ds) (patchDateToStats d c) + Round ds rb -> Round (patchDateToStats d ds) rb + DivideRatio ds1 ds2 -> DivideRatio (patchDateToStats d ds1) (patchDateToStats d ds2) + AvgRatio ss -> AvgRatio $ [ patchDateToStats d ds | ds <- ss ] + _ -> t -- `debug` ("Failed to patch date to stats"++show t) patchDatesToStats :: P.Asset a => TestDeal a -> Date -> Date -> DealStats -> DealStats patchDatesToStats t d1 d2 ds @@ -128,7 +128,6 @@ patchDatesToStats t d1 d2 ds AvgRatio ss -> AvgRatio $ [ patchDatesToStats t d1 d2 ds | ds <- ss ] x -> x - -- ^ map from Pool Source to Pool CutoffFields in Pool Map poolSourceToIssuanceField :: PoolSource -> CutoffFields @@ -146,177 +145,307 @@ poolSourceToIssuanceField NewDelinquencies = HistoryDelinquency poolSourceToIssuanceField a = error ("Failed to match pool source when mapping to issuance field"++show a) -queryDeal :: P.Asset a => TestDeal a -> DealStats -> Balance -queryDeal t@TestDeal{accounts=accMap, bonds=bndMap, fees=feeMap, ledgers=ledgerM, pool=pt } s = + +queryCompound :: P.Asset a => TestDeal a -> Date -> DealStats -> Either String Rational +queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=feeMap, pool=pt} + d s = case s of - CurrentBondBalance -> Map.foldr (\x acc -> getCurBalance x + acc) 0.0 bndMap + Sum _s -> sum <$> sequenceA [ queryCompound t d __s | __s <- _s] + Substract dss -> queryCompound t d (Subtract dss) + Subtract (ds:dss) -> + do + a <- queryCompound t d ds + bs <- queryCompound t d (Sum dss) + return $ a - bs + Avg dss -> (/ (toRational (length dss))) <$> (sum <$> sequenceA (queryCompound t d <$> dss )) + Max ss -> maximum' [ queryCompound t d s | s <- ss ] + Min ss -> minimum' [ queryCompound t d s | s <- ss ] + Divide ds1 ds2 -> if (queryCompound t d ds2) == Right 0 then + Left $ "Date:"++show d++"Can not divide zero on ds: "++ show ds2 + else + liftA2 (/) (queryCompound t d ds1) (queryCompound t d ds2) + Factor s f -> (* f) <$> queryCompound t d s + FloorAndCap floor cap s -> max (queryCompound t d floor) $ min (queryCompound t d cap) (queryCompound t d s) + Multiply ss -> product <$> sequenceA [ queryCompound t d _s | _s <- ss] + FloorWith s floor -> liftA2 max (queryCompound t d s) (queryCompound t d floor) + FloorWithZero s -> max 0 <$> queryCompound t d s + Excess (s1:ss) -> do + q1 <- queryCompound t d s1 + q2 <- queryCompound t d (Sum ss) -- `debug` ("Excess"++show (queryCompound t s1)++"ss"++show ( queryCompound t (Sum ss))) + return (max 0 (q1 -q2)) + CapWith s cap -> min (queryCompound t d s) (queryCompound t d cap) + Abs s -> abs <$> queryCompound t d s + Round ds rb -> do + q <- queryCompound t d ds + return $ roundingBy rb q + DivideRatio s1 s2 -> queryCompound t d (Divide s1 s2) + AvgRatio ss -> queryCompound t d (Avg ss) + Constant v -> Right v + -- rate query + BondFactor -> queryCompound t d (Divide CurrentBondBalance OriginalBondBalance) + BondFactorOf bn -> + queryCompound t d (Divide (CurrentBondBalanceOf [bn]) (OriginalBondBalanceOf [bn])) + PoolFactor mPns -> + queryCompound t d (Divide (CurrentPoolBalance mPns) (OriginalPoolBalance mPns)) + FutureCurrentPoolFactor asOfDay mPns -> + queryCompound t d (Divide (FutureCurrentPoolBalance mPns) (OriginalPoolBalance mPns)) + CumulativePoolDefaultedRate mPns -> + queryCompound t d (Divide (PoolCumCollection [NewDefaults] mPns) (OriginalPoolBalance mPns)) + CumulativeNetLossRatio mPns -> + queryCompound t d (Divide (CumulativeNetLoss mPns) (OriginalPoolBalance mPns)) + CumulativePoolDefaultedRateTill idx mPns -> + queryCompound t d (Divide (PoolCumCollectionTill idx [NewDefaults] mPns) (OriginalPoolBalance mPns)) - OriginalBondBalance -> Map.foldr (\x acc -> getOriginBalance x + acc) 0.0 bndMap + BondRate bn -> + case Map.lookup bn (bonds t) of + Just b@(L.Bond {}) -> Right . toRational $ L.bndRate b + Just b@(L.BondGroup bSubMap) -> + let + bnds = Map.elems bSubMap + rates = toRational . L.bndRate <$> bnds + bals = L.getCurBalance <$> bnds + in + Right $ weightedBy bals rates + Nothing -> + case viewDealBondsByNames t [bn] of + [b] -> Right $ toRational $ L.bndRate b + + BondWaRate bns -> + do + rs <- sequenceA $ (\bn -> queryCompound t d (BondRate bn)) <$> bns + ws <- sequenceA $ (\bn -> queryCompound t d (CurrentBondBalanceOf [bn])) <$> bns + return $ weightedBy (fromRational <$> ws) rs + PoolWaRate mPns -> + let + latestCfs = filter isJust $ Map.elems $ getLatestCollectFrame t mPns + rates = toRational . maybe 0.0 CF.mflowRate <$> latestCfs + bals = maybe 0.0 CF.mflowBalance <$> latestCfs + in + Right $ weightedBy bals rates + + -- int query + FutureCurrentPoolBorrowerNum _d mPns -> + let + poolCfs = Map.elems $ getLatestCollectFrame t mPns + poolBn = maybe 0 (fromMaybe 0 . CF.mflowBorrowerNum) <$> poolCfs + in + Right . toRational $ sum poolBn + CurrentPoolBorrowerNum mPns -> + let + assetM = concat $ Map.elems $ getAllAsset t mPns + in + Right . toRational $ sum $ P.getBorrowerNum <$> assetM + + MonthsTillMaturity bn -> + do + (L.OriginalInfo _ _ _ mm) <- lookupAndApply L.bndOriginInfo "Get Months till maturity" bn bndMap + case mm of + Nothing -> Left $ "Date:"++show d++"There is maturity date for bond " ++ bn + Just md -> Right . toRational $ T.cdMonths $ T.diffGregorianDurationClip md d + + + ProjCollectPeriodNum -> Right . toRational $ maximum' $ Map.elems $ Map.map (maybe 0 CF.sizeCashFlowFrame) $ getAllCollectedFrame t Nothing + + ReserveBalance ans -> + do + accBal <- lookupAndApplies (calcTargetAmount t d) ("Date:"++show d++"Cal Reserve Balance") ans accMap + vs <- sequenceA accBal + return $ toRational (sum vs) + + + ReserveExcessAt _d ans -> + do + q1 <- queryCompound t d (AccBalance ans) + q2 <- queryCompound t d (ReserveBalance ans) + return $ max 0 (q1 - q2) + + ReserveGapAt _d ans -> + do + q1 <- queryCompound t d (AccBalance ans) + q2 <- queryCompound t d (ReserveBalance ans) + return $ max 0 (q2 - q1) + + CurrentBondBalance -> Right . toRational $ Map.foldr (\x acc -> getCurBalance x + acc) 0.0 bndMap - BondDuePrin bnds -> sum $ L.bndDuePrin <$> viewDealBondsByNames t bnds + OriginalBondBalance -> Right . toRational $ Map.foldr (\x acc -> getOriginBalance x + acc) 0.0 bndMap - OriginalBondBalanceOf bnds -> sum $ getOriginBalance <$> viewDealBondsByNames t bnds + BondDuePrin bnds -> Right . toRational $ sum $ L.bndDuePrin <$> viewDealBondsByNames t bnds + + OriginalBondBalanceOf bnds -> Right . toRational $ sum $ getOriginBalance <$> viewDealBondsByNames t bnds - CurrentBondBalanceOf bns -> sum $ getCurBalance <$> viewDealBondsByNames t bns + CurrentBondBalanceOf bns -> Right . toRational $ sum $ getCurBalance <$> viewDealBondsByNames t bns CurrentPoolBalance mPns -> let assetM = concat $ Map.elems $ getAllAsset t mPns in - sum $ P.getCurrentBal <$> assetM + Right . toRational $ sum $ P.getCurrentBal <$> assetM CurrentPoolDefaultedBalance -> - foldl (\acc x -> acc + P.getCurrentBal x) - 0.0 $ - filter P.isDefaulted (getAllAssetList t) + Right . toRational $ + foldl (\acc x -> acc + P.getCurrentBal x) + 0.0 $ + filter P.isDefaulted (getAllAssetList t) DealIssuanceBalance mPns -> - sum $ Map.findWithDefault 0.0 IssuanceBalance <$> Map.elems (getIssuanceStats t mPns) + Right . toRational $ + sum $ Map.findWithDefault 0.0 IssuanceBalance <$> Map.elems (getIssuanceStats t mPns) OriginalPoolBalance mPns -> let statsConsol = getIssuanceStatsConsol t mPns in case Map.lookup IssuanceBalance statsConsol of - Just v -> v - Nothing -> error "No issuance balance found in the pool, pls specify it in the pool stats map `issuanceStat`" + Just v -> Right . toRational $ v + Nothing -> Left $ "Date:"++show d++"No issuance balance found in the pool, pls specify it in the pool stats map `issuanceStat`" - UnderlyingBondBalance mBndNames -> 0 + UnderlyingBondBalance mBndNames -> Left $ "Date:"++show d++"Not implemented for underlying bond balance" - AllAccBalance -> sum $ map A.accBalance $ Map.elems accMap + AllAccBalance -> Right . toRational $ sum $ map A.accBalance $ Map.elems accMap - AccBalance ans -> sum $ A.accBalance . (accMap Map.!) <$> ans + AccBalance ans -> + do + accBals <- lookupAndApplies A.accBalance "AccBalance" ans accMap + return $ (toRational . sum) accBals - -- ReserveBalance ans -> - -- - -- ReserveAccGapAt d ans -> - -- - -- ReserveExcessAt d ans -> - -- ^ negatave -> credit balance , postive -> debit balance LedgerBalance ans -> - case ledgerM of - Nothing -> error ("No ledgers were modeled , failed to find ledger:"++show ans ) - Just ledgersM -> sum $ LD.ledgBalance . (ledgersM Map.!) <$> ans + case ledgersM of + 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 + return $ (toRational . sum) lgBals + LedgerBalanceBy dr ans -> + case ledgersM of + Nothing -> Left ("Date:"++show d++"No ledgers were modeled , failed to find ledger:"++show ans ) + Just ledgersM -> + 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 -- `debug` ("dr"++show dr++">> bs dr"++ show (bs dr)) + FutureCurrentPoolBalance mPns -> case (mPns,pt) of - (Just [PoolConsol], SoloPool p) -> Pl.getIssuanceField p RuntimeCurrentPoolBalance - (Nothing, SoloPool p) -> Pl.getIssuanceField p RuntimeCurrentPoolBalance - (Nothing, MultiPool pm ) -> queryDeal t (FutureCurrentPoolBalance (Just $ Map.keys pm)) + (Nothing, MultiPool pm ) -> queryCompound t d (FutureCurrentPoolBalance (Just $ Map.keys pm)) (Just pids, MultiPool pm) -> if S.isSubsetOf (S.fromList pids) (S.fromList (Map.keys pm)) then let m = Map.filterWithKey (\k _ -> S.member k (S.fromList pids)) pm in - sum $ Map.elems $ Map.map (`Pl.getIssuanceField` RuntimeCurrentPoolBalance) m + Right . toRational $ sum $ Map.elems $ Map.map (`Pl.getIssuanceField` RuntimeCurrentPoolBalance) m else - error $ "Failed to find pool balance" ++ show pids ++ " from deal "++ show (Map.keys pm) - _ -> error $ "Failed to find pool" ++ show (mPns) ++","++ show pt + Left $ "Date:"++show d++"Failed to find pool balance" ++ show pids ++ " from deal "++ show (Map.keys pm) + _ -> Left $ "Date:"++show d++"Failed to find pool" ++ show (mPns) ++","++ show pt FutureCurrentSchedulePoolBalance mPns -> let scheduleFlowM = Map.elems $ view dealScheduledCashflow t in - sum $ maybe 0 (CF.mflowBalance . head . view CF.cashflowTxn) <$> scheduleFlowM + Right . toRational $ sum $ maybe 0 (CF.mflowBalance . head . view CF.cashflowTxn) <$> scheduleFlowM FutureCurrentSchedulePoolBegBalance mPns -> let scheduleFlowM = Map.elems $ view dealScheduledCashflow t in - sum $ maybe 0 (CF.mflowBegBalance . head . view CF.cashflowTxn) <$> scheduleFlowM + Right . toRational $ sum $ maybe 0 (CF.mflowBegBalance . head . view CF.cashflowTxn) <$> scheduleFlowM FutureCurrentPoolBegBalance mPns -> let ltc = getLatestCollectFrame t mPns in - sum $ maybe 0 CF.mflowBegBalance <$> ltc + Right . toRational $ sum $ maybe 0 CF.mflowBegBalance <$> ltc PoolCollectionHistory incomeType fromDay asOfDay mPns -> - sum fieldAmts - where - mTxns = Map.elems $ getAllCollectedTxns t mPns - subflow = sliceBy EI fromDay asOfDay $ concat $ fromMaybe [] <$> mTxns - fieldAmts = map (`CF.lookupSource` incomeType) subflow + Right . toRational $ sum fieldAmts + where + mTxns = Map.elems $ getAllCollectedTxns t mPns + subflow = sliceBy EI fromDay asOfDay $ concat $ fromMaybe [] <$> mTxns + fieldAmts = map (`CF.lookupSource` incomeType) subflow CumulativePoolDefaultedBalance mPns -> - let - latestCollect = getLatestCollectFrame t mPns - futureDefaults = sum $ Map.elems $ Map.map (maybe 0 (fromMaybe 0 . CF.tsCumDefaultBal )) $ latestCollect - in - futureDefaults -- `debug` ("future Defaults at"++ show futureDefaults ++ show latestCollect) + let + latestCollect = getLatestCollectFrame t mPns + futureDefaults = sum $ Map.elems $ Map.map (maybe 0 (fromMaybe 0 . CF.tsCumDefaultBal )) $ latestCollect + in + Right . toRational $ futureDefaults -- `debug` ("future Defaults at"++ show futureDefaults ++ show latestCollect) CumulativePoolRecoveriesBalance mPns -> - let - latestCollect = getLatestCollectFrame t mPns - futureRecoveries = sum $ Map.elems $ Map.map (maybe 0 (fromMaybe 0 . CF.tsCumRecoveriesBal)) $ latestCollect - in - futureRecoveries + let + latestCollect = getLatestCollectFrame t mPns + futureRecoveries = sum $ Map.elems $ Map.map (maybe 0 (fromMaybe 0 . CF.tsCumRecoveriesBal)) $ latestCollect + in + Right . toRational $ futureRecoveries CumulativeNetLoss mPns -> - queryDeal t (CumulativePoolDefaultedBalance mPns) - queryDeal t (CumulativePoolRecoveriesBalance mPns) + liftA2 + (-) + (queryCompound t d (CumulativePoolDefaultedBalance mPns)) + (queryCompound t d (CumulativePoolRecoveriesBalance mPns)) PoolCumCollection ps mPns -> - let - collectedTxns = concat . Map.elems $ Map.map (fromMaybe []) $ getAllCollectedTxns t mPns - futureVals = sum $ (CF.lookupSource <$> collectedTxns) <*> ps - - poolStats = Map.elems $ getIssuanceStats t mPns - historyVals = sum $ (Map.findWithDefault 0.0 . poolSourceToIssuanceField <$> ps) <*> poolStats - in - futureVals + historyVals + let + collectedTxns = concat . Map.elems $ Map.map (fromMaybe []) $ getAllCollectedTxns t mPns + futureVals = sum $ (CF.lookupSource <$> collectedTxns) <*> ps + + poolStats = Map.elems $ getIssuanceStats t mPns + historyVals = sum $ (Map.findWithDefault 0.0 . poolSourceToIssuanceField <$> ps) <*> poolStats + in + Right . toRational $ futureVals + historyVals PoolCumCollectionTill idx ps mPns -> - let - txnMap = Map.map (dropLastN (negate idx) . fromMaybe []) $ getAllCollectedTxns t mPns - txnList = concat $ Map.elems txnMap - lookupList = CF.lookupSource <$> txnList - futureVals = sum $ lookupList <*> ps - sumMap = getIssuanceStatsConsol t mPns - historyVals = sum $ Map.findWithDefault 0 . poolSourceToIssuanceField <$> ps <*> [sumMap] - in - futureVals + historyVals - + let + txnMap = Map.map (dropLastN (negate idx) . fromMaybe []) $ getAllCollectedTxns t mPns + txnList = concat $ Map.elems txnMap + lookupList = CF.lookupSource <$> txnList + futureVals = sum $ lookupList <*> ps + sumMap = getIssuanceStatsConsol t mPns + historyVals = sum $ Map.findWithDefault 0 . poolSourceToIssuanceField <$> ps <*> [sumMap] + in + Right . toRational $ futureVals + historyVals + PoolCurCollection ps mPns -> let pCf = getLatestCollectFrame t mPns -- `debug` ("mPns"++ show mPns) lastRows = Map.map (maybe 0 (\r -> sum (CF.lookupSource r <$> ps))) pCf -- `debug` ("Latest collect frame"++ show pCf) in - sum $ Map.elems lastRows -- `debug ` ("lst row found"++ show lastRows) + Right . toRational $ sum $ Map.elems lastRows -- `debug ` ("lst row found"++ show lastRows) PoolCollectionStats idx ps mPns -> let - pCollectedTxns = getAllCollectedTxns t mPns + pCollectedTxns = getAllCollectedTxns t mPns pStat = Map.map (\_x -> - let - lookupIndx = length x + idx - 1 - x = fromMaybe [] _x - in - if (( lookupIndx >= length x ) || (lookupIndx <0)) then - Nothing - else - Just (x!!lookupIndx)) - pCollectedTxns - - curPoolBalM = Map.mapWithKey - (\k v -> - queryDeal t (FutureCurrentPoolBalance (Just [k]))) - pStat - poolStat = Map.mapWithKey - (\k v -> - case v of - Just _v -> sum $ CF.lookupSource _v <$> ps - Nothing -> sum $ CF.lookupSourceM (curPoolBalM Map.! k) Nothing <$> ps - ) - pStat -- `debug` ("query pool current bal" ++ show curPoolBalM ) - in - sum $ Map.elems poolStat -- `debug` ("query pool current stats"++ show poolStat) + let + lookupIndx = length x + idx - 1 + x = fromMaybe [] _x + in + if (( lookupIndx >= length x ) || (lookupIndx <0)) then + Nothing + else + Just (x!!lookupIndx)) + pCollectedTxns -- `debug` ("date"++show d++"Pool collection: "++ show pCollectedTxns) + in + do + curPoolBalM <- sequenceA $ + Map.mapWithKey + (\k v -> queryCompound t d (FutureCurrentPoolBalance (Just [k]))) + pStat -- `debug` ("date"++show d++"Pool stats collection: "++ show pStat) + let poolStat = Map.mapWithKey + (\k v -> + case v of + Just _v -> sum $ CF.lookupSource _v <$> ps + Nothing -> sum $ CF.lookupSourceM (fromRational (curPoolBalM Map.! k)) Nothing <$> ps) + pStat -- `debug` ("date"++show d++"query pool current pool stat 2" ++ show pStat ) + return $ sum $ Map.elems $ toRational <$> poolStat -- `debug` ("query pool current stats"++ show poolStat) FuturePoolScheduleCfPv asOfDay pm mPns -> let pScheduleFlow = view dealScheduledCashflow t - pCfTxns = Map.map (maybe [] CF.getTsCashFlowFrame) $ + pCfTxns = Map.map (maybe [] (view CF.cashflowTxn)) $ case mPns of Nothing -> pScheduleFlow Just pIds -> Map.filterWithKey (\k _ -> S.member k (S.fromList pIds)) pScheduleFlow @@ -324,18 +453,18 @@ queryDeal t@TestDeal{accounts=accMap, bonds=bndMap, fees=feeMap, ledgers=ledgerM txnsCfs = CF.tsTotalCash <$> txns -- `debug` ("schedule cf as of "++ show asOfDay ++ ">>" ++ show txns) txnsDs = getDate <$> txns txnsRates = CF.mflowRate <$> txns - scheduleBal = queryDeal t (FutureCurrentSchedulePoolBegBalance mPns) - curBal = queryDeal t (FutureCurrentPoolBalance mPns) - factor = case scheduleBal of - 0.00 -> 0 - _ -> curBal / scheduleBal -- `debug` ("cur Bal"++show curBal ++">> sheduleBal"++ show scheduleBal) - cfForPv = (factor *) <$> txnsCfs -- `debug` (">>> factor"++ show factor) - pvs = case pm of - PvRate r -> uncurry (A.pv2 r asOfDay) <$> zip txnsDs cfForPv - -- PvByRef ds -> uncurry (A.pv2 (queryCompound t asOfDay ds) asOfDay) <$> zip txnsDs cfForPv - _ -> error $ "Failed to use pricing method on pool" ++ show pm ++"on pool id"++ show mPns - in - sum pvs -- `debug` ("pvs"++ show pvs) + in + do + scheduleBal <- queryCompound t d (FutureCurrentSchedulePoolBegBalance mPns) + curBal <- queryCompound t d (FutureCurrentPoolBalance mPns) + let factor = case scheduleBal of + 0.00 -> 0 + _ -> curBal / scheduleBal -- `debug` ("cur Bal"++show curBal ++">> sheduleBal"++ show scheduleBal) + let cfForPv = (`mulBR` factor) <$> txnsCfs -- `debug` (">>> factor"++ show factor) + let pvs = case pm of + PvRate r -> uncurry (A.pv2 r asOfDay) <$> zip txnsDs cfForPv + -- _ -> Left $ "Date:"++ show asOfDay ++ "Failed to use pricing method on pool" ++ show pm ++"on pool id"++ show mPns + return $ toRational $ sum pvs BondsIntPaidAt d bns -> let @@ -349,7 +478,7 @@ queryDeal t@TestDeal{accounts=accMap, bonds=bndMap, fees=feeMap, ledgers=ledgerM _ -> False) $ filter (\x -> d == getDate x) txns in - sum $ map ex stmts + Right . toRational $ sum $ map ex stmts BondsPrinPaidAt d bns -> let @@ -363,62 +492,66 @@ queryDeal t@TestDeal{accounts=accMap, bonds=bndMap, fees=feeMap, ledgers=ledgerM _ -> False) $ filter (\x -> d == getDate x) txns in - sum $ map ex stmts + Right . toRational $ sum $ map ex stmts FeeTxnAmtBy d fns mCmt -> let fees = (feeMap Map.!) <$> fns -- Map.elems $ getFeeByName t (Just fns) in - case mCmt of - Just cmt -> sum [ queryTxnAmtAsOf fee d cmt | fee <- fees ] - Nothing -> - let - _txn = concat [ getTxns (F.feeStmt fee) | fee <- fees ] - in - sumTxn $ cutBy Inc Past d _txn + Right . toRational $ + case mCmt of + Just cmt -> sum [ queryTxnAmtAsOf fee d cmt | fee <- fees ] + Nothing -> + let + _txn = concat [ getTxns (F.feeStmt fee) | fee <- fees ] + in + sumTxn $ cutBy Inc Past d _txn BondTxnAmtBy d bns mCmt -> let bnds = viewDealBondsByNames t bns in - case mCmt of - Just cmt -> sum [ queryTxnAmtAsOf bnd d cmt | bnd <- bnds ] - Nothing -> - let - _txn = concat [ getTxns (L.bndStmt bnd) | bnd <- bnds ] - in - sumTxn $ cutBy Inc Past d _txn + Right . toRational $ + case mCmt of + Just cmt -> sum [ queryTxnAmtAsOf bnd d cmt | bnd <- bnds ] + Nothing -> + let + _txn = concat [ getTxns (L.bndStmt bnd) | bnd <- bnds ] + in + sumTxn $ cutBy Inc Past d _txn AccTxnAmtBy d ans mCmt -> let accs = (accMap Map.!) <$> ans in - case mCmt of - Just cmt -> sum [ queryTxnAmtAsOf acc d cmt | acc <- accs ] - Nothing -> - let - _txn = concat [ getTxns (A.accStmt acc) | acc <- accs ] - in - sumTxn $ cutBy Inc Past d _txn + Right . toRational $ + case mCmt of + Just cmt -> sum [ queryTxnAmtAsOf acc d cmt | acc <- accs ] + Nothing -> + let + _txn = concat [ getTxns (A.accStmt acc) | acc <- accs ] + in + sumTxn $ cutBy Inc Past d _txn LedgerTxnAmt lns mCmt -> - case ledgerM of - Nothing -> error ("No ledgers were modeled , failed to find ledger:"++show lns ) + case ledgersM of + Nothing -> Left $ ("Date:"++show d++"No ledgers were modeled , failed to find ledger:"++show lns ) Just ledgerm -> let lgs = (ledgerm Map.!) <$> lns in case mCmt of - Just cmt -> sum [ queryTxnAmt lg cmt | lg <- lgs ] - Nothing -> sum [ LD.ledgBalance lg | lg <- lgs ] + Just cmt -> Right . toRational $ sum [ queryTxnAmt lg cmt | lg <- lgs ] + Nothing -> Right . toRational $ sum [ LD.ledgBalance lg | lg <- lgs ] BondBalanceGapAt d bName -> - let - bn@L.Bond{L.bndType = L.PAC _target} = bndMap Map.! bName - bal = L.bndBalance bn - targetBal = getValOnByDate _target d - in - max 0 $ bal - targetBal + toRational <$> + lookupAndApply + (\b@L.Bond{L.bndBalance = bal ,L.bndType = L.PAC _target} + -> max 0 ( bal - getValOnByDate _target d)) + ("Failed to find bond "++ bName) + bName + bndMap FeesPaidAt d fns -> let @@ -428,53 +561,61 @@ queryDeal t@TestDeal{accounts=accMap, bonds=bndMap, fees=feeMap, ledgers=ledgerM Nothing -> 0 Just (Statement txns) -> sum $ getTxnAmt <$> filter (\x -> d == getDate x) txns in - sum $ map ex stmts + Right . toRational $ sum $ map ex stmts CurrentDueBondInt bns -> - sum $ L.bndDueInt <$> viewDealBondsByNames t bns + Right . toRational $ sum $ L.bndDueInt <$> viewDealBondsByNames t bns CurrentDueBondIntOverInt bns -> - sum $ L.bndDueIntOverInt <$> viewDealBondsByNames t bns + Right . toRational $ sum $ L.bndDueIntOverInt <$> viewDealBondsByNames t bns - CurrentDueBondIntTotal bns -> sum (queryDeal t <$> [CurrentDueBondInt bns,CurrentDueBondIntOverInt bns]) + CurrentDueBondIntTotal bns -> + sum <$> sequenceA (queryCompound t d <$> [CurrentDueBondInt bns,CurrentDueBondIntOverInt bns]) - CurrentDueFee fns -> sum $ F.feeDue <$> (feeMap Map.!) <$> fns + CurrentDueFee fns -> + do + vs <- lookupAndApplies F.feeDue "Get Current Due Fee" fns feeMap + return $ toRational (sum vs) LiqCredit lqNames -> case liqProvider t of - Nothing -> 0 - Just liqProviderM -> sum $ [ fromMaybe 0 (CE.liqCredit liq) | (k,liq) <- Map.assocs liqProviderM + Nothing -> Left $ "Date:"++show d++"No Liquidation Provider modeled when looking for " ++ show s + Just liqProviderM -> Right . toRational $ + sum $ [ fromMaybe 0 (CE.liqCredit liq) | (k,liq) <- Map.assocs liqProviderM , S.member k (S.fromList lqNames) ] LiqBalance lqNames -> case liqProvider t of - Nothing -> 0 - Just liqProviderM -> sum $ [ CE.liqBalance liq | (k,liq) <- Map.assocs liqProviderM + Nothing -> Left $ "Date:"++show d++"No Liquidation Provider modeled when looking for " ++ show s + Just liqProviderM -> Right . toRational $ + sum $ [ CE.liqBalance liq | (k,liq) <- Map.assocs liqProviderM , S.member k (S.fromList lqNames) ] RateCapNet rcName -> case rateCap t of - Nothing -> error "No rate cap in the deal" + Nothing -> Left $ "Date:"++show d++"No Rate Cap modeled when looking for " ++ show s Just rm -> case Map.lookup rcName rm of - Nothing -> error $ "No "++ rcName ++" Found in rate cap map with key"++ show (Map.keys rm) - Just rc -> H.rcNetCash rc + Nothing -> Left $ "Date:"++show d++"No Rate Cap modeled when looking for " ++ show s + Just rc -> Right . toRational $ H.rcNetCash rc RateSwapNet rsName -> case rateCap t of - Nothing -> error "No rate swap in the deal" + Nothing -> Left $ "Date:"++show d++"No Rate Swap modeled when looking for " ++ show s Just rm -> case Map.lookup rsName rm of - Nothing -> error $ "No "++ rsName ++" Found in rate swap map with key"++ show (Map.keys rm) - Just rc -> H.rcNetCash rc + Nothing -> Left $ "Date:"++show d++"No Rate Swap modeled when looking for " ++ show s + Just rc -> Right . toRational $ H.rcNetCash rc WeightedAvgCurrentBondBalance d1 d2 bns -> - Map.foldr (\v a-> a + (L.weightAverageBalance d1 d2 v)) -- `debug` (" Avg Bal for bond"++ show (L.weightAverageBalance d1 d2 v)) ) - 0.0 - (getBondsByName t (Just bns)) + Right . toRational $ + Map.foldr (\v a-> a + (L.weightAverageBalance d1 d2 v)) -- `debug` (" Avg Bal for bond"++ show (L.weightAverageBalance d1 d2 v)) ) + 0.0 + (getBondsByName t (Just bns)) WeightedAvgCurrentPoolBalance d1 d2 mPns -> let txnsByPool = getAllCollectedTxns t mPns waBalByPool = Map.map (CF.mflowWeightAverageBalance d1 d2 <$>) txnsByPool in - sum $ fromMaybe 0 <$> Map.elems waBalByPool + Right . toRational $ + sum $ fromMaybe 0 <$> Map.elems waBalByPool WeightedAvgOriginalBondBalance d1 d2 bns -> let @@ -482,142 +623,27 @@ queryDeal t@TestDeal{accounts=accMap, bonds=bndMap, fees=feeMap, ledgers=ledgerM oBals = getOriginBalance <$> bnds bgDates = L.originDate . L.bndOriginInfo <$> bnds -- `debug` ("bals"++show oBals++">>"++ show d1++"-"++show d2) in - sum $ (\(b,sd) -> mulBR b (yearCountFraction DC_ACT_365F (max d1 sd) d2)) <$> (zip oBals bgDates) -- `debug` ("bgDates"++show bgDates) + Right . toRational $ + sum $ (\(b,sd) -> mulBR b (yearCountFraction DC_ACT_365F (max d1 sd) d2)) <$> (zip oBals bgDates) -- `debug` ("bgDates"++show bgDates) WeightedAvgOriginalPoolBalance d1 d2 mPns -> - mulBR - (Map.findWithDefault 0.0 IssuanceBalance (getIssuanceStatsConsol t mPns)) - (yearCountFraction DC_ACT_365F d1 d2) + Right . toRational $ + mulBR + (Map.findWithDefault 0.0 IssuanceBalance (getIssuanceStatsConsol t mPns)) + (yearCountFraction DC_ACT_365F d1 d2) CustomData s d -> case custom t of - Nothing -> 0 + Nothing -> Left $ "Date:"++show d++"No Custom data to query" ++ show s Just mCustom -> - case mCustom Map.! s of - CustomConstant v -> fromRational v - CustomCurve cv -> getValOnByDate cv d - CustomDS ds -> queryDeal t (patchDateToStats d ds ) - - _ -> error ("Failed to query balance of -> "++ show s) + case Map.lookup s mCustom of + Just (CustomConstant v) -> Right . toRational $ v + Just (CustomCurve cv) -> Right . toRational $ getValOnByDate cv d + Just (CustomDS ds) -> queryCompound t d (patchDateToStats d ds ) + _ -> Left $ "Date:"++show d++"Unsupported custom data found for key " ++ show s -queryCompound :: P.Asset a => TestDeal a -> Date -> DealStats -> Either String Rational -queryCompound t@TestDeal{accounts=accMap, bonds=bndMap} d s = - case s of - Sum _s -> sum <$> sequenceA [ queryCompound t d __s | __s <- _s] - Substract dss -> queryCompound t d (Subtract dss) - Subtract (ds:dss) -> - do - a <- queryCompound t d ds - bs <- queryCompound t d (Sum dss) - return $ a - bs - Avg dss -> (/ (toRational (length dss))) <$> (sum <$> sequenceA (queryCompound t d <$> dss )) - Max ss -> maximum' [ queryCompound t d s | s <- ss ] - Min ss -> minimum' [ queryCompound t d s | s <- ss ] - Divide ds1 ds2 -> if (queryCompound t d ds2) == Right 0 then - Left $ "Can not divide zero on ds: "++ show ds2 - else - liftA2 (/) (queryCompound t d ds1) (queryCompound t d ds2) - Factor s f -> (* f) <$> (queryCompound t d s) - FloorAndCap floor cap s -> max (queryCompound t d floor) $ min (queryCompound t d cap) (queryCompound t d s) - Multiply ss -> product <$> sequenceA [ queryCompound t d _s | _s <- ss] - FloorWith s floor -> liftA2 max (queryCompound t d s) (queryCompound t d floor) - FloorWithZero s -> max 0 <$> (queryCompound t d s) - Excess (s1:ss) -> do - q1 <- queryCompound t d s1 - q2 <- queryCompound t d (Sum ss) -- `debug` ("Excess"++show (queryCompound t s1)++"ss"++show ( queryCompound t (Sum ss))) - return (max 0 (q1 -q2)) - CapWith s cap -> min (queryCompound t d s) (queryCompound t d cap) - Abs s -> abs <$> queryCompound t d s - Round ds rb -> do - q <- (queryCompound t d ds) - return $ roundingBy rb q - DivideRatio s1 s2 -> queryCompound t d (Divide s1 s2) - AvgRatio ss -> queryCompound t d (Avg ss) - Constant v -> Right v - -- rate query - BondFactor -> queryCompound t d (Divide CurrentBondBalance OriginalBondBalance) - BondFactorOf bn -> - queryCompound t d (Divide (CurrentBondBalanceOf [bn]) (OriginalBondBalanceOf [bn])) - PoolFactor mPns -> - queryCompound t d (Divide (CurrentPoolBalance mPns) (OriginalPoolBalance mPns)) - FutureCurrentPoolFactor asOfDay mPns -> - queryCompound t d (Divide (FutureCurrentPoolBalance mPns) (OriginalPoolBalance mPns)) - CumulativePoolDefaultedRate mPns -> - queryCompound t d (Divide (PoolCumCollection [NewDefaults] mPns) (OriginalPoolBalance mPns)) - CumulativeNetLossRatio mPns -> - queryCompound t d (Divide (CumulativeNetLoss mPns) (OriginalPoolBalance mPns)) - CumulativePoolDefaultedRateTill idx mPns -> - queryCompound t d (Divide (PoolCumCollectionTill idx [NewDefaults] mPns) (OriginalPoolBalance mPns)) - BondRate bn -> - case Map.lookup bn (bonds t) of - Just b@(L.Bond {}) -> Right . toRational $ L.bndRate b - Just b@(L.BondGroup bSubMap) -> - let - bnds = Map.elems bSubMap - rates = toRational <$> L.bndRate <$> bnds - bals = L.getCurBalance <$> bnds - in - Right $ weightedBy bals rates - Nothing -> - case viewDealBondsByNames t [bn] of - [b] -> Right $ toRational $ L.bndRate b - - BondWaRate bns -> - do - rs <- sequenceA $ (\bn -> queryCompound t d (BondRate bn)) <$> bns - ws <- sequenceA $ (\bn -> queryCompound t d (CurrentBondBalanceOf [bn])) <$> bns - return $ weightedBy (fromRational <$> ws) rs - PoolWaRate mPns -> - let - latestCfs = filter isJust $ Map.elems $ getLatestCollectFrame t mPns - rates = toRational <$> maybe 0.0 CF.mflowRate <$> latestCfs - bals = maybe 0.0 CF.mflowBalance <$> latestCfs - in - Right $ weightedBy bals rates - - -- int query - FutureCurrentPoolBorrowerNum _d mPns -> - let - poolCfs = Map.elems $ getLatestCollectFrame t mPns - poolBn = maybe 0 (\x -> fromMaybe 0 (CF.mflowBorrowerNum x)) <$> poolCfs - in - Right . toRational $ sum poolBn - CurrentPoolBorrowerNum mPns -> - let - assetM = concat $ Map.elems $ getAllAsset t mPns - in - Right . toRational $ sum $ P.getBorrowerNum <$> assetM - MonthsTillMaturity bn -> - let - (L.Bond _ _ (L.OriginalInfo _ _ _ mm) _ _ _ _ _ _ _ _ _ _ _) = bndMap Map.! bn - in - case mm of - Nothing -> Left $ "There is maturity date for bond " ++ bn - Just md -> Right . toRational $ T.cdMonths $ T.diffGregorianDurationClip md d - - ProjCollectPeriodNum -> Right . toRational $ maximum' $ Map.elems $ Map.map (maybe 0 CF.sizeCashFlowFrame) $ getAllCollectedFrame t Nothing - - ReserveBalance ans -> - let - accs::[A.Account] = (accMap Map.!) <$> ans - targetBals::[Either String Balance] = calcTargetAmount t d <$> accs - in - (toRational . sum) <$> sequenceA targetBals - - ReserveExcessAt _d ans -> - do - q1 <- queryCompound t d (AccBalance ans) - q2 <- queryCompound t d (ReserveBalance ans) - return $ max 0 (q1 - q2) - - ReserveGapAt _d ans -> - do - q1 <- queryCompound t d (AccBalance ans) - q2 <- queryCompound t d (ReserveBalance ans) - return $ max 0 (q2 - q1) - - - balanceQ -> Right . toRational $ queryDeal t balanceQ + _ -> Left ("Date:"++show d++"Failed to query formula of -> "++ show s) + @@ -627,24 +653,31 @@ queryDealBool t@TestDeal{triggers= trgs,bonds = bndMap} ds d = TriggersStatus dealcycle tName -> case trgs of Just _trgsM -> case Map.lookup dealcycle _trgsM of - Nothing -> Left ("no trigger cycle for this deal" ++ show dealcycle) + Nothing -> Left ("Date:"++show d++"no trigger cycle for this deal" ++ show dealcycle) Just triggerMatCycle -> case Map.lookup tName triggerMatCycle of - Nothing -> Left ("no trigger for this deal" ++ show tName ++ " in cycle " ++ show triggerMatCycle) + Nothing -> Left ("Date:"++show d++"no trigger for this deal" ++ show tName ++ " in cycle " ++ show triggerMatCycle) Just trigger -> Right $ Trg.trgStatus trigger - Nothing -> Left "no trigger for this deal" + Nothing -> Left $ "Date:"++show d++"no trigger for this deal" IsMostSenior bn bns -> - let - bn1:bns1 = (bndMap Map.!) <$> (bn:bns) - in - case (isPaidOff bn1,all isPaidOff bns1) of - (False,True) -> Right $ True - _ -> Right $ False - - IsPaidOff bns -> Right $ all isPaidOff $ (bndMap Map.!) <$> bns + do + bn1 <- lookupAndApply isPaidOff "Is Most Senior" bn bndMap + bns1 <- lookupAndApplies isPaidOff "Is Most Senior" bns bndMap + return $ + case (bn1, and bns1) of + (False,True) -> True + _ -> False + + IsPaidOff bns -> + do + vs <- lookupAndApplies isPaidOff "Is Paid Off" bns bndMap + return $ and vs - IsOutstanding bns -> Right $ all (not . isPaidOff) $ (bndMap Map.!) <$> bns + IsOutstanding bns -> + do + vs <- lookupAndApplies (not . isPaidOff) "Is Outstanding" bns bndMap + return $ and vs TestRate ds cmp _r -> do testRate <- queryCompound t d ds @@ -656,25 +689,20 @@ queryDealBool t@TestDeal{triggers= trgs,bonds = bndMap} ds d = LE -> testRate <= r E -> testRate == r - HasPassedMaturity bns -> let - oustandingBnds = filter (not . isPaidOff) $ (bndMap Map.!) <$> bns - monthsToMaturity = sequenceA $ (\bn -> queryCompound t d (MonthsTillMaturity bn)) <$> L.bndName <$> oustandingBnds - in - do - ms <- monthsToMaturity - return $ all (<= 0) ms + HasPassedMaturity bns -> do + bMap <- selectInMap "Bond Pass Maturity" bns bndMap + let oustandingBnds = Map.filter (not . isPaidOff) bMap + ms <- sequenceA $ (\bn -> queryCompound t d (MonthsTillMaturity bn)) <$> L.bndName <$> oustandingBnds + return $ all (<= 0) ms IsDealStatus st -> Right $ status t == st - TestNot ds -> do - q <- (queryDealBool t ds d) - return $ not q - + 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 + TestAny b dss -> anyM (\ x -> (== b) <$> queryDealBool t x d ) dss + TestAll b dss -> allM (\ x -> (== b) <$> queryDealBool t x d ) dss - _ -> error ("Failed to query bool type formula"++ show ds) + _ -> Left ("Date:"++show d++"Failed to query bool type formula"++ show ds) -- ^ test a condition with a deal and a date testPre :: P.Asset a => Date -> TestDeal a -> Pre -> Either String Bool diff --git a/src/Deal/DealValidation.hs b/src/Deal/DealValidation.hs index b48457ba..e1182d2a 100644 --- a/src/Deal/DealValidation.hs +++ b/src/Deal/DealValidation.hs @@ -201,9 +201,19 @@ validateAction ((W.LiquidatePool _ accName mPids):as) rs accKeys bndKeys bgNames | isJust mPids && not (Set.isSubsetOf (Set.fromList (fromMaybe [] mPids)) poolKeys) = validateAction as (rs ++ [ErrorMsg (show mPids++" not in "++show poolKeys)]) accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys | otherwise = validateAction as rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys -validateAction ((W.LiqSupport _ liqName _ accName):as) rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys +validateAction ((W.LiqSupport _ liqName CE.LiqToAcc [accName]):as) rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys | Set.notMember accName accKeys || Set.notMember liqName liqProviderKeys - = validateAction as (rs ++ [ErrorMsg (accName++" not in "++show accKeys++" Or "++liqName ++" not in "++ show liqProviderKeys)]) accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys + = validateAction as (rs ++ [ErrorMsg (show accName++" not in "++show accKeys++" Or "++liqName ++" not in "++ show liqProviderKeys)]) accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys + | otherwise = validateAction as rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys + +validateAction ((W.LiqSupport _ liqName CE.LiqToFee feeNames):as) rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys + | not (Set.isSubsetOf (Set.fromList feeNames) feeKeys) || Set.notMember liqName liqProviderKeys + = validateAction as (rs ++ [ErrorMsg (show feeNames++" not in "++show feeKeys++" Or "++liqName ++" not in "++ show liqProviderKeys)]) accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys + | otherwise = validateAction as rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys + +validateAction ((W.LiqSupport _ liqName CE.LiqToBondInt bndNames):as) rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys + | not (Set.isSubsetOf (Set.fromList bndNames) bndKeys) || Set.notMember liqName liqProviderKeys + = validateAction as (rs ++ [ErrorMsg (show bndNames++" not in "++show bndKeys++" Or "++liqName ++" not in "++ show liqProviderKeys)]) accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys | otherwise = validateAction as rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys validateAction ((W.LiqRepay _ _ accName liqName):as) rs accKeys bndKeys bgNames feeKeys liqProviderKeys rateSwapKeys rcKeys ledgerKeys rPoolKeys poolKeys diff --git a/src/Ledger.hs b/src/Ledger.hs index a80bdec6..d46452c8 100644 --- a/src/Ledger.hs +++ b/src/Ledger.hs @@ -2,8 +2,8 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} -module Ledger (Ledger(..),entryLog,LedgerName,queryGap,entryDebit,entryCredit,clearLedgersBySeq - ,queryDirection) +module Ledger (Ledger(..),entryLog,LedgerName,queryGap,clearLedgersBySeq + ,queryDirection,entryLogByDr) where import qualified Data.Time as T import Stmt @@ -26,9 +26,9 @@ debug = flip trace type LedgerName = String data Ledger = Ledger { - ledgName :: String -- ^ ledger account name - ,ledgBalance :: Balance -- ^ current balance of ledger - ,ledgStmt :: Maybe Statement -- ^ ledger transaction history + ledgName :: String -- ^ ledger account name + ,ledgBalance :: Balance -- ^ 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 @@ -44,7 +44,23 @@ entryLog amt d cmt ledg@Ledger{ledgStmt = mStmt, ledgBalance = bal} txn = EntryTxn d newBal amt cmt in ledg { ledgStmt = appendStmt mStmt txn ,ledgBalance = newBal } - where + +-- 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)) + + +hasTxnDirection :: TxnComment -> Bool +hasTxnDirection (TxnDirection _) = True +hasTxnDirection (TxnComments txns) = any (hasTxnDirection) txns +hasTxnDirection _ = False isTxnDirection :: BookDirection -> TxnComment -> Bool @@ -55,22 +71,12 @@ isTxnDirection Debit (TxnComments txns) = any (isTxnDirection Debit) txns isTxnDirection _ _ = False -- ^ credit is negative amount -entryCredit :: Amount -> Date -> TxnComment -> Ledger -> Ledger -entryCredit amt d txn lg@Ledger{ledgName = ln} - | isTxnDirection Credit txn = entryLog (negate amt) d txn lg - | otherwise = undefined $ "Failed to write credit txn to ledger "++ ln ++ " with txn"++ show txn - -entryDebit :: Amount -> Date -> TxnComment -> Ledger -> Ledger -entryDebit amt d txn lg@Ledger{ledgName = ln} - | isTxnDirection Debit txn = entryLog amt d txn lg - | otherwise = undefined $ "Failed to write debit txn to ledger "++ ln ++ " with txn"++ show txn - queryDirection :: Ledger -> (BookDirection ,Balance) queryDirection (Ledger _ bal _) | bal >= 0 = (Debit, bal) | bal < 0 = (Credit, negate bal) --- ^ return ledger's bookable amount with direction input +-- ^ 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 diff --git a/src/Liability.hs b/src/Liability.hs index 4b0c0dc4..2821a5fc 100644 --- a/src/Liability.hs +++ b/src/Liability.hs @@ -12,7 +12,7 @@ module Liability ,weightAverageBalance,calcZspread,payYield,scaleBond,totalDueInt ,buildRateResetDates,isAdjustble,StepUp(..),isStepUp,getDayCountFromInfo ,calcWalBond,patchBondFactor,fundWith,writeOff,InterestOverInterestType(..) - ,getCurBalance,setBondOrigDate + ,getCurBalance,setBondOrigDate,isFloaterBond ,bndOriginInfoLens,bndIntLens,getBeginRate,_Bond,_BondGroup) where @@ -65,6 +65,10 @@ isAdjustble (CapRate r _ ) = isAdjustble r isAdjustble (FloorRate r _ ) = isAdjustble r isAdjustble (WithIoI r _) = isAdjustble r +isFloaterBond :: InterestInfo -> Bool +isFloaterBond Floater {} = True +isFloaterBond _ = False + isStepUp :: Bond -> Bool isStepUp Bond{bndStepUp = Nothing} = False isStepUp _ = True diff --git a/src/Pool.hs b/src/Pool.hs index 2303e842..e3c478d8 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -185,7 +185,7 @@ pricingPoolFlow d pool@Pool{ futureCf = mCollectedCf, issuanceStat = mStat } fut Nothing -> 0 Just collectedCf -> let - collectedTxns = CF.getTsCashFlowFrame collectedCf + collectedTxns = view CF.cashflowTxn collectedCf in if null collectedTxns then 0 @@ -205,7 +205,7 @@ pricingPoolFlow d pool@Pool{ futureCf = mCollectedCf, issuanceStat = mStat } fut PvRate discountRate -> let - futureTxn = CF.getTsCashFlowFrame futureCfUncollected -- `debug` ("PV with cf"++ show d ++ ">>"++show futureCfUncollected) + futureTxn = view CF.cashflowTxn futureCfUncollected -- `debug` ("PV with cf"++ show d ++ ">>"++show futureCfUncollected) futureCfCash = CF.tsTotalCash <$> futureTxn futureDates = getDate <$> futureTxn in diff --git a/src/Reports.hs b/src/Reports.hs index c893cd98..a00f8f09 100644 --- a/src/Reports.hs +++ b/src/Reports.hs @@ -2,6 +2,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} module Reports (patchFinancialReports,getItemBalance,buildBalanceSheet,buildCashReport @@ -16,6 +17,7 @@ import qualified CreditEnhancement as CE import qualified Hedge as HE import qualified Expense as F import qualified Liability as L +import Control.Applicative (liftA3) import Types ( ResultComponent(FinancialReport), CashflowReport(..), @@ -28,7 +30,7 @@ import Types Balance, PoolId (..) ,PoolSource(..)) import Deal.DealBase ( TestDeal(TestDeal, pool, fees, bonds, accounts,liqProvider,rateSwap), getIssuanceStatsConsol, getAllCollectedFrame ,poolTypePool, dealPool) -import Deal.DealQuery ( queryDeal) +import Deal.DealQuery ( queryCompound ) import Deal.DealAction ( calcDueFee, calcDueInt ) import Data.Maybe (fromMaybe) @@ -64,14 +66,32 @@ getItemBalance :: BookItem -> Balance getItemBalance (Item _ bal) = bal getItemBalance (ParentItem _ items) = sum $ getItemBalance <$> items -getPoolBalanceStats :: P.Asset a => TestDeal a -> Maybe PoolId -> (Balance,Balance,Balance) -getPoolBalanceStats t Nothing = (queryDeal t (FutureCurrentPoolBalance Nothing) - ,(queryDeal t (PoolCumCollection [NewDefaults] Nothing)) - ,negate (queryDeal t (PoolCumCollection [CollectedRecoveries] Nothing))) +getPoolBalanceStats :: P.Asset a => TestDeal a -> Date -> Maybe [PoolId] -> Either String [Balance] +getPoolBalanceStats t d mPid + = let + poolStats = [queryCompound t d (FutureCurrentPoolBalance mPid) + ,(queryCompound t d (PoolCumCollection [NewDefaults] mPid)) + ,negate <$> (queryCompound t d (PoolCumCollection [CollectedRecoveries] mPid))] + in + do + poolStats2::[Rational] <- sequenceA poolStats + return $ fromRational <$> poolStats2 + +-- getPoolBalanceStats t d Nothing +-- = sequenceA +-- (queryCompound t d (FutureCurrentPoolBalance Nothing) +-- ,(queryCompound t d (PoolCumCollection [NewDefaults] Nothing)) +-- ,negate (queryCompound t (PoolCumCollection [CollectedRecoveries] Nothing))) +-- +-- getPoolBalanceStats t d (Just pid) = +-- sequenceA +-- (queryCompound t d (FutureCurrentPoolBalance (Just [pid])) +-- ,(queryCompound t d (PoolCumCollection [NewDefaults] (Just [pid]))) +-- ,negate (queryCompound t d (PoolCumCollection [CollectedRecoveries] (Just [pid])))) + + + -getPoolBalanceStats t (Just pid) = (queryDeal t (FutureCurrentPoolBalance (Just [pid])) - ,(queryDeal t (PoolCumCollection [NewDefaults] (Just [pid]))) - ,negate (queryDeal t (PoolCumCollection [CollectedRecoveries] (Just [pid])))) type PoolBalanceSnapshot = (Balance, Balance, Balance) @@ -85,29 +105,16 @@ buildBalanceSheet t@TestDeal{ pool = pool, bonds = bndMap , fees = feeMap , liqP ---- pools mapPoolKey PoolConsol = Nothing - mapPoolKey (PoolName x) = Just (PoolName x) - poolMap = Map.mapKeys mapPoolKey $ view (dealPool . poolTypePool) t - poolAstBalMap = Map.mapWithKey - (\k _ -> getPoolBalanceStats t k) - poolMap + mapPoolKey (PoolName x) = Just [PoolName x] + poolAstBalMap_ = Map.mapWithKey + (\k _ -> getPoolBalanceStats t d (mapPoolKey k)) $ + view (dealPool . poolTypePool) t - poolAstMap = Map.mapWithKey - (\k (a,b,c) -> ParentItem (show (fromMaybe PoolConsol k)) - [ Item "Performing" a - , Item "Defaulted" b - , Item "Recovery" c ]) - poolAstBalMap - poolAst = ParentItem "Pool" $ Map.elems poolAstMap ---- swaps swapToCollect = ParentItem "Swap" [ ParentItem rsName [ Item "To Receive" rsNet ] | (rsName,rsNet) <- Map.toList (Map.map (HE.rsNetCash . (HE.accrueIRS d)) (fromMaybe Map.empty rsMap)) , rsNet > 0 ] - ast = ParentItem "Asset" [ParentItem "Account" accM , poolAst , swapToCollect] - - - -- tranches - - -- expenses - -- liquidity provider + + -- liquidity provider liqProviderAccrued = Map.map (CE.accrueLiqProvider d) (fromMaybe Map.empty liqMap) liqProviderOs = [ ParentItem liqName [Item "Balance" liqBal,Item "Accrue Int" liqDueInt, Item "Due Fee" liqDueFee ] | (liqName,[liqBal,liqDueInt,liqDueFee]) <- Map.toList (Map.map (\liq -> [CE.liqBalance,CE.liqDueInt,CE.liqDuePremium]<*> [liq]) liqProviderAccrued)] -- rate swap @@ -116,6 +123,16 @@ buildBalanceSheet t@TestDeal{ pool = pool, bonds = bndMap , fees = feeMap , liqP in do + poolAstBalMap <- sequenceA poolAstBalMap_ + let poolAstMap = Map.mapWithKey + (\k vs -> ParentItem (show k) + [ Item "Performing" (vs!!0) + , Item "Defaulted" (vs!!1) + , Item "Recovery" (vs!!2) ]) + poolAstBalMap + let poolAst = ParentItem "Pool" $ Map.elems poolAstMap + + let ast = ParentItem "Asset" [ParentItem "Account" accM , poolAst , swapToCollect] feeWithDueAmount <- (F.feeDue <$>) <$> mapM ((calcDueFee t d)) feeMap let feeToPay = ParentItem "Fee" [ ParentItem feeName [Item "Due" feeDueBal] | (feeName,feeDueBal) <- Map.toList feeWithDueAmount ] diff --git a/src/Stmt.hs b/src/Stmt.hs index 328edf64..9f785066 100644 --- a/src/Stmt.hs +++ b/src/Stmt.hs @@ -245,6 +245,7 @@ getFlow comment = PurchaseAsset _ _-> Outflow IssuanceProceeds _ -> Inflow TxnDirection _ -> Noneflow + BookLedgerBy _ _ -> Noneflow TxnComments cmts -> --TODO the direction of combine txns let directionList = getFlow <$> cmts diff --git a/src/Types.hs b/src/Types.hs index 4333f7b5..2a90e7b1 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -30,7 +30,7 @@ module Types ,PricingMethod(..),CustomDataType(..),ResultComponent(..),DealStatType(..) ,ActionWhen(..) ,getDealStatType,getPriceValue,preHasTrigger - ,MyRatio + ,MyRatio,HowToPay(..) ) where @@ -444,6 +444,7 @@ data TxnComment = PayInt [BondName] | PayFeeYield FeeName | Transfer AccName AccName | TransferBy AccName AccName Limit + | BookLedgerBy BookDirection String | PoolInflow (Maybe [PoolId]) PoolSource | LiquidationProceeds [PoolId] | LiquidationSupport String @@ -494,6 +495,7 @@ data DealStats = CurrentBondBalance | AllAccBalance | AccBalance [AccName] | LedgerBalance [String] + | LedgerBalanceBy BookDirection [String] | LedgerTxnAmt [String] (Maybe TxnComment) | ReserveBalance [AccName] | ReserveGap [AccName] @@ -604,15 +606,20 @@ data Limit = DuePct Rate -- ^ up to % of total amount due | DueCapAmt Balance -- ^ up to $ amount | KeepBalAmt DealStats -- ^ pay till a certain amount remains in an account | DS DealStats -- ^ transfer with limit described by a `DealStats` - | ClearLedger BookDirection String -- ^ when transfer, clear the ledger by transfer amount - | ClearLedgerBySeq BookDirection [String] -- ^ clear a direction to a sequence of ledgers - | BookLedger String -- ^ when transfer, book the ledger by the transfer amount + -- | ClearLedger BookDirection String -- ^ when transfer, clear the ledger by transfer amount + -- | ClearLedgerBySeq BookDirection [String] -- ^ clear a direction to a sequence of ledgers + -- | BookLedger String -- ^ when transfer, book the ledger by the transfer amount | RemainBalPct Rate -- ^ pay till remain balance equals to a percentage of `stats` | TillTarget -- ^ transfer amount which make target account up reach reserve balanace | TillSource -- ^ transfer amount out till source account down back to reserve balance | Multiple Limit Float -- ^ factor of a limit deriving (Show,Ord,Eq,Read, Generic) +data HowToPay = ByProRata + | BySequential + deriving (Show,Ord,Eq,Read, Generic) + + type BookItems = [BookItem] data BookItem = Item String Balance @@ -792,15 +799,15 @@ data ActionWhen = EndOfPoolCollection -- ^ waterfall executed at the deriving (Show,Ord,Eq,Generic,Read) -data ResultComponent = CallAt Date -- ^ the date when deal called - | DealStatusChangeTo Date DealStatus DealStatus -- ^ record when status changed - | BondOutstanding String Balance Balance -- ^ when deal ends,calculate oustanding principal balance - | BondOutstandingInt String Balance Balance -- ^ when deal ends,calculate oustanding interest due - | InspectBal Date DealStats Balance -- ^ A bal value from inspection - | InspectInt Date DealStats Int -- ^ A int value from inspection - | InspectRate Date DealStats Micro -- ^ A rate value from inspection - | InspectBool Date DealStats Bool -- ^ A bool value from inspection - | RunningWaterfall Date ActionWhen -- ^ running waterfall at a date +data ResultComponent = CallAt Date -- ^ the date when deal called + | DealStatusChangeTo Date DealStatus DealStatus String -- ^ record when & why status changed + | BondOutstanding String Balance Balance -- ^ when deal ends,calculate oustanding principal balance + | BondOutstandingInt String Balance Balance -- ^ when deal ends,calculate oustanding interest due + | InspectBal Date DealStats Balance -- ^ A bal value from inspection + | InspectInt Date DealStats Int -- ^ A int value from inspection + | InspectRate Date DealStats Micro -- ^ A rate value from inspection + | InspectBool Date DealStats Bool -- ^ A bool value from inspection + | RunningWaterfall Date ActionWhen -- ^ running waterfall at a date | FinancialReport StartDate EndDate BalanceSheetReport CashflowReport | InspectWaterfall Date (Maybe String) [DealStats] [String] | ErrorMsg String @@ -845,6 +852,7 @@ instance ToJSON TxnComment where toJSON (TxnComments tcms) = Array $ V.fromList $ map toJSON tcms toJSON (PayGroupInt bns) = String $ T.pack $ "" toJSON (PayGroupPrin bns) = String $ T.pack $ "" + toJSON (BookLedgerBy dr lName) = String $ T.pack $ "" toJSON x = error $ "Not support for toJSON for "++show x instance FromJSON TxnComment where @@ -973,7 +981,7 @@ data CustomDataType = CustomConstant Rational $(deriveJSON defaultOptions ''DealStatus) $(deriveJSON defaultOptions ''CutoffType) -$(concat <$> traverse (deriveJSON defaultOptions) [''DealStats, ''PricingMethod, ''DealCycle, ''DateType, ''Period, +$(concat <$> traverse (deriveJSON defaultOptions) [''BookDirection, ''DealStats, ''PricingMethod, ''DealCycle, ''DateType, ''Period, ''DatePattern, ''Table, ''BalanceSheetReport, ''BookItem, ''CashflowReport, ''Txn] ) @@ -1004,6 +1012,7 @@ $(deriveJSON defaultOptions ''ResultComponent) $(deriveJSON defaultOptions ''PriceResult) $(deriveJSON defaultOptions ''CutoffFields) +$(deriveJSON defaultOptions ''HowToPay) @@ -1052,7 +1061,6 @@ instance FromJSONKey Threshold where $(deriveJSON defaultOptions ''RateAssumption) -$(deriveJSON defaultOptions ''BookDirection) $(deriveJSON defaultOptions ''Direction) $(concat <$> traverse (deriveJSON defaultOptions) [''Limit] ) diff --git a/src/Util.hs b/src/Util.hs index e7643594..d07328f1 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -12,6 +12,8 @@ module Util ,floorWith,slice,toPeriodRateByInterval, dropLastN, zipBalTs ,lastOf,findBox,safeDivide', safeDiv ,safeDivide,lstToMapByFn,paySequentially,payProRata,mapWithinMap + ,payInMap,adjustM,lookupAndApply,lookupAndUpdate,lookupAndApplies + ,lookupInMap,selectInMap -- for debug ,zyj ) @@ -348,7 +350,7 @@ paySequentially :: Date -> Amount -> (a->Balance) -> (Amount->a->a) -> [a] -> [a paySequentially d amt getDueAmt payFn paidList [] = (reverse paidList, amt) paySequentially d 0 getDueAmt payFn paidList tobePaidList - = (reverse (paidList++tobePaidList), 0) + = (reverse paidList++tobePaidList, 0) paySequentially d amt getDueAmt payFn paidList (l:tobePaidList) = let dueAmt = getDueAmt l @@ -372,9 +374,59 @@ payProRata d amt getDueAmt payFn tobePaidList in (paidList, remainAmt) +payInMap :: Date -> Amount -> (a->Balance) -> (Amount->a->a)-> [String] + -> HowToPay -> Map.Map String a -> Map.Map String a +payInMap d amt getDueFn payFn objNames how inputMap + = let + objsToPay = (inputMap Map.!) <$> objNames + dueAmts = getDueFn <$> objsToPay + totalDueAmt = sum dueAmts + actualPaidOut = min totalDueAmt amt + allocatedPayAmt = case how of + ByProRata -> prorataFactors dueAmts actualPaidOut + BySequential -> paySeqLiabilitiesAmt amt dueAmts + paidObjs = [ payFn amt l | (amt,l) <- zip allocatedPayAmt objsToPay ] + in + (Map.fromList $ zip objNames paidObjs) <> inputMap + mapWithinMap :: Ord k => (a -> a) -> [k] -> Map.Map k a -> Map.Map k a mapWithinMap fn ks m = foldr (Map.adjust fn) m ks + +adjustM :: (Ord k, Applicative m) => (a -> m a) -> k -> Map.Map k a -> m (Map.Map k a) +adjustM f = Map.alterF (traverse f) + + +lookupAndApply :: Ord k => (a -> b) -> String -> k -> Map.Map k a -> Either String b +lookupAndApply f errMsg key m = + case Map.lookup key m of + Nothing -> Left errMsg + Just a -> Right $ f a + +lookupAndApplies :: Ord k => (a -> b) -> String -> [k] -> Map.Map k a -> Either String [b] +lookupAndApplies f errMsg keys m + = sequenceA $ (\x -> lookupAndApply f errMsg x m) <$> keys + +lookupAndUpdate :: (Show k, Ord k) => (a -> a) -> String -> [k] -> Map.Map k a -> Either String (Map.Map k a) +lookupAndUpdate f errMsg keys m + | S.isSubsetOf inputKs mapKs = Right $ mapWithinMap f keys m + | otherwise = Left $ errMsg++":Missing keys, valid range "++ show mapKs ++ "But got:" ++ show inputKs + where + inputKs = S.fromList keys + mapKs = Map.keysSet m + +lookupInMap :: (Show k, Ord k) => String -> [k] -> Map.Map k a -> Either String (Map.Map k a) +lookupInMap = lookupAndUpdate id + + +selectInMap :: (Show k, Ord k) => String -> [k] -> Map.Map k a -> Either String (Map.Map k a) +selectInMap errMsg keys m + | S.isSubsetOf inputKs mapKs = Right $ (Map.filterWithKey (\k _ -> S.member k inputKs) m) + | otherwise = Left $ errMsg++":Missing keys, valid range "++ show mapKs ++ "But got:" ++ show inputKs + where + inputKs = S.fromList keys + mapKs = Map.keysSet m + ----- DEBUG/PRINT -- z y j : stands for chinese Zhao Yao Jing ,which is a mirror reveals the devil zyj :: Show a => Maybe String -> [a] -> String diff --git a/src/Waterfall.hs b/src/Waterfall.hs index 7eca34ec..321b746b 100644 --- a/src/Waterfall.hs +++ b/src/Waterfall.hs @@ -32,7 +32,7 @@ import Ledger (Ledger,LedgerName) -data BookType = PDL DealStats [(LedgerName,DealStats)] -- Reverse PDL Debit reference, [(name,cap reference)] +data BookType = PDL BookDirection DealStats [(LedgerName,DealStats)] -- Reverse PDL Debit reference, [(name,cap reference)] | ByAccountDraw LedgerName -- Book amount equal to account draw amount | ByDS LedgerName BookDirection DealStats -- Book amount equal to a formula/deal stats deriving (Show,Generic,Eq,Ord) @@ -51,10 +51,13 @@ data PayOrderBy = ByName -- | InverseSeq PayOrderBy deriving (Show,Generic,Eq,Ord) +type BookLedger = (BookDirection, LedgerName) +type BookLedgers = (BookDirection, [LedgerName]) data Action = -- Accounts Transfer (Maybe Limit) AccountName AccountName (Maybe TxnComment) + | TransferAndBook (Maybe Limit) AccountName AccountName BookLedger (Maybe TxnComment) | TransferMultiple [(Maybe Limit, AccountName)] AccountName (Maybe TxnComment) -- Fee | CalcFee [FeeName] -- ^ calculate fee due amount in the fee names @@ -88,7 +91,9 @@ data Action = | AccrueAndPayIntGroup (Maybe Limit) AccountName BondName PayOrderBy (Maybe ExtraSupport) -- Bond - Balance | WriteOff (Maybe Limit) BondName + | WriteOffAndBook (Maybe Limit) BondName BookLedger | WriteOffBySeq (Maybe Limit) [BondName] + | WriteOffBySeqAndBook (Maybe Limit) [BondName] BookLedger | FundWith (Maybe Limit) AccountName BondName -- ^ extra more funds from bond and deposit cash to account -- Pool/Asset change | BuyAsset (Maybe Limit) PricingMethod AccountName (Maybe PoolId) -- ^ buy asset from revolving assumptions using funds from account @@ -96,7 +101,7 @@ data Action = | LiquidatePool PricingMethod AccountName (Maybe [PoolId]) -- ^ sell all assets and deposit proceeds to account -- TODO include a limit for LIquidatePool -- Liquidation support - | LiqSupport (Maybe Limit) CE.LiquidityProviderName CE.LiqDrawType AccountName -- ^ draw credit and deposit to account/fee/bond interest/principal + | LiqSupport (Maybe Limit) CE.LiquidityProviderName CE.LiqDrawType [String] -- ^ draw credit and deposit to account/fee/bond interest/principal | LiqRepay (Maybe Limit) CE.LiqRepayType AccountName CE.LiquidityProviderName -- ^ repay liquidity facility | LiqYield (Maybe Limit) AccountName CE.LiquidityProviderName -- ^ repay compensation to liquidity facility | LiqAccrue [CE.LiquidityProviderName] -- ^ accure premium/due interest of liquidity facility @@ -115,8 +120,9 @@ data Action = -- Trigger | RunTrigger DealCycle [String] -- ^ update the trigger status during the waterfall execution -- Debug - | WatchVal (Maybe String) [DealStats] -- ^ inspect vals during the waterfall execution + | WatchVal (Maybe String) [DealStats] -- ^ inspect vals during the waterfall execution | Placeholder (Maybe String) + | ChangeStatus (Maybe Pre) DealStatus -- change deal status deriving (Show,Generic,Eq,Ord) type DistributionSeq = [Action] diff --git a/swagger.json b/swagger.json index a43ea074..5ef87b63 100644 --- a/swagger.json +++ b/swagger.json @@ -126,6 +126,54 @@ "title": "Transfer", "type": "object" }, + { + "properties": { + "contents": { + "items": [ + { + "$ref": "#/components/schemas/Limit" + }, + { + "type": "string" + }, + { + "type": "string" + }, + { + "items": [ + { + "$ref": "#/components/schemas/BookDirection" + }, + { + "type": "string" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + }, + { + "$ref": "#/components/schemas/TxnComment" + } + ], + "maxItems": 5, + "minItems": 5, + "type": "array" + }, + "tag": { + "enum": [ + "TransferAndBook" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "TransferAndBook", + "type": "object" + }, { "properties": { "contents": { @@ -1088,6 +1136,48 @@ "title": "WriteOff", "type": "object" }, + { + "properties": { + "contents": { + "items": [ + { + "$ref": "#/components/schemas/Limit" + }, + { + "type": "string" + }, + { + "items": [ + { + "$ref": "#/components/schemas/BookDirection" + }, + { + "type": "string" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + } + ], + "maxItems": 3, + "minItems": 3, + "type": "array" + }, + "tag": { + "enum": [ + "WriteOffAndBook" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "WriteOffAndBook", + "type": "object" + }, { "properties": { "contents": { @@ -1120,6 +1210,51 @@ "title": "WriteOffBySeq", "type": "object" }, + { + "properties": { + "contents": { + "items": [ + { + "$ref": "#/components/schemas/Limit" + }, + { + "items": { + "type": "string" + }, + "type": "array" + }, + { + "items": [ + { + "$ref": "#/components/schemas/BookDirection" + }, + { + "type": "string" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + } + ], + "maxItems": 3, + "minItems": 3, + "type": "array" + }, + "tag": { + "enum": [ + "WriteOffBySeqAndBook" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "WriteOffBySeqAndBook", + "type": "object" + }, { "properties": { "contents": { @@ -1274,7 +1409,10 @@ "$ref": "#/components/schemas/LiqDrawType" }, { - "type": "string" + "items": { + "type": "string" + }, + "type": "array" } ], "maxItems": 4, @@ -1671,6 +1809,54 @@ ], "title": "WatchVal", "type": "object" + }, + { + "properties": { + "contents": { + "type": "string" + }, + "tag": { + "enum": [ + "Placeholder" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "Placeholder", + "type": "object" + }, + { + "properties": { + "contents": { + "items": [ + { + "$ref": "#/components/schemas/Pre" + }, + { + "$ref": "#/components/schemas/DealStatus" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + }, + "tag": { + "enum": [ + "ChangeStatus" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "ChangeStatus", + "type": "object" } ] }, @@ -4240,6 +4426,9 @@ "properties": { "contents": { "items": [ + { + "$ref": "#/components/schemas/BookDirection" + }, { "$ref": "#/components/schemas/DealStats" }, @@ -4260,8 +4449,8 @@ "type": "array" } ], - "maxItems": 2, - "minItems": 2, + "maxItems": 3, + "minItems": 3, "type": "array" }, "tag": { @@ -6227,6 +6416,38 @@ "title": "LedgerBalance", "type": "object" }, + { + "properties": { + "contents": { + "items": [ + { + "$ref": "#/components/schemas/BookDirection" + }, + { + "items": { + "type": "string" + }, + "type": "array" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + }, + "tag": { + "enum": [ + "LedgerBalanceBy" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "LedgerBalanceBy", + "type": "object" + }, { "properties": { "contents": { @@ -10556,86 +10777,6 @@ "title": "DS", "type": "object" }, - { - "properties": { - "contents": { - "items": [ - { - "$ref": "#/components/schemas/BookDirection" - }, - { - "type": "string" - } - ], - "maxItems": 2, - "minItems": 2, - "type": "array" - }, - "tag": { - "enum": [ - "ClearLedger" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "ClearLedger", - "type": "object" - }, - { - "properties": { - "contents": { - "items": [ - { - "$ref": "#/components/schemas/BookDirection" - }, - { - "items": { - "type": "string" - }, - "type": "array" - } - ], - "maxItems": 2, - "minItems": 2, - "type": "array" - }, - "tag": { - "enum": [ - "ClearLedgerBySeq" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "ClearLedgerBySeq", - "type": "object" - }, - { - "properties": { - "contents": { - "type": "string" - }, - "tag": { - "enum": [ - "BookLedger" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "BookLedger", - "type": "object" - }, { "properties": { "contents": { @@ -11796,25 +11937,6 @@ }, "PoolType_AssetUnion": { "oneOf": [ - { - "properties": { - "contents": { - "$ref": "#/components/schemas/Pool_AssetUnion" - }, - "tag": { - "enum": [ - "SoloPool" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "SoloPool", - "type": "object" - }, { "properties": { "contents": { @@ -11863,25 +11985,6 @@ }, "PoolType_FixedAsset": { "oneOf": [ - { - "properties": { - "contents": { - "$ref": "#/components/schemas/Pool_FixedAsset" - }, - "tag": { - "enum": [ - "SoloPool" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "SoloPool", - "type": "object" - }, { "properties": { "contents": { @@ -11930,25 +12033,6 @@ }, "PoolType_Installment": { "oneOf": [ - { - "properties": { - "contents": { - "$ref": "#/components/schemas/Pool_Installment" - }, - "tag": { - "enum": [ - "SoloPool" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "SoloPool", - "type": "object" - }, { "properties": { "contents": { @@ -11997,25 +12081,6 @@ }, "PoolType_Lease": { "oneOf": [ - { - "properties": { - "contents": { - "$ref": "#/components/schemas/Pool_Lease" - }, - "tag": { - "enum": [ - "SoloPool" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "SoloPool", - "type": "object" - }, { "properties": { "contents": { @@ -12064,25 +12129,6 @@ }, "PoolType_Loan": { "oneOf": [ - { - "properties": { - "contents": { - "$ref": "#/components/schemas/Pool_Loan" - }, - "tag": { - "enum": [ - "SoloPool" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "SoloPool", - "type": "object" - }, { "properties": { "contents": { @@ -12131,25 +12177,6 @@ }, "PoolType_Mortgage": { "oneOf": [ - { - "properties": { - "contents": { - "$ref": "#/components/schemas/Pool_Mortgage" - }, - "tag": { - "enum": [ - "SoloPool" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "SoloPool", - "type": "object" - }, { "properties": { "contents": { @@ -12198,25 +12225,6 @@ }, "PoolType_ProjectedCashflow": { "oneOf": [ - { - "properties": { - "contents": { - "$ref": "#/components/schemas/Pool_ProjectedCashflow" - }, - "tag": { - "enum": [ - "SoloPool" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "SoloPool", - "type": "object" - }, { "properties": { "contents": { @@ -12265,25 +12273,6 @@ }, "PoolType_Receivable": { "oneOf": [ - { - "properties": { - "contents": { - "$ref": "#/components/schemas/Pool_Receivable" - }, - "tag": { - "enum": [ - "SoloPool" - ], - "type": "string" - } - }, - "required": [ - "tag", - "contents" - ], - "title": "SoloPool", - "type": "object" - }, { "properties": { "contents": { @@ -14815,10 +14804,13 @@ }, { "$ref": "#/components/schemas/DealStatus" + }, + { + "type": "string" } ], - "maxItems": 3, - "minItems": 3, + "maxItems": 4, + "minItems": 4, "type": "array" }, "tag": { @@ -18685,6 +18677,35 @@ "title": "TransferBy", "type": "object" }, + { + "properties": { + "contents": { + "items": [ + { + "$ref": "#/components/schemas/BookDirection" + }, + { + "type": "string" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + }, + "tag": { + "enum": [ + "BookLedgerBy" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "BookLedgerBy", + "type": "object" + }, { "properties": { "contents": { @@ -19254,7 +19275,7 @@ "name": "BSD 3" }, "title": "Hastructure API", - "version": "0.31.2" + "version": "0.40.10" }, "openapi": "3.0.0", "paths": { diff --git a/test/DealTest/DealTest.hs b/test/DealTest/DealTest.hs index f9774a07..6132c4c9 100644 --- a/test/DealTest/DealTest.hs +++ b/test/DealTest/DealTest.hs @@ -48,7 +48,7 @@ emptyCase = D.TestDeal { ,D.accounts = Map.empty ,D.fees = Map.empty ,D.bonds = Map.empty - ,D.pool = D.SoloPool (P.Pool {P.assets=[]}) + ,D.pool = D.MultiPool $ Map.fromList [(PoolConsol, (P.Pool {P.assets=[]}))] ,D.waterfall = Map.empty ,D.collects = [] } @@ -87,7 +87,8 @@ baseCase = D.TestDeal { ,L.bndStmt=Nothing}) ] ) - ,D.pool = D.SoloPool (P.Pool {P.assets=[AB.Mortgage + ,D.pool = D.MultiPool $ + (Map.fromList [(PoolConsol, (P.Pool {P.assets=[AB.Mortgage AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 @@ -104,7 +105,7 @@ baseCase = D.TestDeal { ,P.futureCf=Just (CF.CashFlowFrame dummySt []) ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Nothing - ,P.extendPeriods = Nothing}) + ,P.extendPeriods = Nothing}))]) ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) diff --git a/test/DealTest/ResecDealTest.hs b/test/DealTest/ResecDealTest.hs index a43a7218..2fa0c645 100644 --- a/test/DealTest/ResecDealTest.hs +++ b/test/DealTest/ResecDealTest.hs @@ -68,7 +68,7 @@ baseCase = D.TestDeal { ,L.bndStmt=Nothing}) ] ) - ,D.pool = D.SoloPool (P.Pool {P.assets=[AB.Mortgage + ,D.pool = D.MultiPool (Map.fromList [(PoolConsol, (P.Pool {P.assets=[AB.Mortgage AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 @@ -85,7 +85,7 @@ baseCase = D.TestDeal { ,P.futureCf=Just (CF.CashFlowFrame dummySt []) ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Nothing - ,P.extendPeriods = Nothing}) + ,P.extendPeriods = Nothing}))]) ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) @@ -136,4 +136,4 @@ resecDeal = D.TestDeal { ])] ,D.collects = [W.Collect Nothing W.CollectedInterest "General" ,W.Collect Nothing W.CollectedPrincipal "General"] -} \ No newline at end of file +} diff --git a/test/MainTest.hs b/test/MainTest.hs index 23481371..757d310d 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -64,6 +64,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,BT.bndConsolTest ,LT.curveTests ,LT.pvTests + ,LT.seqFunTest -- --,LT.queryStmtTests ,LT.datesTests ,LT.prorataTests @@ -73,6 +74,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,DT.triggerTests ,DT.dateTests ,DT.liqProviderTest + ,DT.poolFlowTest ,DT2.queryTests ,UtilT.daycountTests1 ,UtilT.daycountTests2 diff --git a/test/UT/AccountTest.hs b/test/UT/AccountTest.hs index 8275683b..94661491 100644 --- a/test/UT/AccountTest.hs +++ b/test/UT/AccountTest.hs @@ -14,6 +14,11 @@ import Deal.DealQuery (queryCompound) import Deal.DealBase import qualified Cashflow as CF +import qualified Pool as P +import Control.Lens hiding (element,Empty) +import Control.Lens.TH +import Data.Map.Lens + import qualified Data.Time as T import qualified Data.Map as Map import UT.DealTest (td2) @@ -80,7 +85,7 @@ reserveAccTest = ,CF.MortgageFlow (toDate "20220801") 110 20 10 0 0 0 0 0 Nothing Nothing Nothing ,CF.MortgageFlow (toDate "20220901") 90 20 10 0 0 0 0 0 Nothing Nothing Nothing ,CF.MortgageFlow (toDate "20221001") 70 20 10 0 0 0 0 0 Nothing Nothing Nothing] - ttd = (setFutureCF td2 testCFs) {accounts = accMap} + ttd = set (dealPool . poolTypePool . (ix PoolConsol) . P.poolFutureCf) (Just testCFs) td2 {accounts = accMap} in testGroup "Test On Reserve Acc" [ @@ -94,12 +99,12 @@ reserveAccTest = (calcTargetAmount ttd (toDate "20220801") acc2) ,testCase "test on reserve account gap" $ assertEqual "pct reserve gap " - (Right 0) - (queryCompound ttd (toDate "20220826") (ReserveGapAt (toDate "20220826") ["A1"])) + (Right 0) + (queryCompound ttd (toDate "20220826") (ReserveGapAt (toDate "20220826") ["A1"])) ,testCase "test on reserve account gap" $ assertEqual "fix reserve gap " - (Right 60) - (queryCompound ttd (toDate "20220801") (ReserveGapAt (toDate "20220801") ["A2"])) + (Right 60) + (queryCompound ttd (toDate "20220801") (ReserveGapAt (toDate "20220801") ["A2"])) ] diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index 083e8722..5ecf9bff 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -24,7 +24,8 @@ import InterestRate import Debug.Trace import qualified Assumptions as A -import qualified Assumptions as A +import Control.Lens hiding (element) +import Control.Lens.TH debug = flip trace dummySt = (0,L.toDate "19000101",Nothing) @@ -79,7 +80,7 @@ asOfDate = L.toDate "20210605" (tmcf_00,_) = case Ast.projCashflow tm asOfDate (A.MortgageAssump Nothing Nothing Nothing Nothing,A.DummyDelinqAssump,A.DummyDefaultAssump) Nothing of Left _ -> undefined Right x -> x -trs = CF.getTsCashFlowFrame tmcf_00 +trs = tmcf_00^.CF.cashflowTxn (tmcf_default,_) = case Ast.projCashflow tm asOfDate (A.MortgageAssump (Just (A.DefaultConstant 0.015)) Nothing Nothing Nothing ,A.DummyDelinqAssump,A.DummyDefaultAssump) Nothing of Left _ -> undefined Right x -> x @@ -111,7 +112,7 @@ mortgageTests = testGroup "Mortgage cashflow Tests" tm1cf_00 = case Ast.calcCashflow tm1 asOfDate Nothing of Left _ -> undefined Right x -> x - trs = CF.getTsCashFlowFrame tm1cf_00 + trs = tm1cf_00 ^. CF.cashflowTxn in assertEqual "first row" 12.63 (CF.mflowPrincipal (head trs)) -- `debug` ("result"++show(tmcf_00)) , @@ -121,7 +122,7 @@ mortgageTests = testGroup "Mortgage cashflow Tests" (tm2cf_00, _) = case Ast.projCashflow tm2 asDay (A.MortgageAssump Nothing Nothing Nothing Nothing ,A.DummyDelinqAssump,A.DummyDefaultAssump) Nothing of Left _ -> undefined Right x -> x - trs = CF.getTsCashFlowFrame tm2cf_00 + trs = tm2cf_00 ^. CF.cashflowTxn in assertEqual "Empty for principal" (0.0, asDay, 1) @@ -134,7 +135,7 @@ mortgageTests = testGroup "Mortgage cashflow Tests" tm1cf_00 = case Ast.calcCashflow tm4 asOfDate Nothing of-- `debug` (">>>") Left _ -> undefined Right x -> x - trs = CF.getTsCashFlowFrame tm1cf_00 + trs = tm1cf_00 ^. CF.cashflowTxn in assertEqual "first & last row row" [94.29,0.62,0.66, 0.79] @@ -148,7 +149,7 @@ mortgageTests = testGroup "Mortgage cashflow Tests" tm1cf_00 = case Ast.calcCashflow tm5 asOfDate Nothing of Left _ -> undefined Right x -> x - trs = CF.getTsCashFlowFrame tm1cf_00 + trs = tm1cf_00 ^. CF.cashflowTxn in assertEqual "first & last row row" [84.19,0.56,0.64, 0.66] @@ -162,7 +163,7 @@ mortgageTests = testGroup "Mortgage cashflow Tests" (A.MortgageAssump Nothing (Just (A.PrepaymentCPR 0.1)) Nothing Nothing ,A.DummyDelinqAssump,A.DummyDefaultAssump) Nothing of Left _ -> undefined Right x -> x - trs = CF.getTsCashFlowFrame tm1cf_00 + trs = tm1cf_00 ^. CF.cashflowTxn in assertEqual "first & last row row" [68.77, 0.45, 1.06, 0.65, 0.79] @@ -177,7 +178,7 @@ mortgageTests = testGroup "Mortgage cashflow Tests" (A.MortgageAssump Nothing (Just (A.PrepaymentCPR 0.1)) Nothing Nothing ,A.DummyDelinqAssump,A.DummyDefaultAssump) Nothing of Left _ -> undefined Right x -> x - trs = CF.getTsCashFlowFrame tm1cf_00 + trs = tm1cf_00 ^. CF.cashflowTxn in assertEqual "first & last row row" ([82, 0.73, 0.54, 1.06, 0.75, 0.79], 25) @@ -194,7 +195,7 @@ mortgageTests = testGroup "Mortgage cashflow Tests" (A.MortgageAssump (Just (A.DefaultAtEndByRate 0.05 0.1)) Nothing Nothing Nothing ,A.DummyDelinqAssump,A.DummyDefaultAssump) Nothing of Left _ -> undefined Right x -> x - trs = CF.getTsCashFlowFrame tm1cf_00 + trs = tm1cf_00 ^. CF.cashflowTxn in assertEqual "first & last row row" ([74.34, 17.43, 0.49, 0.52, 0.76, 0.79], 25) @@ -320,7 +321,7 @@ leaseTests = testCase "1 year Regular Lease sum of rentals" $ assertEqual "total rental" 214 - (sum $ map CF.tsTotalCash (CF.getTsCashFlowFrame cf1)) -- `debug` ("regular test"++show cf1) + (sum $ map CF.tsTotalCash (cf1 ^. CF.cashflowTxn)) -- `debug` ("regular test"++show cf1) ,testCase "1 year Regular Lease first pay date" $ assertEqual "first date of regular lease" (L.toDate "20230630") @@ -328,39 +329,39 @@ leaseTests = ,testCase "1 year Stepup lease first pay" $ assertEqual "first pay" (CF.LeaseFlow (L.toDate "20230630") 377.76 29) - (head (CF.getTsCashFlowFrame cf2)) + (head (cf2 ^. CF.cashflowTxn)) ,testCase "1 year Stepup lease" $ assertEqual "total rental" 406.76 - (sum $ map CF.tsTotalCash (CF.getTsCashFlowFrame cf2)) + (sum $ map CF.tsTotalCash (cf2 ^. CF.cashflowTxn)) ,testCase "1 year Stepup lease" $ assertEqual "first rental step up at Month 2" (CF.LeaseFlow (L.toDate "20230731") 346.14 31.62) - ((CF.getTsCashFlowFrame cf2)!!1) + ((cf2 ^. CF.cashflowTxn)!!1) ,testCase "1 year Stepup Curve lease" $ assertEqual "first rental step up at Month 0" (CF.LeaseFlow (L.toDate "20230430") 97.83 29.0) - (head (CF.getTsCashFlowFrame cf3_0)) + (head (cf3_0 ^. CF.cashflowTxn )) ,testCase "1 year Stepup Curve lease" $ assertEqual "first rental step up at Month 1" (CF.LeaseFlow (L.toDate "20230630") 34.41 31.8) - (head (CF.getTsCashFlowFrame cf3)) -- `debug` ("CF3->"++show cf3) + (head (cf3 ^. CF.cashflowTxn)) -- `debug` ("CF3->"++show cf3) ,testCase "1 year Stepup Curve lease" $ assertEqual "first rental step up at Month 2" (CF.LeaseFlow (L.toDate "20230731") 0 34.41) - ((CF.getTsCashFlowFrame cf3)!!1) + ((cf3 ^. CF.cashflowTxn)!!1) ,testCase "Lease with Assumptions" $ assertEqual "Month Gap=45 days" (CF.LeaseFlow (L.toDate "20250131") 0 31) - (last (CF.getTsCashFlowFrame cf4) ) -- `debug` ("CF4"++show cf4) + (last (cf4 ^. CF.cashflowTxn) ) -- `debug` ("CF4"++show cf4) ,testCase "Lease with Assumptions" $ assertEqual "Month Gap by Table : New Lease at period 0" (CF.LeaseFlow (L.toDate "20240131") 335 8) - ((CF.getTsCashFlowFrame cf5)!!7) + ((cf5 ^. CF.cashflowTxn)!!7) ,testCase "Lease with Assumptions" $ assertEqual "Month Gap by Table : New Lease at period 1" (CF.LeaseFlow (L.toDate "20240229") 306 29) - ((CF.getTsCashFlowFrame cf5)!!8) + ((cf5 ^. CF.cashflowTxn)!!8) ] installmentTest = diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index 7d22452c..e42a4883 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -1,13 +1,14 @@ -module UT.DealTest(td2,queryTests,triggerTests,dateTests,liqProviderTest) +module UT.DealTest(td2,queryTests,triggerTests,dateTests,liqProviderTest,poolFlowTest) where import Test.Tasty import Test.Tasty.HUnit import Deal +import Deal.DealQuery (queryCompound) import qualified Accounts as A -import qualified Stmt as S +import qualified Stmt as Stmt import qualified Pool as P import qualified Asset as Ast import qualified AssetClass.Mortgage as ACM @@ -25,15 +26,24 @@ import qualified Triggers as Trg import Lib import Types +import Control.Lens hiding (Index,Empty) +import Control.Lens.TH +import Data.Maybe +import Data.Either + import qualified Data.Map as Map import qualified Data.Time as T import qualified Data.Set as S -import Types (PoolId(PoolConsol)) -import qualified CreditEnhancement as CE + +import Debug.Trace +debug = flip Debug.Trace.trace dummySt = (0,toDate "19000101",Nothing) +emptyRunAssump = AP.NonPerfAssumption Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing + + td2 = D.TestDeal { D.name = "test deal1" ,D.status = Amortizing @@ -99,7 +109,9 @@ td2 = D.TestDeal { ,L.bndStmt=Nothing}) ] ) - ,D.pool = D.SoloPool $ + ,D.pool = D.MultiPool $ + Map.fromList $ + [( PoolConsol, P.Pool {P.assets=[AB.Mortgage AB.MortgageOriginalInfo{ AB.originBalance=4000 @@ -132,6 +144,7 @@ td2 = D.TestDeal { ,P.futureCf=Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Just $ Map.fromList [(RuntimeCurrentPoolBalance, 70)]} + )] ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayFee Nothing "General" ["Service-Fee"] Nothing) ,(W.PayInt Nothing "General" ["A"] Nothing) @@ -157,8 +170,8 @@ td2 = D.TestDeal { 0 (toDate "20220201") Nothing - (Just (S.Statement [SupportTxn (toDate "20220215") (Just 110) 10 40 0 0 S.Empty - ,SupportTxn (toDate "20220315") (Just 100) 10 50 0 0 S.Empty])))] + (Just (Stmt.Statement [SupportTxn (toDate "20220215") (Just 110) 10 40 0 0 Empty + ,SupportTxn (toDate "20220315") (Just 100) 10 50 0 0 Empty])))] ,D.triggers = Just $ Map.fromList $ [(BeginDistributionWF, @@ -171,13 +184,131 @@ td2 = D.TestDeal { ,D.ledgers = Nothing } +baseDeal = D.TestDeal { + D.name = "base deal" + ,D.status = Amortizing + ,D.rateSwap = Nothing + ,D.currencySwap = Nothing + ,D.dates = PatternInterval $ + (Map.fromList [ + (ClosingDate,((T.fromGregorian 2022 1 1),MonthFirst,(toDate "20300101"))) + ,(CutoffDate,((T.fromGregorian 2022 1 1),MonthFirst,(toDate "20300101"))) + ,(FirstPayDate,((T.fromGregorian 2022 2 25),DayOfMonth 25,(toDate "20300101"))) + ]) + ,D.accounts = Map.fromList [("General", A.Account { A.accName="General" ,A.accBalance=1000.0 ,A.accType=Nothing, A.accInterest=Nothing ,A.accStmt=Nothing})] + ,D.fees = Map.empty + ,D.bonds = (Map.fromList [("A" + ,L.Bond{ + L.bndName="A" + ,L.bndType=L.Sequential + ,L.bndOriginInfo= L.OriginalInfo{ + L.originBalance=3000 + ,L.originDate= (T.fromGregorian 2022 1 1) + ,L.originRate= 0.08 + ,L.maturityDate = Nothing} + ,L.bndInterestInfo= L.Fix 0.08 DC_ACT_365F + ,L.bndBalance=3000 + ,L.bndRate=0.08 + ,L.bndStepUp=Nothing + ,L.bndDuePrin=0.0 + ,L.bndDueInt=0.0 + ,L.bndDueIntOverInt=0.0 + ,L.bndDueIntDate=Nothing + ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) + ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) + ,L.bndStmt=Nothing}) + ,("B" + ,L.Bond{ + L.bndName="B" + ,L.bndType=L.Equity + ,L.bndOriginInfo= L.OriginalInfo{ + L.originBalance=3000 + ,L.originDate= (T.fromGregorian 2022 1 1) + ,L.originRate= 0.08 + ,L.maturityDate = Nothing} + ,L.bndInterestInfo= L.Fix 0.08 DC_ACT_365F + ,L.bndBalance=500 + ,L.bndRate=0.08 + ,L.bndStepUp=Nothing + ,L.bndDuePrin=0.0 + ,L.bndDueInt=0.0 + ,L.bndDueIntOverInt=0.0 + ,L.bndDueIntDate=Nothing + ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) + ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) + ,L.bndStmt=Nothing}) + ] + ) + ,D.pool = D.MultiPool $ + Map.fromList $ + [( PoolConsol, + P.Pool {P.assets=[AB.Mortgage + AB.MortgageOriginalInfo{ + AB.originBalance=4000 + ,AB.originRate=Fix DC_ACT_365F 0.085 + ,AB.originTerm=60 + ,AB.period=Monthly + ,AB.startDate=(T.fromGregorian 2022 1 1) + ,AB.prinType= AB.Level + ,AB.obligor = Nothing + ,AB.prepaymentPenalty = Nothing} + 4000 + 0.085 + 60 + Nothing + AB.Current] + ,P.futureCf=Nothing + ,P.extendPeriods = Nothing + ,P.asOfDate = T.fromGregorian 2022 1 1 + ,P.issuanceStat = Just $ Map.fromList [(RuntimeCurrentPoolBalance, 70)]})] + ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ + (W.PayInt Nothing "General" ["A"] Nothing) + ,(W.PayPrin Nothing "General" ["A"] Nothing) + ,(W.PayPrin Nothing "General" ["B"] Nothing) + ])] + ,D.collects = [W.Collect Nothing W.CollectedCash "General"] + ,D.custom = Nothing + ,D.call = Nothing + ,D.liqProvider = Nothing + ,D.triggers = Nothing + ,D.overrides = Nothing + ,D.ledgers = Nothing + ,D.rateCap = Nothing +} + +poolFlowTest = + let + (deal,mPoolCf,mResultComp,mPricing) = case (runDeal baseDeal DealPoolFlowPricing Nothing emptyRunAssump) of + (Left er) -> undefined + (Right (a,b,c,d)) -> (a,b,c,d) + bndMap = D.viewBondsInMap deal + in + testGroup "pool cashflow test" + [ + testCase "pool begin flow" $ + assertEqual "pool size should be 60+1" + (Just (Map.fromList [(PoolConsol ,61)])) + ( (\m -> Map.map CF.sizeCashFlowFrame m) <$> mPoolCf ) -- `debug` ("pool "++ show (viewBond)) + + ,testCase "total principal bal" $ + assertEqual "pool bal should equal to total collect" + (Just (Map.fromList [(PoolConsol ,4000)])) + ((\m -> Map.map CF.totalPrincipal m) <$> mPoolCf ) -- `debug` ("pool "++ show (viewBond)) + + ,testCase "last bond A payment date" $ + assertEqual "pool bal should equal to total collect" + (Just (BondTxn (toDate "20240225") 0.00 0.00 30.56 0.080000 30.56 0.00 0.00 (Just 0.0) (TxnComments [PayInt ["A"],PayPrin ["A"]]))) + $ (\s -> last (view Stmt.statementTxns s)) <$> (L.bndStmt $ (bndMap Map.! "A")) + ] + + queryTests = testGroup "deal stat query Tests" [ let - currentDefBal = queryDeal td2 CurrentPoolDefaultedBalance + currentDefBal = queryCompound td2 epocDate CurrentPoolDefaultedBalance in testCase "query current assets in defaulted status" $ - assertEqual "should be 200" 200 currentDefBal + assertEqual "should be 200" (Right 200) currentDefBal ] triggerTests = testGroup "Trigger Tests" @@ -238,26 +369,22 @@ liqProviderTest = let liq1 = CE.LiqFacility "" (CE.FixSupport 100) - 90 (Just 100) (Just CE.IncludeDueInt) - Nothing -- rate type Nothing -- premium rate type Nothing -- rate Nothing -- premium reate - (Just (toDate "20220201")) 0 0 - (toDate "20220301") Nothing - (Just (S.Statement - [SupportTxn (toDate "20220215") (Just 110) 40 40 0 0 S.Empty - ,SupportTxn (toDate "20220315") (Just 100) 50 90 0 0 S.Empty + (Just (Stmt.Statement + [SupportTxn (toDate "20220215") (Just 110) 40 40 0 0 Empty + ,SupportTxn (toDate "20220315") (Just 100) 50 90 0 0 Empty ])) in testGroup "Liq provider test" diff --git a/test/UT/DealTest2.hs b/test/UT/DealTest2.hs index c5d306f5..24c2e2bc 100644 --- a/test/UT/DealTest2.hs +++ b/test/UT/DealTest2.hs @@ -6,6 +6,7 @@ import Test.Tasty import Test.Tasty.HUnit import Deal +import Deal.DealQuery (queryCompound) import qualified Accounts as A import qualified Stmt as S import qualified Pool as P @@ -93,7 +94,8 @@ td = D.TestDeal { ,L.bndStmt=Nothing}) ] ) - ,D.pool = D.SoloPool $ + ,D.pool = D.MultiPool $ + Map.fromList [(PoolConsol, P.Pool {P.assets=[AB.Mortgage AB.MortgageOriginalInfo{ AB.originBalance=4000 @@ -126,6 +128,7 @@ td = D.TestDeal { ,P.futureCf=Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 ,P.issuanceStat = Nothing} + )] ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayFee Nothing "General" ["Service-Fee"] Nothing) ,(W.PayInt Nothing "General" ["A"] Nothing) @@ -213,23 +216,23 @@ tdBondGroup = td { D.bonds = bondGroups, queryTests = testGroup "Deal Group Test" [ let - currBndGrpBal = queryDeal tdBondGroup (CurrentBondBalanceOf ["A"]) + currBndGrpBal = queryCompound tdBondGroup epocDate (CurrentBondBalanceOf ["A"]) in testCase "group bond balance" $ - assertEqual "should be 2500" 2500 currBndGrpBal + assertEqual "should be 2500" (Right 2500) currBndGrpBal ,let bndsFound = D.viewDealAllBonds tdBondGroup in testCase "view viewDealAllBonds " $ assertEqual "should be 3" 3 (length bndsFound) ,let - totalBndBal = queryDeal tdBondGroup CurrentBondBalance + totalBndBal = queryCompound tdBondGroup epocDate CurrentBondBalance in testCase "total bond balance" $ - assertEqual "should be 3000" 3000 totalBndBal + assertEqual "should be 3000" (Right 3000) totalBndBal ,let - originBndbal = queryDeal tdBondGroup (OriginalBondBalanceOf ["A"]) + originBndbal = queryCompound tdBondGroup epocDate (OriginalBondBalanceOf ["A"]) in testCase "original bond balance" $ - assertEqual "should be 5000" 5000 originBndbal - ] \ No newline at end of file + assertEqual "should be 5000" (Right 5000) originBndbal + ] diff --git a/test/UT/LibTest.hs b/test/UT/LibTest.hs index 2ff8fa45..d0cee22f 100644 --- a/test/UT/LibTest.hs +++ b/test/UT/LibTest.hs @@ -3,7 +3,7 @@ module UT.LibTest(curveTests ,datesTests ,prorataTests ,tsOperationTests - ,pvTests) + ,pvTests,seqFunTest) where import Test.Tasty @@ -141,3 +141,23 @@ pvTests = 1 1 ] + +seqFunTest = + let + a =1 + in + testGroup "seq fun test" + [ + testCase "clear:even" $ + assertEqual "Good for first" + [100,20,0] + (paySeqLiabilitiesAmt 120 [100,20,0]) + ,testCase "shortfall" $ + assertEqual "Good for first" + [100,20,0] + (paySeqLiabilitiesAmt 120 [100,20,10]) + ,testCase "over " $ + assertEqual "Good for first" + [100,10,0] + (paySeqLiabilitiesAmt 120 [100,10,0]) + ] diff --git a/test/UT/RateHedgeTest.hs b/test/UT/RateHedgeTest.hs index f429867d..874903c5 100644 --- a/test/UT/RateHedgeTest.hs +++ b/test/UT/RateHedgeTest.hs @@ -28,14 +28,14 @@ capRateTests = [ testCase "Accure out of scope" $ assertEqual "before" - rc + (Right rc) (accrueRC td2 (Lib.toDate "20231201") indexAssump rc) ,testCase "Accure out of scope" $ assertEqual "after" - rc + (Right rc) (accrueRC td2 (Lib.toDate "20280101") indexAssump rc) ,testCase "Accrue on flat curve" $ assertEqual "netCash" - 5.0 - (rcNetCash rc1) - ] \ No newline at end of file + (Right 5.0) + (rcNetCash <$> rc1) + ]