diff --git a/Hastructure.cabal b/Hastructure.cabal --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: Hastructure -version: 0.50.2 +version: 0.50.3 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow @@ -52,6 +52,8 @@ Deal.DealMod Deal.DealQuery Deal.DealValidation + Deal.DealRun + Deal.DealCollection Errors Expense Hedge @@ -84,7 +86,7 @@ bytestring >= 0.12.1 && < 0.13, -- exceptions >= 0.10.7 && < 0.11, mtl >= 2.3.1 && < 2.4, - time >= 1.12.2 && < 1.13, + time >= 1.12.2 && < 1.15, text >= 2.1.1 && < 2.2, regex-base >= 0.94.0 && < 0.95, aeson >= 2.2.3 && < 2.3, @@ -141,7 +143,6 @@ containers, template-haskell, bytestring, - exceptions, mtl, time, text, @@ -220,7 +221,6 @@ containers, template-haskell, bytestring, - exceptions, mtl, time, text, diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,13 +1,10 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} @@ -18,7 +15,6 @@ import Prelude () import Prelude.Compat import System.Environment -import Control.Monad.Catch (MonadCatch, MonadThrow (..)) import Control.Monad.IO.Class (liftIO) import Control.Monad (mapM) import Control.Exception (Exception,throwIO,throw) @@ -141,7 +137,6 @@ (_d,_pflow,_rs,_p, _osPflow) <- D.runDeal d (S.fromList fs) mAssump mNonPerfAssump return (PDeal _d,_pflow,_rs,_p,_osPflow) -wrapRun _ x _ _ = Left $ "RunDeal Failed ,due to unsupport deal type "++ show x patchCumulativeToPoolRun :: RunPoolTypeRtn_ -> RunPoolTypeRtn_ patchCumulativeToPoolRun @@ -158,22 +153,21 @@ wrapRunPoolType flag (VPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) wrapRunPoolType flag (PPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) wrapRunPoolType flag (UPool pt) assump mRates = D.runPoolType flag pt assump $ Just (AP.NonPerfAssumption{AP.interest = mRates}) -wrapRunPoolType flag x _ _ = Left $ "RunPool Failed ,due to unsupport pool type "++ show x wrapRunAsset :: RunAssetReq -> RunAssetResp wrapRunAsset (RunAssetReq d assets Nothing mRates Nothing) = do - cfs <- sequenceA $ (\a -> MA.calcAssetUnion a d mRates) <$> assets + cfs <- traverse (\a -> MA.calcAssetUnion a d mRates) assets return (fst (P.aggPool Nothing [(cf,Map.empty) | cf <- cfs]), Nothing) wrapRunAsset (RunAssetReq d assets (Just (AP.PoolLevel assumps)) mRates Nothing) = do - cfs <- sequenceA $ (\a -> MA.projAssetUnion a d assumps mRates) <$> assets + cfs <- traverse (\a -> MA.projAssetUnion a d assumps mRates) assets return (fst (P.aggPool Nothing [(cf,Map.empty) | (cf,_) <- cfs]) , Nothing) wrapRunAsset (RunAssetReq d assets (Just (AP.PoolLevel assumps)) mRates (Just pm)) = do - cfs <- sequenceA $ (\a -> MA.projAssetUnion a d assumps mRates) <$> assets - pricingResult <- sequenceA $ (\a -> D.priceAssetUnion a d pm assumps mRates) <$> assets + cfs <- traverse (\a -> MA.projAssetUnion a d assumps mRates) assets + pricingResult <- traverse (\a -> D.priceAssetUnion a d pm assumps mRates) assets let (assetCf,_) = P.aggPool Nothing cfs return (assetCf , Just pricingResult) @@ -213,12 +207,11 @@ runPool :: RunPoolReq -> Handler PoolRunResp runPool (SingleRunPoolReq f pt passumption mRates) = return $ - patchCumulativeToPoolRun <$> (wrapRunPoolType f pt passumption mRates) + patchCumulativeToPoolRun <$> wrapRunPoolType f pt passumption mRates runPoolScenarios :: RunPoolReq -> Handler (Map.Map ScenarioName PoolRunResp) runPoolScenarios (MultiScenarioRunPoolReq f pt mAssumps mRates) - = return $ Map.map (\assump -> - patchCumulativeToPoolRun <$> (wrapRunPoolType f pt (Just assump) mRates)) + = return $ Map.map (\assump -> patchCumulativeToPoolRun <$> wrapRunPoolType f pt (Just assump) mRates) mAssumps runDeal :: RunDealReq -> Handler RunResp @@ -407,7 +400,7 @@ Just (EndRun (Just d) _ ) -> d Nothing -> case queryClosingDate dt of Right d' -> d' - Left err -> error $ "Error in BalanceFormula: " ++ err + Left err -> error $ "Error in BalanceFormula: " ++ err v = case queryDealType dt _date (Q.patchDateToStats _date ds) of Right v' -> fromRational v' Left err -> error $ "Error in BalanceFormula: " ++ err @@ -433,13 +426,12 @@ def = RiddersParam { riddersMaxIter = itertimes, riddersTol = RelTol 0.000001} riddersFn = case tweak of SplitFixedBalance _ _ (l,h) -> ridders def (min h 0.99, max l 0.00001) - StressPoolDefault (l,h) -> ridders def (h ,max l 0.00) - StressPoolPrepayment (l,h) -> ridders def (h ,max l 0.00) - MaxSpreadTo _ (l,h) -> ridders def (h ,max l 0.00) - _ -> error ("Unsupported tweak for root finder" ++ show tweak) + StressPoolDefault (l,h) -> ridders def (h ,max l 0.00) + StressPoolPrepayment (l,h) -> ridders def (h ,max l 0.00) + MaxSpreadTo _ (l,h) -> ridders def (h ,max l 0.00) in case riddersFn (rootFindAlgo req tweak stop) of - Root r -> Right $ RFResult r (doTweak r tweak req) + Root r -> return $ RFResult r (doTweak r tweak req) NotBracketed -> Left "Not able to bracket the root" SearchFailed -> Left "Not able to find the root" diff --git a/app/MainBase.hs b/app/MainBase.hs --- a/app/MainBase.hs +++ b/app/MainBase.hs @@ -24,7 +24,6 @@ import Prelude () import Prelude.Compat import System.Environment -import Control.Monad.Catch (MonadCatch, MonadThrow (..)) import Control.Monad.IO.Class (liftIO) import Control.Monad (mapM) import Control.Exception (Exception,throwIO,throw) @@ -65,6 +64,7 @@ import Types import qualified Deal as D import qualified Deal.DealBase as DB +import qualified Deal.DealCollection as DC import qualified Deal.DealQuery as Q import qualified Asset as Ast import qualified Pool as P @@ -254,7 +254,7 @@ instance ToSchema W.ExtraSupport instance ToSchema W.Action instance ToSchema W.BookType -instance ToSchema W.CollectionRule +instance ToSchema DC.CollectionRule instance ToSchema C.CallOption instance ToSchema CE.LiqCreditCalc instance ToSchema CE.LiqFacility diff --git a/src/Asset.hs b/src/Asset.hs --- a/src/Asset.hs +++ b/src/Asset.hs @@ -198,7 +198,7 @@ vectorUsed = take remainingTerm $ drop agedTerm ppyVectorInCPR in case period (getOriginInfo a) of - Monthly -> Right $ cpr2smm <$> vectorUsed + Monthly -> return $ cpr2smm <$> vectorUsed _ -> Left $ "PSA is only supported for monthly payment but got "++ show (period (getOriginInfo a)) Just (A.PrepaymentByTerm rs) -> let @@ -206,7 +206,7 @@ oTerm = originTerm (getOriginInfo a) in case find (\x -> oTerm == length x) rs of - Just v -> Right $ drop agedTerm v + Just v -> return $ drop agedTerm v Nothing -> Left "Prepayment by term doesn't match the origin term" _ -> Left ("failed to find prepayment type"++ show mPa) diff --git a/src/AssetClass/Installment.hs b/src/AssetClass/Installment.hs --- a/src/AssetClass/Installment.hs +++ b/src/AssetClass/Installment.hs @@ -76,7 +76,7 @@ instance Asset Installment where calcCashflow inst@(Installment (LoanOriginalInfo ob or ot p sd ptype _) cb rt st) asOfDay _ - = Right $ CF.CashFlowFrame (begBal,asOfDay,Nothing) flows + = return $ CF.CashFlowFrame (begBal,asOfDay,Nothing) flows where lastPayDate:cf_dates = lastN (rt+1) $ sd:getPaymentDates inst 0 opmt = divideBI ob ot @@ -94,7 +94,6 @@ int_flow = case ptype of F_P -> replicate rt cfee PO_FirstN n -> lastN rt $ replicate n 0.0 ++ replicate (ot-n) cfee - -- initRow = CF.LoanFlow lastPayDate cb 0.0 0.0 0.0 0.0 0.0 0.0 0.0 Nothing _flows = let _rt = succ rt in @@ -155,12 +154,12 @@ let (txns,_,_) = projectInstallmentFlow (cb,lastPayDate,(opmt,ofee),orate,currentFactor,pt,ot) (cfDates,defRates,ppyRates,remainTerms) let (futureTxns,historyM) = CF.cutoffTrs asOfDay (patchLossRecovery (DL.toList txns) recoveryAssump) let begBal = CF.buildBegBal futureTxns - return $ (applyHaircut ams (CF.CashFlowFrame (begBal,asOfDay,Nothing) futureTxns), historyM) + return (applyHaircut ams (CF.CashFlowFrame (begBal,asOfDay,Nothing) futureTxns), historyM) -- ^ project with defaulted at a date projCashflow inst@(Installment (LoanOriginalInfo ob or ot p sd ptype _) cb rt (Defaulted (Just defaultedDate))) asOfDay - (_,_,(A.DefaultedRecovery rr lag timing)) + (_,_,A.DefaultedRecovery rr lag timing) mRates = let (cf_dates1,cf_dates2) = splitAt lag $ genDates defaultedDate p (lag+length timing) @@ -171,14 +170,14 @@ futureTxns = cutBy Inc Future asOfDay $ beforeRecoveryTxn++_txns begBal = CF.buildBegBal futureTxns in - Right $ (CF.CashFlowFrame (begBal,asOfDay,Nothing) futureTxns ,Map.empty) + return (CF.CashFlowFrame (begBal,asOfDay,Nothing) futureTxns ,Map.empty) where cr = getOriginRate inst -- ^ project cashflow with defaulted status 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) - + = return (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 diff --git a/src/Assumptions.hs b/src/Assumptions.hs --- a/src/Assumptions.hs +++ b/src/Assumptions.hs @@ -22,12 +22,14 @@ ,_ReceivableAssump,_FixedAssetAssump ,stressDefaultAssump,applyAssumptionTypeAssetPerf,TradeType(..) ,LeaseEndType(..),LeaseDefaultType(..),stressPrepaymentAssump,StopBy(..) + ,readCallOptions + ,evalFloaterRate,applyFloatRate ,applyFloatRate2 ) where import Call as C import Lib (Ts(..),TsPoint(..),toDate,mkRateTs) -import Liability (Bond,InterestInfo) +import Liability (Bond,InterestInfo(..)) import Util import DateUtil import qualified Data.Map as Map @@ -45,7 +47,7 @@ import GHC.Generics import AssetClass.AssetBase import Debug.Trace -import InterestRate +import qualified InterestRate as IR import Control.Lens hiding (Index) debug = flip trace @@ -311,11 +313,11 @@ assumps -- | project rates used by rate type ,with interest rate assumptions and observation dates -projRates :: IRate -> RateType -> Maybe [RateAssumption] -> [Date] -> Either String [IRate] +projRates :: IRate ->IR.RateType -> Maybe [RateAssumption] -> [Date] -> Either String [IRate] projRates sr _ _ [] = Left "No dates provided for rate projection" -projRates sr (Fix _ r) _ ds = Right $ replicate (length ds) sr -projRates sr (Floater _ idx spd r dp rfloor rcap mr) Nothing ds = Left $ "Looking up rate error: No rate assumption found for index "++ show idx -projRates sr (Floater _ idx spd r dp rfloor rcap mr) (Just assumps) ds +projRates sr (IR.Fix _ r) _ ds = Right $ replicate (length ds) sr +projRates sr (IR.Floater _ idx spd r dp rfloor rcap mr) Nothing ds = Left $ "Looking up rate error: No rate assumption found for index "++ show idx +projRates sr (IR.Floater _ idx spd r dp rfloor rcap mr) (Just assumps) ds = case getRateAssumption assumps idx of Nothing -> Left ("Failed to find index rate " ++ show idx ++ " from "++ show assumps) Just _rateAssumption -> @@ -337,6 +339,84 @@ (Nothing, Just cv) -> capWith cv $ fromRational <$> ratesUsedByDates projRates _ rt rassump ds = Left ("Invalid rate type: "++ show rt++" assump: "++ show rassump) + +-- ^ split call option assumption , +-- lefts are for waterfall payment days +-- rights are for date-based calls +splitCallOpts :: CallOpt -> ([Pre],[Pre]) +splitCallOpts (CallPredicate ps) = (ps,[]) +splitCallOpts (LegacyOpts copts) = + let + cFn (C.PoolBalance bal) = If L (CurrentPoolBalance Nothing) bal + cFn (C.BondBalance bal) = If L CurrentBondBalance bal + cFn (C.PoolFactor r) = IfRate L (Types.PoolFactor Nothing) (fromRational r) + cFn (C.BondFactor r) = IfRate L Types.BondFactor (fromRational r) + cFn (C.OnDate d) = IfDate E d + cFn (C.AfterDate d) = IfDate G d + cFn (C.And _opts) = Types.All [ cFn o | o <- _opts ] + cFn (C.Or _opts) = Types.Any [ cFn o | o <- _opts ] + cFn (C.Pre p) = p + in + ([ cFn copt | copt <- copts ],[]) +-- legacyCallOptConvert (AP.CallOptions opts) = concat [ legacyCallOptConvert o | o <- opts ] +splitCallOpts (CallOnDates dp ps) = ([],ps) + + +readCallOptions :: [CallOpt] -> ([Pre],[Pre]) +readCallOptions [] = ([],[]) +readCallOptions opts = + let + result = splitCallOpts <$> opts + in + (concat (fst <$> result), concat (snd <$> result)) + +evalFloaterRate :: Date -> [RateAssumption] -> IR.RateType -> IRate +evalFloaterRate _ _ (IR.Fix _ r) = r +evalFloaterRate d ras (IR.Floater _ idx spd _r _ mFloor mCap mRounding) + = let + ra = getRateAssumption ras idx + flooring (Just f) v = max f v + flooring Nothing v = v + capping (Just f) v = min f v + capping Nothing v = v + in + case ra of + Nothing -> error "Failed to find index rate in assumption" + Just (RateFlat _ v) -> capping mCap $ flooring mFloor $ v + spd + Just (RateCurve _ curve) -> capping mCap $ flooring mFloor $ fromRational $ getValByDate curve Inc d + toRational spd + +applyFloatRate :: InterestInfo -> Date -> [RateAssumption] -> IRate +applyFloatRate (Liability.Floater _ idx spd p dc mf mc) d ras + = case (mf,mc) of + (Nothing,Nothing) -> _rate + (Just f,Nothing) -> max f _rate + (Just f,Just c) -> min c $ max f _rate + (Nothing,Just c) -> min c _rate + where + idx_rate = case ra of + Just (RateCurve _idx _ts) -> fromRational $ getValByDate _ts Exc d + Just (RateFlat _idx _r) -> _r + Nothing -> 0.0 + ra = getRateAssumption ras idx + _rate = idx_rate + spd -- `debug` ("idx"++show idx_rate++"spd"++show spd) + +applyFloatRate (Liability.CapRate ii _rate) d ras = min _rate (applyFloatRate ii d ras) +applyFloatRate (Liability.FloorRate ii _rate) d ras = max _rate (applyFloatRate ii d ras) +applyFloatRate (Liability.Fix r _ ) d ras = r +applyFloatRate (Liability.WithIoI ii _) d ras = applyFloatRate ii d ras + +applyFloatRate2 :: IR.RateType -> Date -> [RateAssumption] -> Either String IRate +applyFloatRate2 (IR.Fix _ r) _ _ = Right r +applyFloatRate2 (IR.Floater _ idx spd _r _ mFloor mCap mRounding) d ras + = let + flooring (Just f) v = max f v + flooring Nothing v = v + capping (Just f) v = min f v + capping Nothing v = v + in + do + rateAtDate <- lookupRate0 ras idx d + return $ flooring mFloor $ capping mCap $ rateAtDate + spd -- ^ Given a list of rates, calcualte whether rates was reset diff --git a/src/Cashflow.hs b/src/Cashflow.hs --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -28,7 +28,7 @@ ,splitPoolCashflowByDate ,getAllDatesCashFlowFrame,splitCf, cutoffCashflow ,AssetCashflow,PoolCashflow - ,emptyCashflow,isEmptyRow2 + ,emptyCashflow,isEmptyRow2,appendMCashFlow ) where import Data.Time (Day) @@ -1155,6 +1155,13 @@ getter (CashFlowFrame _ txns) = txns setter (CashFlowFrame st txns) newTxns = CashFlowFrame st newTxns +appendMCashFlow :: Maybe CashFlowFrame -> [TsRow] -> Maybe CashFlowFrame +appendMCashFlow Nothing [] = Nothing +appendMCashFlow (Just cf) [] = Just cf +appendMCashFlow Nothing txns + = Just $ CashFlowFrame (0, epocDate, Nothing) txns +appendMCashFlow (Just (CashFlowFrame st txns)) newTxns + = Just $ CashFlowFrame st (txns ++ newTxns) txnCumulativeStats :: Lens' TsRow (Maybe CumulativeStat) txnCumulativeStats = lens getter setter diff --git a/src/Deal.hs b/src/Deal.hs --- a/src/Deal.hs +++ b/src/Deal.hs @@ -7,1600 +7,639 @@ {-# LANGUAGE TupleSections #-} {-# LANGUAGE FlexibleContexts #-} -module Deal (run,runPool,getInits,runDeal,ExpectReturn(..) - ,performAction - ,populateDealDates,accrueRC - ,calcTargetAmount,updateLiqProvider - ,projAssetUnion,priceAssetUnion - ,removePoolCf,runPoolType,PoolType - ,ActionOnDate(..),DateDesp(..) - ,changeDealStatus - ) where - -import Control.Parallel.Strategies -import qualified Accounts as A -import qualified Ledger as LD -import qualified Asset as Ast -import qualified Pool as P -import qualified Expense as F -import qualified Liability as L -import qualified CreditEnhancement as CE -import qualified Analytics -import qualified Waterfall as W -import qualified Cashflow as CF -import qualified Assumptions as AP -import qualified Reports as Rpt -import qualified AssetClass.AssetBase as ACM -import AssetClass.Mortgage -import AssetClass.Lease -import AssetClass.Loan -import AssetClass.Installment -import AssetClass.MixedAsset - -import qualified Call as C -import qualified InterestRate as IR -import Deal.DealBase -import Deal.DealQuery -import Deal.DealAction -import qualified Deal.DealValidation as V -import Stmt -import Lib -import Util -import DateUtil -import Types -import Revolving -import Triggers - -import qualified Data.Map as Map hiding (mapEither) -import qualified Data.Time as T -import qualified Data.Set as S -import qualified Control.Lens as LS -import Data.List -import qualified Data.DList as DL -import Data.Fixed -import Data.Time.Clock -import Data.Maybe -import Data.Either -import Data.Aeson hiding (json) --- import qualified Data.Aeson.Encode.Pretty as Pretty -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types -import GHC.Generics -import Control.Monad -import Control.Monad.Writer -import Control.Monad.Loops (allM,anyM) -import Control.Applicative (liftA2) - -import Debug.Trace -import Cashflow (buildBegTsRow) -import Assumptions (NonPerfAssumption(NonPerfAssumption),lookupRate0) -import Asset () -import Pool (issuanceStat) -import qualified Types as P -import Control.Lens hiding (element) -import Control.Lens.TH -import Data.Either.Utils -import InterestRate (calcInt) -import Liability (getDayCountFromInfo,getTxnRate) -import Hedge (RateCap(..),RateSwapBase(..),RateSwap(rsRefBalance)) -import qualified Hedge as HE - -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 _ _ L.OriginalInfo{ L.originDate = od} ii _ bal currentRate _ dueInt _ Nothing _ _ _) - = setBondNewRate t d ras b {L.bndDueIntDate = Just od} - --- ^ Floater rate -setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Floater br idx _spd rset dc mf mc) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) - = Right $ (L.accrueInt d b){ L.bndRate = applyFloatRate ii d ras } - --- ^ Fix rate, do nothing -setBondNewRate t d ras b@(L.Bond _ _ _ L.Fix {} _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) - = Right b - --- ^ Ref rate -setBondNewRate t d ras b@(L.Bond _ _ _ (L.RefRate sr ds factor _) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) - = do - let b' = L.accrueInt d b - rate <- queryCompound t d (patchDateToStats d ds) - return b' {L.bndRate = fromRational (rate * toRational factor) } - --- ^ cap & floor & IoI -setBondNewRate t d ras b@(L.Bond _ _ _ ii _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) - = Right $ (L.accrueInt d b) { L.bndRate = applyFloatRate ii d ras} - --- ^ bond group -setBondNewRate t d ras bg@(L.BondGroup bMap pt) - = do - m <- mapM (setBondNewRate t d ras) bMap - return $ L.BondGroup m pt - --- ^ apply all rates for multi-int bond -setBondNewRate t d ras b@(L.MultiIntBond bn _ _ iis _ bal currentRates _ dueInts dueIoIs _ _ _ _) - = let - newRates = applyFloatRate <$> iis <*> pure d <*> pure ras - b' = L.accrueInt d b -- `debug` ("accrue due to new rate "++ bn) - in - Right $ b' { L.bndRates = newRates } - - - -setBondStepUpRate :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> L.Bond -> Either String L.Bond -setBondStepUpRate t d ras b@(L.Bond _ _ _ ii (Just sp) _ _ _ _ _ _ _ _ _) - = Right $ - let - newII = L.stepUpInterestInfo sp ii - newRate = applyFloatRate ii d ras - in - (L.accrueInt d b) { L.bndInterestInfo = newII, L.bndRate = newRate } - -setBondStepUpRate t d ras b@(L.MultiIntBond bn _ _ iis (Just sps) _ _ _ _ _ _ _ _ _) - = Right $ - let - newIIs = zipWith L.stepUpInterestInfo sps iis - newRates = (\x -> applyFloatRate x d ras) <$> newIIs - in - (L.accrueInt d b) { L.bndInterestInfos = newIIs, L.bndRates = newRates } -- `debug` (show d ++ ">> accure due to step up rate "++ bn) - -setBondStepUpRate t d ras bg@(L.BondGroup bMap pt) - = do - m <- mapM (setBondStepUpRate t d ras) bMap - return $ L.BondGroup m pt - - - -updateSrtRate :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> HE.SRT -> Either String HE.SRT -updateSrtRate t d ras srt@HE.SRT{HE.srtPremiumType = rt} - = do - r <- applyFloatRate2 rt d ras - return srt { HE.srtPremiumRate = r } - - -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 } - = do - newBal <- case st of - HE.SrtByEndDay ds dp -> queryCompound t d (patchDateToStats d ds) - 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 -updateLiqProviderRate t d ras liq@CE.LiqFacility{CE.liqRateType = mRt, CE.liqPremiumRateType = mPrt - , CE.liqRate = mr, CE.liqPremiumRate = mPr } - = let - newMr = evalFloaterRate d ras <$> mRt - newMpr = evalFloaterRate d ras <$> mPrt - -- TODO probably need to accure int when interest rate changes ? - in - liq {CE.liqRate = newMr, CE.liqPremiumRate = newMpr } - - -evalFloaterRate :: Date -> [RateAssumption] -> IR.RateType -> IRate -evalFloaterRate _ _ (IR.Fix _ r) = r -evalFloaterRate d ras (IR.Floater _ idx spd _r _ mFloor mCap mRounding) - = let - ra = AP.getRateAssumption ras idx - flooring (Just f) v = max f v - flooring Nothing v = v - capping (Just f) v = min f v - capping Nothing v = v - in - case ra of - Nothing -> error "Failed to find index rate in assumption" - Just (RateFlat _ v) -> capping mCap $ flooring mFloor $ v + spd - Just (RateCurve _ curve) -> capping mCap $ flooring mFloor $ fromRational $ getValByDate curve Inc d + toRational spd - -applyFloatRate :: L.InterestInfo -> Date -> [RateAssumption] -> IRate -applyFloatRate (L.Floater _ idx spd p dc mf mc) d ras - = case (mf,mc) of - (Nothing,Nothing) -> _rate - (Just f,Nothing) -> max f _rate - (Just f,Just c) -> min c $ max f _rate - (Nothing,Just c) -> min c _rate - where - idx_rate = case ra of - Just (RateCurve _idx _ts) -> fromRational $ getValByDate _ts Exc d - Just (RateFlat _idx _r) -> _r - Nothing -> 0.0 - ra = AP.getRateAssumption ras idx - _rate = idx_rate + spd -- `debug` ("idx"++show idx_rate++"spd"++show spd) - -applyFloatRate (L.CapRate ii _rate) d ras = min _rate (applyFloatRate ii d ras) -applyFloatRate (L.FloorRate ii _rate) d ras = max _rate (applyFloatRate ii d ras) -applyFloatRate (L.Fix r _ ) d ras = r -applyFloatRate (L.WithIoI ii _) d ras = applyFloatRate ii d ras - -applyFloatRate2 :: IR.RateType -> Date -> [RateAssumption] -> Either String IRate -applyFloatRate2 (IR.Fix _ r) _ _ = Right r -applyFloatRate2 (IR.Floater _ idx spd _r _ mFloor mCap mRounding) d ras - = let - flooring (Just f) v = max f v - flooring Nothing v = v - capping (Just f) v = min f v - capping Nothing v = v - in - do - rateAtDate <- AP.lookupRate0 ras idx d - return $ flooring mFloor $ capping mCap $ rateAtDate + spd - -updateRateSwapRate :: Ast.Asset a => TestDeal a -> Maybe [RateAssumption] -> Date -> HE.RateSwap -> Either String HE.RateSwap -updateRateSwapRate t Nothing _ _ = Left "Failed to update rate swap: No rate input assumption" -updateRateSwapRate t (Just rAssumps) d rs@HE.RateSwap{ HE.rsType = rt } - = let - getRate x = AP.lookupRate rAssumps x d - in - do - (pRate,rRate) <- case rt of - HE.FloatingToFloating flter1 flter2 -> - do - r1 <- getRate flter1 - r2 <- getRate flter2 - return (r1, r2) - HE.FloatingToFixed flter r -> - do - _r <- getRate flter - return (_r, r) - HE.FixedToFloating r flter -> - do - _r <- getRate flter - return (r, _r) - HE.FormulaToFloating ds flter -> - do - _r <- queryCompound t d (patchDateToStats d ds) - r <- getRate flter - return (fromRational _r, r) - HE.FloatingToFormula flter ds -> - do - r <- getRate flter - _r <- queryCompound t d (patchDateToStats d ds) - return (r, fromRational _r) - return rs {HE.rsPayingRate = pRate, HE.rsReceivingRate = rRate } - -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 _ -> 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 -> 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 = Right rc - | otherwise = do - r <- lookupRate0 rs index d - 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 (IrsTxn d newAmt addAmt 0 0 0 SwapAccrue) mstmt - 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 -> (< 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 - C.Or xs -> anyM (testCall t d) xs - -- 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 - _ -> Left ("failed to find call options"++ show opt) - - -queryTrigger :: Ast.Asset a => TestDeal a -> DealCycle -> [Trigger] -queryTrigger t@TestDeal{ triggers = trgs } wt - = case trgs of - Nothing -> [] - Just _trgs -> maybe [] Map.elems $ Map.lookup wt _trgs - --- ^ execute effects of trigger: making changes to deal --- TODO seems position of arugments can be changed : f :: a -> b -> m a => f:: b -> a -> m a -runEffects :: Ast.Asset a => (TestDeal a, RunContext a, [ActionOnDate], DL.DList ResultComponent) -> Date -> TriggerEffect - -> Either String (TestDeal a, RunContext a, [ActionOnDate], DL.DList ResultComponent) -runEffects (t@TestDeal{accounts = accMap, fees = feeMap ,status=st, bonds = bondMap, pool=pt - ,collects = collRules}, rc, actions, logs) d te - = case te of - DealStatusTo _ds -> Right (t {status = _ds}, rc, actions, logs) - DoAccrueFee fns -> do - newFeeList <- sequenceA $ calcDueFee t d <$> (feeMap Map.!) <$> fns - let newFeeMap = Map.fromList (zip fns newFeeList) <> feeMap - return (t {fees = newFeeMap}, rc, actions, logs) - ChangeReserveBalance accName rAmt -> - Right (t {accounts = Map.adjust (set A.accTypeLens (Just rAmt)) accName accMap } - , rc, actions, logs) - - TriggerEffects efs -> foldM (`runEffects` d) (t, rc, actions, logs) efs - - RunActions wActions -> do - (newT, newRc, newLogs) <- foldM (performActionWrap d) (t, rc, DL.empty) wActions - return (newT, newRc, actions, DL.append logs newLogs) - - ChangeBondRate bName bRateType bRate -> - let - -- accrual rate - -- set current rate - -- update rate component - updateFn b = L.accrueInt d b - & set L.interestInfoTraversal bRateType - & set L.curRatesTraversal bRate - -- updated deal - t' = t {bonds = updateBondInMap bName updateFn bondMap} - -- build bond rate reset actions - newActions = case getBondByName t' True bName of - Just bnd -> [ ResetBondRate _d bName | _d <- L.buildRateResetDates bnd d (getDate (last actions))] - Nothing -> [] - in - Right (t' , rc, sortBy sortActionOnDate (newActions++actions), logs) - - DoNothing -> Right (t, rc, actions, DL.empty) - _ -> 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], DL.DList ResultComponent) -runTriggers (t@TestDeal{status=oldStatus, triggers = Nothing},rc, actions) d dcycle = Right (t, rc, actions, DL.empty) -runTriggers (t@TestDeal{status=oldStatus, triggers = Just trgM},rc, actions) d dcycle = - do - let trgsMap = Map.findWithDefault Map.empty dcycle trgM - let trgsToTest = Map.filter - (\trg -> (not (trgStatus trg) || trgStatus trg && trgCurable trg)) - trgsMap - triggeredTrgs <- mapM (testTrigger t d) trgsToTest - let triggeredEffects = [ trgEffects _trg | _trg <- Map.elems triggeredTrgs, (trgStatus _trg) ] - (newDeal, newRc, newActions, logsFromTrigger) <- foldM (`runEffects` d) (t,rc,actions, DL.empty) triggeredEffects - let newStatus = status newDeal - let newLogs = DL.fromList [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 - , DL.append 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.PoolCashflow -> Maybe [ActionOnDate] -> Maybe [RateAssumption] -> Maybe ([Pre],[Pre]) - -> Maybe (Map.Map String (RevolvingPool,AP.ApplyAssumptionType)) -> DL.DList ResultComponent - -> Either String (TestDeal a,DL.DList ResultComponent, Map.Map PoolId CF.PoolCashflow) -run t@TestDeal{status=(Ended endedDate)} pCfM ads _ _ _ log = return (t,DL.snoc log (EndRun endedDate "By Status:Ended"), pCfM) -run t pCfM (Just []) _ _ _ log = return (t,DL.snoc log (EndRun Nothing "No Actions"), pCfM) -run t pCfM (Just [HitStatedMaturity d]) _ _ _ log = return (t, DL.snoc log (EndRun (Just d) "Stop: Stated Maturity"), pCfM) -run t pCfM (Just (StopRunFlag d:_)) _ _ _ log = return (t, DL.snoc log (EndRun (Just d) "Stop Run Flag"), pCfM) -run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status=dStatus - ,waterfall=waterfallM,name=dealName,pool=pt,stats=_stat} - poolFlowMap (Just (ad:ads)) rates calls rAssump log - | futureCashToCollectFlag && (queryCompound t (getDate ad) AllAccBalance == Right 0) && (dStatus /= Revolving) && (dStatus /= Warehousing Nothing) --TODO need to use prsim here to cover all warehouse status - = do - let runContext = RunContext poolFlowMap rAssump rates --- `debug` ("ending at date " ++ show (getDate ad)) - (finalDeal,_,newLogs) <- foldM (performActionWrap (getDate ad)) (t,runContext,log) cleanUpActions - return (finalDeal - , DL.snoc newLogs (EndRun (Just (getDate ad)) "No Pool Cashflow/All Account is zero/Not revolving") - , poolFlowMap) - - | otherwise - = case ad of - PoolCollection d _ -> - if any (> 0) remainCollectionNum then - let - cutOffPoolFlowMap = Map.map (\(pflow,mAssetFlow) -> - (CF.splitCashFlowFrameByDate pflow d EqToLeft - ,(\xs -> [ CF.splitCashFlowFrameByDate x d EqToLeft | x <- xs ]) <$> mAssetFlow)) - poolFlowMap - collectedFlow = Map.map (\(p,mAstFlow) -> (fst p, (\xs -> [ fst x | x <- xs ]) <$> mAstFlow)) cutOffPoolFlowMap -- `debug` ("PoolCollection : "++ show d ++ " splited"++ show cutOffPoolFlowMap++"\n input pflow"++ show poolFlowMap) - -- outstandingFlow = Map.map (CF.insertBegTsRow d . snd) cutOffPoolFlowMap - outstandingFlow = Map.map (\(p,mAstFlow) -> (snd p, (\xs -> [ snd x | x <- xs ]) <$> mAstFlow)) cutOffPoolFlowMap - -- deposit cashflow to SPV from external pool cf - in - do - accs <- depositPoolFlow (collects t) d collectedFlow accMap -- `debug` ("PoolCollection: deposit >>"++ show d++">>>"++ show collectedFlow++"\n") - let dAfterDeposit = (appendCollectedCF d t collectedFlow) {accounts=accs} - -- newScheduleFlowMap = Map.map (over CF.cashflowTxn (cutBy Exc Future d)) (fromMaybe Map.empty (getScheduledCashflow t Nothing)) - let newPt = case (pool dAfterDeposit) of - MultiPool pm -> MultiPool $ - Map.map - (over (P.poolFutureScheduleCf . _Just . _1 . CF.cashflowTxn) (cutBy Exc Future d)) - pm - ResecDeal dMap -> ResecDeal dMap - let runContext = RunContext outstandingFlow rAssump rates -- `debug` ("PoolCollection: before rc >>"++ show d++">>>"++ show (pool dAfterDeposit)) - (dRunWithTrigger0, rc1, ads2, newLogs0) <- runTriggers (dAfterDeposit {pool = newPt},runContext,ads) d EndCollection - let eopActionsLog = DL.fromList [ RunningWaterfall d W.EndOfPoolCollection | Map.member W.EndOfPoolCollection waterfallM ] -- `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 (increasePoolCollectedPeriod dRunWithTrigger1 ) - (runPoolFlow rc3) - (Just ads3) - rates - calls - rAssump - (DL.concat [newLogs0,newLogs,eopActionsLog,newLogs1]) - else - run t 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 - let logsBeforeDist = DL.concat [newLogs0 , DL.fromList [ 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 (dealAfterCleanUp, DL.concat [logsBeforeDist,DL.fromList (newStLogs++[EndRun (Just d) "Clean Up"]),endingLogs], poolFlowMap) -- `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 (increaseBondPaidPeriod dRunWithTrigger1) - (runPoolFlow rc3) - (Just ads2) - rates - calls - rAssump - (DL.concat [newLogsWaterfall, newLogs2 ,logsBeforeDist,DL.fromList [RunningWaterfall d waterfallKey]]) -- `debug` ("In RunWaterfall Date"++show d++"after run waterfall 3>>"++ show (pool dRunWithTrigger1)++" status>>"++ show (status dRunWithTrigger1)) - - -- Custom waterfall execution action from custom dates - RunWaterfall d wName -> - let - runContext = RunContext poolFlowMap rAssump rates - waterfallKey = W.CustomWaterfall wName - in - do - waterfallToExe <- maybeToEither - ("No waterfall distribution found on date "++show d++" with waterfall key "++show waterfallKey) $ - Map.lookup waterfallKey waterfallM - let logsBeforeDist =[ WarningMsg (" No waterfall distribution found on date "++show d++" with waterfall key "++show waterfallKey) - | Map.notMember waterfallKey waterfallM ] - (dAfterWaterfall, rc2, newLogsWaterfall) <- foldM (performActionWrap d) (t,runContext,log) waterfallToExe -- `debug` (show d ++ " running action"++ show waterfallToExe) - run dAfterWaterfall (runPoolFlow rc2) (Just ads) rates calls rAssump - (DL.concat [newLogsWaterfall,DL.fromList (logsBeforeDist ++ [RunningWaterfall d waterfallKey])]) -- `debug` ("size of logs"++ show (length newLogsWaterfall)++ ">>"++ show d++ show (length logsBeforeDist)) - - 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 -> - do - fToAcc <- maybeToEither - ("Failed to find fee "++feeName) - (Map.lookup feeName feeMap) - 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 - - DealClosed d -> - let - w = Map.findWithDefault [] W.OnClosingDay (waterfall t) - rc = RunContext poolFlowMap rAssump rates - logForClosed = [RunningWaterfall d W.OnClosingDay| not (null w)] - 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 - (DL.concat [newLog, DL.fromList ([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 - - CalcIRSwap d sn -> - case rateSwap t of - Nothing -> Left $ " No rate swaps modeled when looking for "++ sn - Just rSwap -> - do - newRateSwap_rate <- adjustM (updateRateSwapRate t rates d) sn rSwap - 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 - - SettleIRSwap d sn -> - case rateSwap t of - Nothing -> Left $ " No rate swaps modeled when looking for "++ sn - Just rSwap -> - do - acc <- case HE.rsSettleDates (rSwap Map.! sn) of - Nothing -> Left $ "No settle date found for "++ sn - Just (_, _accName) -> Right $ accMap Map.! _accName - let accBal = A.accBalance acc - let rs = rSwap Map.! sn - let settleAmt = HE.rsNetCash rs - let accName = A.accName acc - case (settleAmt <0, accBal < abs settleAmt) of - (True, True) -> - let - newAcc = Map.adjust (A.draw accBal d (SwapOutSettle sn)) accName accMap - newRsMap = Just $ Map.adjust (HE.payoutIRS d accBal) sn rSwap - in - run (t{accounts = newAcc, rateSwap = newRsMap}) poolFlowMap (Just ads) rates calls rAssump - $ DL.snoc log (WarningMsg $ "Settle Rate Swap Error: "++ show d ++" Insufficient balance to settle "++ sn) - -- Left $ "Settle Rate Swap Error: "++ show d ++" Insufficient balance to settle "++ sn - (True, False) -> - let - newAcc = Map.adjust (A.draw (abs settleAmt) d (SwapOutSettle sn)) accName accMap - newRsMap = Just $ Map.adjust (HE.payoutIRS d settleAmt) sn rSwap - in - run (t{accounts = newAcc, rateSwap = newRsMap}) poolFlowMap (Just ads) rates calls rAssump log - (False, _) -> - let - newAcc = Map.adjust (A.deposit settleAmt d (SwapInSettle sn)) accName accMap - newRsMap = Just $ Map.adjust (HE.receiveIRS d) sn rSwap - in - run (t{accounts = newAcc, rateSwap = newRsMap}) 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 $ DL.append log (DL.fromList 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 - - StepUpBondRate d bn -> - let - bnd = bndMap Map.! bn -- `debug` ("StepUpBondRate--------------"++ show bn) - in - do - -- newBnd <- setBondStepUpRate t d bnd `debug` ("StepUpBondRate"++ show d++ show bn) - newBndMap <- adjustM (setBondStepUpRate t d (fromMaybe [] rates)) bn bndMap - run t{bonds = newBndMap } poolFlowMap (Just ads) rates calls rAssump log - - ResetAccRate d accName -> - do - newAccMap <- adjustM - (\a@(A.Account _ _ (Just (A.InvestmentAccount idx spd dp dp1 lastDay _)) _ _) - -> do - newRate <- AP.lookupRate (fromMaybe [] rates) (idx,spd) d - let accWithNewInt = A.depositInt d a - return accWithNewInt { A.accInterest = Just (A.InvestmentAccount idx spd dp dp1 lastDay newRate)}) - accName accMap - 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 - let newlog = FinancialReport sd ed bsReport cashReport - run t poolFlowMap (Just ads) rates calls rAssump $ DL.snoc 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 = do - tm <- mTrgMap - cycM <- Map.lookup cyc tm - trg <- Map.lookup n cycM - return $ trgEffects trg - - runContext = RunContext poolFlowMap rAssump rates - in - do - (newT, rc@(RunContext newPool _ _), adsFromTrigger, newLogsFromTrigger) - <- case triggerEffects of - Nothing -> Right (t, runContext, ads, DL.empty) -- `debug` "Nothing found on effects" - Just efs -> runEffects (t, runContext, ads, DL.empty) d efs - let (oldStatus,newStatus) = (status t,status newT) - let stChangeLogs = DL.fromList [DealStatusChangeTo d oldStatus newStatus "by Manual fireTrigger" | oldStatus /= newStatus] - run newT {triggers = Just triggerFired} newPool (Just ads) rates calls rAssump $ DL.concat [log,stChangeLogs,newLogsFromTrigger] - - MakeWhole d spd walTbl -> - let - schedulePoolFlowMap = case pt of - MultiPool pMap -> Map.map (view (P.poolFutureScheduleCf._Just._1) ) pMap - ResecDeal uDealMap -> Map.map (view uDealFutureScheduleCf) uDealMap - in - do - factor <- liftA2 - (/) - (queryCompound t d (FutureCurrentPoolBegBalance Nothing)) - (queryCompound t d (FutureCurrentSchedulePoolBegBalance Nothing)) - let reduceCfs = Map.map (\f -> (over CF.cashflowTxn (\xs -> CF.scaleTsRow factor <$> xs) f, Nothing ) ) 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 (Just d)} Map.empty (Just []) rates calls rAssump $ DL.snoc log (EndRun (Just d) "MakeWhole call") - - FundBond d Nothing bName accName fundAmt -> - let - newAcc = Map.adjust (A.deposit fundAmt d (FundWith bName fundAmt)) accName accMap - in - do - let bndFunded = L.fundWith d fundAmt $ bndMap Map.! bName - run t{accounts = newAcc, bonds = Map.insert bName bndFunded bndMap} - poolFlowMap (Just ads) rates calls rAssump log - - FundBond d (Just p) bName accName fundAmt -> - let - newAcc = Map.adjust (A.deposit fundAmt d (FundWith bName fundAmt)) accName accMap - in - do - flag <- testPre d t p - case flag of - False -> run t poolFlowMap (Just ads) rates calls rAssump (DL.snoc log (WarningMsg ("Failed to fund bond"++ bName++ ":" ++show p))) - True -> - do - let bndFunded = L.fundWith d fundAmt $ bndMap Map.! bName - run t{accounts = newAcc, bonds = Map.insert bName bndFunded bndMap} - poolFlowMap (Just ads) rates calls rAssump log - - - 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 (DL.snoc 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 pt) -> 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) pt) - 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) - isResetActionEvent (ResetBondRate _ bName ) = False - isResetActionEvent _ = True - filteredAds = filter isResetActionEvent ads - newRate = L.getBeginRate iInfo - in - do - nBnd <- calcDueInt t d $ bndMap Map.! bName - let dueIntToPay = L.getTotalDueInt 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 0 | d <- resetDates ] - -- TODO tobe fix - let bResetActions = [] - 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 -> Left "Undefined action: RefiBond" - - 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 - DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call"] - else - DL.fromList [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 (dealAfterCleanUp, DL.snoc (endingLogs `DL.append` newStLogs) (EndRun (Just d) "Clean Up"), poolFlowMap) -- `debug` ("Called ! "++ show d) - _ -> run t poolFlowMap (Just ads) rates calls rAssump log - - StopRunTest d pres -> - do - flags::[Bool] <- sequenceA $ [ (testPre d t pre) | pre <- pres ] - case all id flags of - True -> return (t, DL.snoc log (EndRun (Just d) ("Stop Run Test by:"++ show (zip pres flags))), poolFlowMap) - _ -> 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)) - remainCollectionNum = Map.elems $ Map.map (\(x,_) -> CF.sizeCashFlowFrame x ) poolFlowMap - futureCashToCollectFlag = and $ Map.elems $ Map.map (\(pcf,_) -> all CF.isEmptyRow2 (view CF.cashflowTxn pcf)) poolFlowMap - - -run t empty Nothing Nothing Nothing Nothing log - = do - (t, ads, pcf, unStressPcf) <- getInits S.empty t Nothing Nothing - run t pcf (Just ads) Nothing Nothing Nothing log -- `debug` ("Init Done >>Last Action#"++show (length ads)++"F/L"++show (head ads)++show (last ads)) - -run t empty _ _ _ _ log = Right (t, log ,empty) -- `debug` ("End with pool CF is []") - - - --- reserved for future used -data ExpectReturn = DealLogs - | AssetLevelFlow - deriving (Show,Generic,Ord,Eq) - - --- priceBondIrr :: AP.IrrType -> [Txn] -> Either String (Rate, [(Date,Balance)]) -priceBondIrr :: AP.IrrType -> [Txn] -> Either String (Rate, [Txn]) --- No projected transaction, use history cashflow only -priceBondIrr AP.BuyBond {} [] = Left "No transaction to buy the bond" -priceBondIrr (AP.HoldingBond historyCash _ _) [] - = let - (ds,vs) = unzip historyCash - txns' = [ BondTxn d 0 0 0 0 v 0 0 Nothing Types.Empty | (d,v) <- historyCash ] - in - do - irr <- Analytics.calcIRR ds vs - return (irr, txns') --- Projected transaction and hold to maturity -priceBondIrr (AP.HoldingBond historyCash holding Nothing) txns - = let - begBal = (getTxnBegBalance . head) txns - holdingPct = divideBB holding begBal - bProjectedTxn = scaleTxn holdingPct <$> txns -- `debug` ("holding pct"++ show holding ++"/" ++ show begBal ++" : " ++ show holdingPct) - (ds,vs) = unzip historyCash - (ds2,vs2) = (getDate <$> bProjectedTxn, getTxnAmt <$> bProjectedTxn) -- `debug` ("projected txn position"++ show bProjectedTxn) - - txns' = [ BondTxn d 0 0 0 0 v 0 0 Nothing Types.Empty | (d,v) <- historyCash ] - in - do - irr <- Analytics.calcIRR (ds++ds2) (vs++vs2) -- `debug` ("projected holding"++ show (ds2,vs2)) - return (irr, txns' ++ bProjectedTxn) - --- TODO: need to use DC from bond --- Projected transaction and sell at a Date -priceBondIrr (AP.HoldingBond historyCash holding (Just (sellDate, sellPricingMethod))) txns - = let - -- history cash - (ds,vs) = unzip historyCash - txns' = [ BondTxn d 0 0 0 0 v 0 0 Nothing Types.Empty | (d,v) <- historyCash ] - - begBal = (getTxnBegBalance . head) txns - holdingPct = toRational $ holding / begBal - -- assume cashflow of sell date belongs to seller(owner) - (bProjectedTxn',futureFlow') = splitByDate txns sellDate EqToLeft - (bProjectedTxn,futureFlow) = ((scaleTxn holdingPct) <$> bProjectedTxn',(scaleTxn holdingPct) <$> futureFlow') - -- projected cash - (ds2,vs2) = (getDate <$> bProjectedTxn, getTxnAmt <$> bProjectedTxn) - -- accrued interest - accruedInt = L.backoutAccruedInt sellDate epocDate (bProjectedTxn++futureFlow) - (ds3,vs3) = (sellDate, accruedInt) -- `debug` ("accrued interest"++ show (accruedInt,sellDate)) - -- sell price - sellPrice = case sellPricingMethod of - BondBalanceFactor f -> case bProjectedTxn of - [] -> mulBR begBal (f * holdingPct) - _txns -> mulBR (getTxnBalance (last _txns)) f - (ds4,vs4) = (sellDate, sellPrice) -- `debug` ("sale price, date"++ show (sellPrice,sellDate)) - in - do - irr <- Analytics.calcIRR (ds++ds2++[ds3]++[ds4]) (vs++vs2++[vs3]++[vs4]) -- `debug` ("vs:"++ show vs++ "vs2:"++ show vs2++ "vs3:"++ show vs3++ "vs4:"++ show vs4 ++">>> ds "++ show ds++ "ds2"++ show ds2++ "ds3"++ show ds3++ "ds4"++ show ds4) - return (irr, txns'++ bProjectedTxn++ [(BondTxn sellDate 0 vs3 sellPrice 0 (sellPrice+vs3) 0 0 Nothing Types.Empty)]) - --- Buy and hold to maturity -priceBondIrr (AP.BuyBond dateToBuy bPricingMethod (AP.ByCash cash) Nothing) txns - | null futureFlow' = Left "No transaction to buy bond" - | otherwise - = let - -- balance of bond on buy date - nextTxn = head futureFlow' - balAsBuyDate = getTxnBegBalance nextTxn - buyPrice = case bPricingMethod of - BondBalanceFactor f -> mulBR balAsBuyDate f - buyPaidOut = min buyPrice cash - buyPct = divideBB buyPaidOut buyPrice - boughtTxns = scaleTxn buyPct <$> futureFlow' - -- buy price (including accrued interest) - - accuredInt = let - --TODO what about interest over interest - accruedInt' = calcInt balAsBuyDate dateToBuy (getDate nextTxn) (getTxnRate nextTxn) DC_ACT_365F - x = nextTxn - totalInt' = (fromMaybe 0) <$> [(preview (_BondTxn . _3 ) x), (preview (_BondTxn . _7 ) x), (preview (_BondTxn . _8 ) x)] - in - sum(totalInt') - accruedInt' - - (ds1, vs1) = (dateToBuy, negate (buyPaidOut + accuredInt)) - (ds2, vs2) = (getDate <$> futureFlow', getTxnAmt <$> boughtTxns) - in - do - irr <- Analytics.calcIRR (ds1:ds2) (vs1:vs2) - return (irr, (BondTxn dateToBuy 0 (negate accuredInt) (negate buyPaidOut) 0 vs1 0 0 Nothing Types.Empty):boughtTxns) - where - -- assume cashflow of buy date belongs to seller(owner) - (bProjectedTxn',futureFlow') = splitByDate txns dateToBuy EqToLeft - - -priceBonds :: Ast.Asset a => TestDeal a -> AP.BondPricingInput -> Either String (Map.Map String PriceResult) --- Price bond via discount future cashflow -priceBonds t (AP.DiscountCurve d dc) = Right $ Map.map (L.priceBond d dc) (viewBondsInMap t) --- Run Z-Spread -priceBonds t@TestDeal {bonds = bndMap} (AP.RunZSpread curve bondPrices) - = sequenceA $ - Map.mapWithKey - (\bn (pd,price)-> ZSpread <$> L.calcZspread (price,pd) (bndMap Map.! bn) curve) - bondPrices --- Calc Irr of bonds -priceBonds t@TestDeal {bonds = bndMap} (AP.IrrInput bMapInput) - = let - -- Date - d = getNextBondPayDate t - -- get projected bond txn - projectedTxns xs = snd $ splitByDate xs d EqToRight - -- (Maybe Bond,IrrType) - bndMap' = Map.mapWithKey (\k v -> (getBondByName t True k, v)) bMapInput - -- (Rate, [(date, cash)]) - bndMap'' = Map.mapWithKey (\bName (Just b, v) -> - do - let _irrTxns = projectedTxns (getAllTxns b) - (_irr, flows) <- priceBondIrr v _irrTxns - return (IrrResult (fromRational _irr) flows)) - bndMap' - in - sequenceA bndMap'' - - --- ^ split call option assumption , --- lefts are for waterfall payment days --- rights are for date-based calls -splitCallOpts :: AP.CallOpt -> ([Pre],[Pre]) -splitCallOpts (AP.CallPredicate ps) = (ps,[]) -splitCallOpts (AP.LegacyOpts copts) = - let - cFn (C.PoolBalance bal) = If L (CurrentPoolBalance Nothing) bal - cFn (C.BondBalance bal) = If L CurrentBondBalance bal - cFn (C.PoolFactor r) = IfRate L (PoolFactor Nothing) (fromRational r) - cFn (C.BondFactor r) = IfRate L BondFactor (fromRational r) - cFn (C.OnDate d) = IfDate E d - cFn (C.AfterDate d) = IfDate G d - cFn (C.And _opts) = Types.All [ cFn o | o <- _opts ] - cFn (C.Or _opts) = Types.Any [ cFn o | o <- _opts ] - cFn (C.Pre p) = p - in - ([ cFn copt | copt <- copts ],[]) --- legacyCallOptConvert (AP.CallOptions opts) = concat [ legacyCallOptConvert o | o <- opts ] -splitCallOpts (AP.CallOnDates dp ps) = ([],ps) - - --- , -readCallOptions :: [AP.CallOpt] -> ([Pre],[Pre]) -readCallOptions [] = ([],[]) -readCallOptions opts = - let - result = splitCallOpts <$> opts - in - (concat (fst <$> result), concat (snd <$> result)) - - -runDeal :: Ast.Asset a => TestDeal a -> S.Set ExpectReturn -> Maybe AP.ApplyAssumptionType-> AP.NonPerfAssumption - -> Either String (TestDeal a - , Map.Map PoolId CF.CashFlowFrame - , [ResultComponent] - , Map.Map String PriceResult - , Map.Map PoolId CF.PoolCashflow) -runDeal t er perfAssumps nonPerfAssumps@AP.NonPerfAssumption{AP.callWhen = opts ,AP.pricing = mPricing ,AP.revolving = mRevolving ,AP.interest = mInterest} - | not runFlag = Left $ intercalate ";" $ show <$> valLogs - | otherwise - = do - (newT, ads, pcf, unStressPcf) <- getInits er t perfAssumps (Just nonPerfAssumps) - (_finalDeal, logs, osPoolFlow) <- run (removePoolCf newT) - pcf - (Just ads) - mInterest - (readCallOptions <$> opts) - mRevolvingCtx - DL.empty - -- prepare deal with expected return - let finalDeal = prepareDeal er _finalDeal - -- extract pool cash collected to deal - let poolFlowUsedNoEmpty = Map.map - (over CF.cashflowTxn CF.dropTailEmptyTxns) - (getAllCollectedFrame finalDeal Nothing) - let poolFlowUnUsed = osPoolFlow & mapped . _1 . CF.cashflowTxn %~ CF.dropTailEmptyTxns - & mapped . _2 . _Just . each . CF.cashflowTxn %~ CF.dropTailEmptyTxns - bndPricing <- case mPricing of - (Just p) -> priceBonds finalDeal p - Nothing -> Right Map.empty - return (finalDeal - , poolFlowUsedNoEmpty - , getRunResult finalDeal ++ V.validateRun finalDeal ++ DL.toList (DL.append logs (unCollectedPoolFlowWarning poolFlowUnUsed)) - , bndPricing - , poolFlowUnUsed - ) -- `debug` ("run deal done with pool" ++ show poolFlowUsedNoEmpty) - where - (runFlag, valLogs) = V.validateReq t nonPerfAssumps - -- getinits() will get (new deal snapshot, actions, pool cashflows, unstressed pool cashflow) - -- extract Revolving Assumption - mRevolvingCtx = case mRevolving of - Nothing -> Nothing - Just (AP.AvailableAssets rp rperf) -> Just (Map.fromList [("Consol", (rp, rperf))]) - Just (AP.AvailableAssetsBy rMap) -> Just rMap - unCollectedPoolFlowWarning pMap = let - countMap = Map.map (CF.sizeCashFlowFrame . view _1) pMap - in - if sum (Map.elems countMap) > 0 then - DL.singleton $ WarningMsg $ "Oustanding pool cashflow hasn't been collected yet"++ show countMap - else - DL.empty - - -- run() is a recusive function loop over all actions till deal end conditions are met - --- | get bond principal and interest shortfalls from a deal -getRunResult :: Ast.Asset a => TestDeal a -> [ResultComponent] -getRunResult t = os_bn_i ++ os_bn_b -- `debug` ("Done with get result") - where - bs = viewDealAllBonds t - os_bn_b = [ BondOutstanding (L.bndName _b) (L.getCurBalance _b) (getBondBegBal t (L.bndName _b)) | _b <- bs ] -- `debug` ("B"++ show bs) - os_bn_i = [ BondOutstandingInt (L.bndName _b) (L.getTotalDueInt _b) (getBondBegBal t (L.bndName _b)) | _b <- bs ] -- `debug` ("C"++ show bs) - - --- | consolidate pool cashflow --- consolidate bond cashflow and patch factor -prepareDeal :: Ast.Asset a => S.Set ExpectReturn -> TestDeal a -> TestDeal a -prepareDeal er t@TestDeal {bonds = bndMap ,pool = poolType } - = let - consolePoolFlowFn = over CF.cashflowTxn CF.dropTailEmptyTxns - rmAssetLevelFn xs - | S.member AssetLevelFlow er = xs - | otherwise = [] - in - t {bonds = Map.map (L.patchBondFactor . L.consolStmt) bndMap - ,pool = poolType & over (_MultiPool . mapped . P.poolFutureCf . _Just ._1) consolePoolFlowFn - & over (_ResecDeal . mapped . uDealFutureCf) consolePoolFlowFn - & over (_MultiPool . mapped . P.poolFutureCf . _Just . _2 . _Just) rmAssetLevelFn - } - - -appendCollectedCF :: Ast.Asset a => Date -> TestDeal a -> Map.Map PoolId CF.PoolCashflow -> TestDeal a --- ^ append cashflow frame (consolidate by a date) into deals collected pool -appendCollectedCF d t@TestDeal { pool = pt } poolInflowMap - = let - newPt = case pt of - MultiPool poolM -> - MultiPool $ - Map.foldrWithKey - (\k (CF.CashFlowFrame st txnCollected, mAssetFlow) acc -> - let - currentStats = case view (P.poolFutureCf . _Just . _1 . CF.cashflowTxn) (acc Map.! k) of - [] -> P.poolBegStats (acc Map.! k) - txns -> fromMaybe (0,0,0,0,0,0) $ view CF.txnCumulativeStats (last txns) - balInCollected = case length txnCollected of - 0 -> 0 - _ -> view CF.tsRowBalance $ last txnCollected - txnToAppend = CF.patchCumulative currentStats [] txnCollected - -- insert aggregated pool flow - accUpdated = Map.adjust - (\_v -> case (P.futureCf _v) of - Nothing -> set P.poolFutureCf (Just (CF.CashFlowFrame st txnCollected , Nothing)) _v - Just _ -> over (P.poolFutureCf . _Just . _1 . CF.cashflowTxn) (++ txnToAppend) _v - ) - k - acc - -- insert breakdown asset flow - accUpdated' = case mAssetFlow of - Nothing -> accUpdated - Just collectedAssetFlow -> - let - appendFn Nothing = Just collectedAssetFlow - appendFn (Just cfs) - | length cfs == length collectedAssetFlow - = Just $ [ origin & over CF.cashflowTxn (++ (view CF.cashflowTxn new)) | (origin,new) <- zip cfs collectedAssetFlow ] - | length collectedAssetFlow > length cfs - = let - dummyCashFrames = replicate (length collectedAssetFlow - length cfs) CF.emptyCashflow - in - Just $ [ origin & over (CF.cashflowTxn) (++ (view CF.cashflowTxn new)) | (origin,new) <- zip (cfs++dummyCashFrames) collectedAssetFlow ] - | otherwise = error "incomping cashflow number shall greater than existing cashflow number" - in - accUpdated & ix k %~ (over (P.poolFutureCf . _Just . _2) appendFn) - in - Map.adjust - (over P.poolIssuanceStat (Map.insert RuntimeCurrentPoolBalance balInCollected)) - k accUpdated') - poolM - poolInflowMap - ResecDeal uds -> - ResecDeal $ - Map.foldrWithKey - (\k (CF.CashFlowFrame _ newTxns, _) acc-> - Map.adjust (over uDealFutureTxn (++ newTxns)) k acc) - uds - poolInflowMap - in - t {pool = newPt} -- `debug` ("after insert bal"++ show newPt) - --- ^ emtpy deal's pool cashflow -removePoolCf :: Ast.Asset a => TestDeal a -> TestDeal a -removePoolCf t@TestDeal{pool=pt} = - let - newPt = case pt of - MultiPool pm -> MultiPool $ set (mapped . P.poolFutureCf) Nothing pm - ResecDeal uds -> ResecDeal uds - in - t {pool = newPt} - - --- | run a pool of assets ,use asOfDate of Pool to cutoff cashflow yields from assets with assumptions supplied -runPool :: Ast.Asset a => P.Pool a -> Maybe AP.ApplyAssumptionType -> Maybe [RateAssumption] - -> Either String [(CF.CashFlowFrame, Map.Map CutoffFields Balance)] --- schedule cashflow just ignores the interest rate assumption -runPool (P.Pool [] (Just (cf,_)) _ asof _ _ ) Nothing _ = Right [(cf, Map.empty)] --- schedule cashflow with stress assumption -runPool (P.Pool [] (Just (CF.CashFlowFrame _ txn,_)) _ asof _ (Just dp)) (Just (AP.PoolLevel assumps)) mRates - = sequenceA [ Ast.projCashflow (ACM.ScheduleMortgageFlow asof txn dp) asof assumps mRates ] -- `debug` ("PROJ in schedule flow") - --- project contractual cashflow if nothing found in pool perf assumption --- use interest rate assumption -runPool (P.Pool as _ _ asof _ _) Nothing mRates - = do - cf <- sequenceA $ parMap rdeepseq - (\x -> Ast.calcCashflow x asof mRates) - as - return [ (x, Map.empty) | x <- cf ] --- asset cashflow with credit stress ----- By pool level -runPool (P.Pool as _ Nothing asof _ _) (Just (AP.PoolLevel assumps)) mRates - = sequenceA $ parMap rdeepseq (\x -> Ast.projCashflow x asof assumps mRates) as ----- By index -runPool (P.Pool as _ Nothing asof _ _) (Just (AP.ByIndex idxAssumps)) mRates = - let - numAssets = length as - in - do - _assumps <- traverse (AP.lookupAssumptionByIdx idxAssumps) [0..(pred numAssets)] -- `debug` ("Num assets"++ show numAssets) - sequenceA $ parMap rdeepseq (\(x, a) -> Ast.projCashflow x asof a mRates) (zip as _assumps) - ----- By Obligor -runPool (P.Pool as _ Nothing asof _ _) (Just (AP.ByObligor obligorRules)) mRates = - let - -- result cf,rules,assets - -- matchAssets:: Ast.Asset c => [Either String (CF.CashFlowFrame, Map.Map CutoffFields Balance)] -> [AP.ObligorStrategy] - -- -> [c] -> Either String [(CF.CashFlowFrame, Map.Map CutoffFields Balance)] - matchAssets [] _ [] = Right [(CF.CashFlowFrame (0,epocDate,Nothing) [], Map.empty)] - matchAssets cfs [] [] = sequenceA cfs - -- matchAssets cfs [] astList = sequenceA $ cfs ++ ((\x -> (\y -> (y, Map.empty)) <$> (Ast.calcCashflow x asof mRates)) <$> astList) - matchAssets cfs [] astList = let - poolCfs = parMap rdeepseq (\x -> Ast.calcCashflow x asof mRates) astList - poolCfs' = (\x -> (, Map.empty) <$> x) <$> poolCfs - in - sequenceA $ cfs ++ poolCfs' - matchAssets cfs (rule:rules) astList = - case rule of - AP.ObligorById ids assetPerf - -> let - idSet = S.fromList ids - (matchedAsts,unMatchedAsts) = partition - (\x -> case Ast.getObligorId x of - Just oid -> S.member oid idSet - Nothing -> False) - astList - matchedCfs = parMap rdeepseq (\x -> Ast.projCashflow x asof assetPerf mRates) matchedAsts - in - matchAssets (cfs ++ matchedCfs) rules unMatchedAsts - AP.ObligorByTag tags tagRule assetPerf -> - let - obrTags = S.fromList tags - - matchRuleFn AP.TagEq s1 s2 = s1 == s2 - matchRuleFn AP.TagSubset s1 s2 = s1 `S.isSubsetOf` s2 - matchRuleFn AP.TagSuperset s1 s2 = s2 `S.isSubsetOf` s1 - matchRuleFn AP.TagAny s1 s2 = not $ S.null $ S.intersection s1 s2 - matchRuleFn (AP.TagNot tRule) s1 s2 = not $ matchRuleFn tRule s1 s2 - - (matchedAsts,unMatchedAsts) = partition (\x -> matchRuleFn tagRule (Ast.getObligorTags x) obrTags) astList - matchedCfs = parMap rdeepseq (\x -> Ast.projCashflow x asof assetPerf mRates) matchedAsts - in - matchAssets (cfs ++ matchedCfs) rules unMatchedAsts - - AP.ObligorByField fieldRules assetPerf -> - let - matchRuleFn (AP.FieldIn fv fvals) Nothing = False - matchRuleFn (AP.FieldIn fv fvals) (Just fm) = case Map.lookup fv fm of - Just (Left v) -> v `elem` fvals - Nothing -> False - matchRuleFn (AP.FieldCmp fv cmp dv) (Just fm) = case Map.lookup fv fm of - Just (Right v) -> case cmp of - G -> v > dv - L -> v < dv - GE -> v >= dv - LE -> v <= dv - Nothing -> False - matchRuleFn (AP.FieldInRange fv rt dv1 dv2) (Just fm) = - case Map.lookup fv fm of - Just (Right v) -> case rt of - II -> v <= dv2 && v >= dv1 - IE -> v <= dv2 && v > dv1 - EI -> v < dv2 && v >= dv1 - EE -> v < dv2 && v > dv1 - _ -> False - Nothing -> False - matchRuleFn (AP.FieldNot fRule) fm = not $ matchRuleFn fRule fm - - matchRulesFn fs fm = all (`matchRuleFn` fm) fs - - (matchedAsts,unMatchedAsts) = partition (matchRulesFn fieldRules . Ast.getObligorFields) astList - matchedCfs = parMap rdeepseq (\x -> Ast.projCashflow x asof assetPerf mRates) matchedAsts - in - matchAssets (cfs ++ matchedCfs) rules unMatchedAsts - AP.ObligorByDefault assetPerf -> - matchAssets - (cfs ++ (parMap rdeepseq (\x -> Ast.projCashflow x asof assetPerf mRates) astList)) - [] - [] - in - matchAssets [] obligorRules as - - - --- safe net to catch other cases -runPool _a _b _c = Left $ "[Run Pool]: Failed to match" ++ show _a ++ show _b ++ show _c - - --- ^ patch issuance balance for PreClosing Deal -patchIssuanceBalance :: Ast.Asset a => DealStatus -> Map.Map PoolId Balance -> PoolType a -> PoolType a --- patchIssuanceBalance (Warehousing _) balM pt = patchIssuanceBalance (PreClosing Amortizing) balM pt -patchIssuanceBalance (PreClosing _ ) balM pt = - case pt of - 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 - -patchIssuanceBalance _ bal p = p -- `debug` ("NO patching ?") - - -patchScheduleFlow :: Ast.Asset a => Map.Map PoolId CF.PoolCashflow -> PoolType a -> PoolType a -patchScheduleFlow flowM pt = - case pt of - 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 (MultiPool pM) - = MultiPool $ - Map.mapWithKey - (\k p -> over P.poolIssuanceStat - (Map.insert RuntimeCurrentPoolBalance (Map.findWithDefault 0.0 k balMap)) - p) - pM - -patchRuntimeBal balMap pt = pt - - -runPoolType :: Ast.Asset a => Bool -> PoolType a -> Maybe AP.ApplyAssumptionType - -> Maybe AP.NonPerfAssumption -> Either String (Map.Map PoolId CF.PoolCashflow) - -runPoolType flag (MultiPool pm) (Just poolAssumpType) mNonPerfAssump - = let - rateAssump = AP.interest =<< mNonPerfAssump - calcPoolCashflow (AP.ByName assumpMap) pid v = runPool v (AP.PoolLevel <$> Map.lookup pid assumpMap) rateAssump - calcPoolCashflow (AP.ByPoolId assumpMap) pid v = runPool v (Map.lookup pid assumpMap) rateAssump - calcPoolCashflow poolAssump pid v = runPool v (Just poolAssump) rateAssump - in - sequenceA $ - Map.mapWithKey - (\k v -> - let - poolBegStats = P.issuanceStat v - in - do - assetCfs <- calcPoolCashflow poolAssumpType k v - let (poolCf,_) = P.aggPool poolBegStats assetCfs - return (poolCf, if flag then - Just $ fst <$> assetCfs - else - Nothing)) - pm - -runPoolType flag (MultiPool pm) mAssumps mNonPerfAssump - = sequenceA $ - Map.map (\p -> - do - assetFlows <- runPool p mAssumps (AP.interest =<< mNonPerfAssump) - let (poolCf, poolStatMap) = P.aggPool (P.issuanceStat p) assetFlows - return (poolCf, if flag then - Just $ fst <$> assetFlows - else - Nothing)) - pm - -runPoolType flag (ResecDeal dm) mAssumps mNonPerfAssump - = - let - assumpMap = Map.mapWithKey (\_ (UnderlyingDeal uDeal _ _ _) -> - let - dName = name uDeal -- `debug` ("Getting name of underlying deal:"++ (name uDeal)) - mAssump = case mAssumps of - Just (AP.ByDealName assumpMap) -> Map.lookup dName assumpMap - _ -> Nothing - in - (uDeal, mAssump)) - dm - ranMap = Map.mapWithKey (\(DealBondFlow dn bn sd pct) (uDeal, mAssump) -> - let - (poolAssump,dealAssump) = case mAssump of - Nothing -> (Nothing, AP.NonPerfAssumption Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) - Just (_poolAssump, _dealAssump) -> (Just _poolAssump, _dealAssump) - in - do - (dealRunned, _, _, _,_) <- runDeal uDeal (S.fromList []) poolAssump dealAssump - let bondFlow = cutBy Inc Future sd $ concat $ Map.elems $ Map.map (DL.toList . Stmt.getTxns) $ getBondStmtByName dealRunned (Just [bn]) - let bondFlowRated = (\(BondTxn d b i p r c di dioi f t) -> CF.BondFlow d b p i) <$> Stmt.scaleByFactor pct bondFlow - return (CF.CashFlowFrame (0,sd,Nothing) bondFlowRated, Nothing)) - assumpMap - in - sequenceA ranMap - - -getInits :: Ast.Asset a => S.Set ExpectReturn -> TestDeal a -> Maybe AP.ApplyAssumptionType -> Maybe AP.NonPerfAssumption - -> Either String (TestDeal a,[ActionOnDate], Map.Map PoolId CF.PoolCashflow, Map.Map PoolId CF.PoolCashflow) -getInits er t@TestDeal{fees=feeMap,pool=thePool,status=status,bonds=bndMap,stats=_stats} mAssumps mNonPerfAssump = - let - expandInspect sd ed (AP.InspectPt dp ds) = [ InspectDS _d [ds] | _d <- genSerialDatesTill2 II sd dp ed ] - expandInspect sd ed (AP.InspectRpt dp dss) = [ InspectDS _d dss | _d <- genSerialDatesTill2 II sd dp ed ] - in - do - (startDate,closingDate,firstPayDate,pActionDates,bActionDates,endDate,custWdates) <- populateDealDates (dates t) status - - let intEarnDates = A.buildEarnIntAction (Map.elems (accounts t)) endDate [] - let intAccRateResetDates = (A.buildRateResetDates endDate) <$> (Map.elems (accounts t)) - let iAccIntDates = [ EarnAccInt _d accName | (accName,accIntDates) <- intEarnDates , _d <- accIntDates ] - let iAccRateResetDates = concat [ [ResetAccRate _d accName | _d <- _ds] | rst@(Just (accName, _ds)) <- intAccRateResetDates, isJust rst ] - - --fee accrue dates - let _feeAccrueDates = F.buildFeeAccrueAction (Map.elems feeMap) endDate [] - let feeAccrueDates = [ AccrueFee _d _feeName | (_feeName,feeAccureDates) <- _feeAccrueDates , _d <- feeAccureDates ] - --liquidation facility - let liqResetDates = case liqProvider t of - Nothing -> [] - Just mLiqProvider -> - let - _liqResetDates = CE.buildLiqResetAction (Map.elems mLiqProvider) endDate [] - _liqRateResetDates = CE.buildLiqRateResetAction (Map.elems mLiqProvider) endDate [] - in - [ ResetLiqProvider _d _liqName |(_liqName,__liqResetDates) <- _liqResetDates , _d <- __liqResetDates ] - ++ - [ ResetLiqProviderRate _d _liqName |(_liqName,__liqResetDates) <- _liqRateResetDates , _d <- __liqResetDates ] - --inspect dates - let inspectDates = case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.inspectOn = Just inspectList } -> concatMap (expandInspect startDate endDate) inspectList - _ -> [] - - let financialRptDates = case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.buildFinancialReport= Just dp } - -> let - (s:_ds) = genSerialDatesTill2 II startDate dp endDate - in - [ BuildReport _sd _ed | (_sd,_ed) <- zip (s:_ds) _ds ] -- `debug` ("ds"++ show _ds) - _ -> [] - - let irUpdateSwapDates = case rateSwap t of - Nothing -> [] - Just rsm -> Map.elems $ Map.mapWithKey - (\k x -> let - resetDs = genSerialDatesTill2 EE (HE.rsStartDate x) (HE.rsUpdateDates x) endDate - in - flip CalcIRSwap k <$> resetDs) - rsm - let irSettleSwapDates = case rateSwap t of - Nothing -> [] - Just rsm -> Map.elems $ Map.mapWithKey - (\k x@HE.RateSwap{ HE.rsSettleDates = sDates} -> - case sDates of - Nothing -> [] - Just (sdp,_) -> - let - resetDs = genSerialDatesTill2 EE (HE.rsStartDate x) sdp endDate - in - flip SettleIRSwap k <$> resetDs) - rsm - let rateCapSettleDates = case rateCap t of - Nothing -> [] - Just rcM -> Map.elems $ Map.mapWithKey - (\k x -> let - resetDs = genSerialDatesTill2 EE (HE.rcStartDate x) (HE.rcSettleDates x) endDate - in - flip AccrueCapRate k <$> resetDs) - rcM - -- bond rate resets - let bndRateResets = let - bndWithDate = Map.toList $ Map.map - (\b -> L.buildRateResetDates b closingDate endDate) - bndMap - in - [ ResetBondRate bdate bn | (bn, bdates) <- bndWithDate - , bdate <- bdates ] - - -- bond step ups events - let bndStepUpDates = let - bndWithDate = Map.toList $ Map.map - (\b -> L.buildStepUpDates b closingDate endDate) - bndMap - in - [ StepUpBondRate bdate bn | (bn, bdates) <- bndWithDate , bdate <- bdates ] - - -- mannual triggers - let mannualTrigger = case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.fireTrigger = Just evts} -> [ FireTrigger d cycle n | (d,cycle,n) <- evts] - _ -> [] - - -- make whole assumption - let makeWholeDate = case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.makeWholeWhen = Just (_d,_s,_t)} -> [MakeWhole _d _s _t] - _ -> [] - - -- issue bonds in the future - let bondIssuePlan = case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.issueBondSchedule = Just bndPlan} - -> [ IssueBond _d mPre bGroupName accName b mBal mRate | TsPoint _d (AP.IssueBondEvent mPre bGroupName accName b mBal mRate) <- bndPlan] - ++ [FundBond _d mPre bName accName amount | TsPoint _d (AP.FundingBondEvent mPre bName accName amount) <- bndPlan] - _ -> [] - - -- refinance bonds in the future - let bondRefiPlan = case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.refinance = Just bndPlan} - -> [ RefiBondRate _d accName bName iInfo | TsPoint _d (AP.RefiRate accName bName iInfo) <- bndPlan] - ++ [ RefiBond _d accName bnd | TsPoint _d (AP.RefiBond accName bnd) <- bndPlan] - - _ -> [] - - let extractTestDates (AP.CallOnDates dp _) = [TestCall x | x <- genSerialDatesTill2 EE startDate dp endDate ] - let extractTestDates _ = [] - -- extractTestDates (AP.CallOptions opts) = concat [ extractTestDates opt | opt <- opts ] - -- call test dates - let callDates = case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.callWhen = Just callOpts} - -> concat [ extractTestDates callOpt | callOpt <- callOpts ] - _ -> [] - let stopTestDates = case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.stopRunBy = Just (AP.StopByPre dp pres)} - -> [StopRunTest d pres | d <- genSerialDatesTill2 EI startDate dp endDate] - _ -> [] - let allActionDates = let - __actionDates = let - a = concat [bActionDates,pActionDates,custWdates,iAccIntDates,makeWholeDate - ,feeAccrueDates,liqResetDates,mannualTrigger,concat rateCapSettleDates - ,concat irUpdateSwapDates, concat irSettleSwapDates ,inspectDates, bndRateResets,financialRptDates, stopTestDates - ,bondIssuePlan,bondRefiPlan,callDates, iAccRateResetDates - ,bndStepUpDates] - in - case (dates t,status) of - (PreClosingDates {}, PreClosing _) -> sortBy sortActionOnDate $ DealClosed closingDate:a - _ -> sortBy sortActionOnDate a - _actionDates = __actionDates++[HitStatedMaturity endDate] - in - case mNonPerfAssump of - Just AP.NonPerfAssumption{AP.stopRunBy = Just (AP.StopByDate d)} -> cutBy Exc Past d __actionDates ++ [StopRunFlag d] - _ -> _actionDates - - let newFeeMap = case mNonPerfAssump of - Nothing -> feeMap - Just AP.NonPerfAssumption{AP.projectedExpense = Nothing } -> feeMap - Just AP.NonPerfAssumption{AP.projectedExpense = Just pairs } - -> foldr (\(feeName,feeFlow) accM -> Map.adjust (\v -> v {F.feeType = F.FeeFlow feeFlow}) feeName accM) feeMap pairs - pCfM <- runPoolType True thePool mAssumps mNonPerfAssump - pScheduleCfM <- runPoolType True thePool Nothing mNonPerfAssump - let aggDates = getDates pActionDates - let pCollectionCfAfterCutoff = Map.map - (\(pCf, mAssetFlow) -> - let - pCf' = CF.cutoffCashflow startDate aggDates pCf - in - (pCf' ,(\xs -> [ CF.cutoffCashflow startDate aggDates x | x <- xs ] ) <$> mAssetFlow) - ) - pCfM - - -- let pTxnOfSpv = Map.map (\((CF.CashFlowFrame _ txns, pstats), mAssetFlow) -> cutBy Inc Future startDate txns) pScheduleCfM - -- let pAggCfM = Map.map - -- (\case - -- [] -> [] - -- (x:xs) -> buildBegTsRow startDate x:x:xs) - -- pTxnOfSpv - -- let pUnstressedAfterCutoff = Map.map (CF.CashFlowFrame (0,startDate,Nothing)) pAggCfM - let pUnstressedAfterCutoff = Map.map - (\(pCf, mAssetFlow) -> - let - pCf' = CF.cutoffCashflow startDate aggDates pCf - in - (pCf' - ,(\xs -> [ CF.cutoffCashflow startDate aggDates x | x <- xs ]) <$> mAssetFlow) - ) - pScheduleCfM - - let poolWithSchedule = patchScheduleFlow pUnstressedAfterCutoff thePool -- `debug` ("D") - let poolWithIssuanceBalance = patchIssuanceBalance - status - ((\(_pflow,_) -> CF.getBegBalCashFlowFrame _pflow) <$> pCollectionCfAfterCutoff) - poolWithSchedule - let poolWithRunPoolBalance = patchRuntimeBal - (Map.map (\(CF.CashFlowFrame (b,_,_) _,_) -> b) pCollectionCfAfterCutoff) - poolWithIssuanceBalance - - let newStat = if (isPreClosing t) then - _stats & (over _4) (`Map.union` (Map.fromList [(BondPaidPeriod,0),(PoolCollectedPeriod,0)])) - else - _stats - return (t {fees = newFeeMap , pool = poolWithRunPoolBalance , stats = newStat} - , allActionDates - , pCollectionCfAfterCutoff - , pUnstressedAfterCutoff) - --- ^ UI translation : to read pool cash -readProceeds :: PoolSource -> CF.TsRow -> Either String Balance -readProceeds CollectedInterest x = Right $ CF.mflowInterest x -readProceeds CollectedPrincipal x = Right $ CF.mflowPrincipal x -readProceeds CollectedRecoveries x = Right $ CF.mflowRecovery x -readProceeds CollectedPrepayment x = Right $ CF.mflowPrepayment x -readProceeds CollectedRental x = Right $ CF.mflowRental x -readProceeds CollectedPrepaymentPenalty x = Right $ CF.mflowPrepaymentPenalty x -readProceeds CollectedCash x = Right $ CF.tsTotalCash x -readProceeds CollectedFeePaid x = Right $ CF.mflowFeePaid x -readProceeds a _ = Left $ " Failed to find pool cashflow field from pool cashflow rule "++show a - - -extractTxnsFromFlowFrameMap :: Maybe [PoolId] -> Map.Map PoolId CF.PoolCashflow -> [CF.TsRow] -extractTxnsFromFlowFrameMap mPids pflowMap = - let - extractTxns :: Map.Map PoolId CF.PoolCashflow -> [CF.TsRow] - extractTxns m = concat $ (view (_1 . CF.cashflowTxn)) <$> Map.elems m - in - case mPids of - Nothing -> extractTxns pflowMap - Just pids -> extractTxns $ Map.filterWithKey (\k _ -> k `elem` pids) pflowMap - --- ^ deposit cash to account by collection rule -depositInflow :: Date -> W.CollectionRule -> Map.Map PoolId CF.PoolCashflow -> Map.Map AccountName A.Account -> Either String (Map.Map AccountName A.Account) -depositInflow d (W.Collect mPids s an) pFlowMap amap - = do - amts <- sequenceA $ readProceeds s <$> txns - let amt = sum amts - return $ Map.adjust (A.deposit amt d (PoolInflow mPids s)) an amap - where - txns = extractTxnsFromFlowFrameMap mPids pFlowMap - - -depositInflow d (W.CollectByPct mPids s splitRules) pFlowMap amap --TODO need to check 100% - = do - amts <- sequenceA $ readProceeds s <$> txns - let amt = sum amts - let amtsToAccs = [ (an, mulBR amt splitRate) | (splitRate, an) <- splitRules] - return $ - foldr - (\(accName,accAmt) accM -> - Map.adjust (A.deposit accAmt d (PoolInflow mPids s)) accName accM) - amap - amtsToAccs - where - txns = extractTxnsFromFlowFrameMap mPids pFlowMap - --- ^ deposit cash to account by pool map CF and rules -depositPoolFlow :: [W.CollectionRule] -> Date -> Map.Map PoolId CF.PoolCashflow -> Map.Map String A.Account -> Either String (Map.Map String A.Account) -depositPoolFlow rules d pFlowMap amap - -- = foldr (\rule acc -> depositInflow d rule pFlowMap acc) amap rules - = foldM (\acc rule -> depositInflow d rule pFlowMap acc) amap rules +module Deal (run,getInits,runDeal,ExpectReturn(..) + ,performAction + ,populateDealDates + ,calcTargetAmount,updateLiqProvider + ,projAssetUnion,priceAssetUnion + ,removePoolCf,runPoolType,PoolType + ,ActionOnDate(..),DateDesp(..) + ,changeDealStatus + ) where + +import Control.Parallel.Strategies +import qualified Accounts as A +import qualified Ledger as LD +import qualified Asset as Ast +import qualified Pool as P +import qualified Expense as F +import qualified Liability as L +import qualified CreditEnhancement as CE +import qualified Analytics +import qualified Waterfall as W +import qualified Cashflow as CF +import qualified Assumptions as AP +import qualified Reports as Rpt +import qualified AssetClass.AssetBase as ACM +import AssetClass.Mortgage +import AssetClass.Lease +import AssetClass.Loan +import AssetClass.Installment +import AssetClass.MixedAsset + +import qualified Call as C +import qualified InterestRate as IR +import Deal.DealBase +import Deal.DealQuery +import Deal.DealAction +import Deal.DealCollection +import Deal.DealRun +import qualified Deal.DealValidation as V +import Stmt +import Lib +import Util +import DateUtil +import Types +import Revolving +import Triggers + +import qualified Data.Map as Map hiding (mapEither) +import qualified Data.Time as T +import qualified Data.Set as S +import qualified Control.Lens as LS +import Data.List +import qualified Data.DList as DL +import Data.Fixed +import Data.Time.Clock +import Data.Maybe +import Data.Either +import Data.Aeson hiding (json) +-- import qualified Data.Aeson.Encode.Pretty as Pretty +import Language.Haskell.TH +import Data.Aeson.TH +import Data.Aeson.Types +import GHC.Generics +import Control.Monad +import Control.Monad.Writer +import Control.Monad.Loops (allM,anyM) +import Control.Applicative (liftA2) + +import Debug.Trace +import Cashflow (buildBegTsRow) +import Assumptions (NonPerfAssumption(NonPerfAssumption),lookupRate0) +import Asset () +import Pool (issuanceStat) +import qualified Types as P +import Control.Lens hiding (element) +import Control.Lens.TH +import Data.Either.Utils +import InterestRate (calcInt) +import Liability (getDayCountFromInfo,getTxnRate) +import Hedge (RateCap(..),RateSwapBase(..),RateSwap(rsRefBalance)) +import qualified Hedge as HE + +debug = flip trace + + +updateSrtRate :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> HE.SRT -> Either String HE.SRT +updateSrtRate t d ras srt@HE.SRT{HE.srtPremiumType = rt} + = do + r <- AP.applyFloatRate2 rt d ras + return srt { HE.srtPremiumRate = r } + + +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 } + = do + newBal <- case st of + HE.SrtByEndDay ds dp -> queryCompound t d (patchDateToStats d ds) + 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} + + +-- ^ 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 -> (< 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 + C.Or xs -> anyM (testCall t d) xs + -- 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 + _ -> Left ("failed to find call options"++ show opt) + + +queryTrigger :: Ast.Asset a => TestDeal a -> DealCycle -> [Trigger] +queryTrigger t@TestDeal{ triggers = trgs } wt + = case trgs of + Nothing -> [] + Just _trgs -> maybe [] Map.elems $ Map.lookup wt _trgs + +-- ^ test triggers in the deal and add a log if deal status changed +changeDealStatus:: Ast.Asset a => (Date,String)-> DealStatus -> TestDeal a -> (Maybe ResultComponent, TestDeal a) +changeDealStatus _ _ t@TestDeal{status=Ended _} = (Nothing, t) +changeDealStatus (d,why) newSt t@TestDeal{status=oldSt} + | newSt /= oldSt = (Just (DealStatusChangeTo d oldSt newSt why), t {status=newSt}) + | otherwise = (Just (DealStatusChangeTo d oldSt newSt ("Duplicate status change: "++why)), t) + + +-- reserved for future used +data ExpectReturn = DealLogs + | AssetLevelFlow + deriving (Show,Generic,Ord,Eq) + + +-- priceBondIrr :: AP.IrrType -> [Txn] -> Either String (Rate, [(Date,Balance)]) +priceBondIrr :: AP.IrrType -> [Txn] -> Either String (Rate, [Txn]) +-- No projected transaction, use history cashflow only +priceBondIrr AP.BuyBond {} [] = Left "No transaction to buy the bond" +priceBondIrr (AP.HoldingBond historyCash _ _) [] + = let + (ds,vs) = unzip historyCash + txns' = [ BondTxn d 0 0 0 0 v 0 0 Nothing Types.Empty | (d,v) <- historyCash ] + in + do + irr <- Analytics.calcIRR ds vs + return (irr, txns') +-- Projected transaction and hold to maturity +priceBondIrr (AP.HoldingBond historyCash holding Nothing) txns + = let + begBal = (getTxnBegBalance . head) txns + holdingPct = divideBB holding begBal + bProjectedTxn = scaleTxn holdingPct <$> txns -- `debug` ("holding pct"++ show holding ++"/" ++ show begBal ++" : " ++ show holdingPct) + (ds,vs) = unzip historyCash + (ds2,vs2) = (getDate <$> bProjectedTxn, getTxnAmt <$> bProjectedTxn) -- `debug` ("projected txn position"++ show bProjectedTxn) + + txns' = [ BondTxn d 0 0 0 0 v 0 0 Nothing Types.Empty | (d,v) <- historyCash ] + in + do + irr <- Analytics.calcIRR (ds++ds2) (vs++vs2) -- `debug` ("projected holding"++ show (ds2,vs2)) + return (irr, txns' ++ bProjectedTxn) + +-- TODO: need to use DC from bond +-- Projected transaction and sell at a Date +priceBondIrr (AP.HoldingBond historyCash holding (Just (sellDate, sellPricingMethod))) txns + = let + -- history cash + (ds,vs) = unzip historyCash + txns' = [ BondTxn d 0 0 0 0 v 0 0 Nothing Types.Empty | (d,v) <- historyCash ] + + begBal = (getTxnBegBalance . head) txns + holdingPct = toRational $ holding / begBal + -- assume cashflow of sell date belongs to seller(owner) + (bProjectedTxn',futureFlow') = splitByDate txns sellDate EqToLeft + (bProjectedTxn,futureFlow) = ((scaleTxn holdingPct) <$> bProjectedTxn',(scaleTxn holdingPct) <$> futureFlow') + -- projected cash + (ds2,vs2) = (getDate <$> bProjectedTxn, getTxnAmt <$> bProjectedTxn) + -- accrued interest + accruedInt = L.backoutAccruedInt sellDate epocDate (bProjectedTxn++futureFlow) + (ds3,vs3) = (sellDate, accruedInt) -- `debug` ("accrued interest"++ show (accruedInt,sellDate)) + -- sell price + sellPrice = case sellPricingMethod of + BondBalanceFactor f -> case bProjectedTxn of + [] -> mulBR begBal (f * holdingPct) + _txns -> mulBR (getTxnBalance (last _txns)) f + (ds4,vs4) = (sellDate, sellPrice) -- `debug` ("sale price, date"++ show (sellPrice,sellDate)) + in + do + irr <- Analytics.calcIRR (ds++ds2++[ds3]++[ds4]) (vs++vs2++[vs3]++[vs4]) -- `debug` ("vs:"++ show vs++ "vs2:"++ show vs2++ "vs3:"++ show vs3++ "vs4:"++ show vs4 ++">>> ds "++ show ds++ "ds2"++ show ds2++ "ds3"++ show ds3++ "ds4"++ show ds4) + return (irr, txns'++ bProjectedTxn++ [BondTxn sellDate 0 vs3 sellPrice 0 (sellPrice+vs3) 0 0 Nothing Types.Empty]) + +-- Buy and hold to maturity +priceBondIrr (AP.BuyBond dateToBuy bPricingMethod (AP.ByCash cash) Nothing) txns + | null futureFlow' = Left "No transaction to buy bond" + | otherwise + = let + -- balance of bond on buy date + nextTxn = head futureFlow' + balAsBuyDate = getTxnBegBalance nextTxn + buyPrice = case bPricingMethod of + BondBalanceFactor f -> mulBR balAsBuyDate f + buyPaidOut = min buyPrice cash + buyPct = divideBB buyPaidOut buyPrice + boughtTxns = scaleTxn buyPct <$> futureFlow' + -- buy price (including accrued interest) + + accuredInt = let + --TODO what about interest over interest + accruedInt' = calcInt balAsBuyDate dateToBuy (getDate nextTxn) (getTxnRate nextTxn) DC_ACT_365F + x = nextTxn + totalInt' = (fromMaybe 0) <$> [(preview (_BondTxn . _3 ) x), (preview (_BondTxn . _7 ) x), (preview (_BondTxn . _8 ) x)] + in + sum(totalInt') - accruedInt' + + (ds1, vs1) = (dateToBuy, negate (buyPaidOut + accuredInt)) + (ds2, vs2) = (getDate <$> futureFlow', getTxnAmt <$> boughtTxns) + in + do + irr <- Analytics.calcIRR (ds1:ds2) (vs1:vs2) + return (irr, (BondTxn dateToBuy 0 (negate accuredInt) (negate buyPaidOut) 0 vs1 0 0 Nothing Types.Empty):boughtTxns) + where + -- assume cashflow of buy date belongs to seller(owner) + (bProjectedTxn',futureFlow') = splitByDate txns dateToBuy EqToLeft + + +priceBonds :: Ast.Asset a => TestDeal a -> AP.BondPricingInput -> Either String (Map.Map String PriceResult) +-- Price bond via discount future cashflow +priceBonds t (AP.DiscountCurve d dc) = Right $ Map.map (L.priceBond d dc) (viewBondsInMap t) +-- Run Z-Spread +priceBonds t@TestDeal {bonds = bndMap} (AP.RunZSpread curve bondPrices) + = sequenceA $ + Map.mapWithKey + (\bn (pd,price)-> ZSpread <$> L.calcZspread (price,pd) (bndMap Map.! bn) curve) + bondPrices +-- Calc Irr of bonds +priceBonds t@TestDeal {bonds = bndMap} (AP.IrrInput bMapInput) + = let + -- Date + d = getNextBondPayDate t + -- get projected bond txn + projectedTxns xs = snd $ splitByDate xs d EqToRight + -- (Maybe Bond,IrrType) + bndMap' = Map.mapWithKey (\k v -> (getBondByName t True k, v)) bMapInput + -- (Rate, [(date, cash)]) + bndMap'' = Map.mapWithKey (\bName (Just b, v) -> + do + let _irrTxns = projectedTxns (getAllTxns b) + (_irr, flows) <- priceBondIrr v _irrTxns + return (IrrResult (fromRational _irr) flows)) + bndMap' + in + sequenceA bndMap'' + + + +-- , + +runDeal :: Ast.Asset a => TestDeal a -> S.Set ExpectReturn -> Maybe AP.ApplyAssumptionType-> AP.NonPerfAssumption + -> Either String (TestDeal a + , Map.Map PoolId CF.CashFlowFrame + , [ResultComponent] + , Map.Map String PriceResult + , Map.Map PoolId CF.PoolCashflow) +runDeal t er perfAssumps nonPerfAssumps@AP.NonPerfAssumption{AP.callWhen = opts ,AP.pricing = mPricing ,AP.revolving = mRevolving ,AP.interest = mInterest} + | not runFlag = Left $ intercalate ";" $ show <$> valLogs + | otherwise + = do + (newT, ads, pcf, unStressPcf) <- getInits er t perfAssumps (Just nonPerfAssumps) + (_finalDeal, logs, osPoolFlow) <- run (removePoolCf newT) + pcf + (Just ads) + mInterest + (AP.readCallOptions <$> opts) + mRevolvingCtx + DL.empty + -- prepare deal with expected return + let finalDeal = prepareDeal er _finalDeal + -- extract pool cash collected to deal + let poolFlowUsedNoEmpty = Map.map + (over CF.cashflowTxn CF.dropTailEmptyTxns) + (getAllCollectedFrame finalDeal Nothing) + let poolFlowUnUsed = osPoolFlow & mapped . _1 . CF.cashflowTxn %~ CF.dropTailEmptyTxns + & mapped . _2 . _Just . each . CF.cashflowTxn %~ CF.dropTailEmptyTxns + bndPricing <- case mPricing of + (Just p) -> priceBonds finalDeal p + Nothing -> Right Map.empty + return (finalDeal + , poolFlowUsedNoEmpty + , getRunResult finalDeal ++ V.validateRun finalDeal ++ DL.toList (DL.append logs (unCollectedPoolFlowWarning poolFlowUnUsed)) + , bndPricing + , poolFlowUnUsed + ) -- `debug` ("run deal done with pool" ++ show poolFlowUsedNoEmpty) + where + (runFlag, valLogs) = V.validateReq t nonPerfAssumps + -- getinits() will get (new deal snapshot, actions, pool cashflows, unstressed pool cashflow) + -- extract Revolving Assumption + mRevolvingCtx = case mRevolving of + Nothing -> Nothing + Just (AP.AvailableAssets rp rperf) -> Just (Map.fromList [("Consol", (rp, rperf))]) + Just (AP.AvailableAssetsBy rMap) -> Just rMap + unCollectedPoolFlowWarning pMap = let + countMap = Map.map (CF.sizeCashFlowFrame . view _1) pMap + in + if sum (Map.elems countMap) > 0 then + DL.singleton $ WarningMsg $ "Oustanding pool cashflow hasn't been collected yet"++ show countMap + else + DL.empty + + -- run() is a recusive function loop over all actions till deal end conditions are met + +-- | get bond principal and interest shortfalls from a deal +getRunResult :: Ast.Asset a => TestDeal a -> [ResultComponent] +getRunResult t = os_bn_i ++ os_bn_b -- `debug` ("Done with get result") + where + bs = viewDealAllBonds t + os_bn_b = [ BondOutstanding (L.bndName _b) (L.getCurBalance _b) (getBondBegBal t (L.bndName _b)) | _b <- bs ] -- `debug` ("B"++ show bs) + os_bn_i = [ BondOutstandingInt (L.bndName _b) (L.getTotalDueInt _b) (getBondBegBal t (L.bndName _b)) | _b <- bs ] -- `debug` ("C"++ show bs) + + +-- | consolidate pool cashflow +-- consolidate bond cashflow and patch factor +prepareDeal :: Ast.Asset a => S.Set ExpectReturn -> TestDeal a -> TestDeal a +prepareDeal er t@TestDeal {bonds = bndMap ,pool = poolType } + = let + consolePoolFlowFn = over CF.cashflowTxn CF.dropTailEmptyTxns + rmAssetLevelFn xs + | S.member AssetLevelFlow er = xs + | otherwise = [] + in + t {bonds = Map.map (L.patchBondFactor . L.consolStmt) bndMap + ,pool = poolType & over (_MultiPool . mapped . P.poolFutureCf . _Just ._1) consolePoolFlowFn + & over (_ResecDeal . mapped . uDealFutureCf . _Just) consolePoolFlowFn + & over (_MultiPool . mapped . P.poolFutureCf . _Just . _2 . _Just) rmAssetLevelFn + } + + +-- ^ emtpy deal's pool cashflow +removePoolCf :: Ast.Asset a => TestDeal a -> TestDeal a +removePoolCf t@TestDeal{pool=pt} = + let + newPt = case pt of + MultiPool pm -> MultiPool $ set (mapped . P.poolFutureCf) Nothing pm + ResecDeal uds -> ResecDeal uds + in + t {pool = newPt} + +runPoolType :: Ast.Asset a => Bool -> PoolType a -> Maybe AP.ApplyAssumptionType + -> Maybe AP.NonPerfAssumption -> Either String (Map.Map PoolId CF.PoolCashflow) + +runPoolType flag (MultiPool pm) (Just poolAssumpType) mNonPerfAssump + = let + rateAssump = AP.interest =<< mNonPerfAssump + calcPoolCashflow (AP.ByName assumpMap) pid v = P.runPool v (AP.PoolLevel <$> Map.lookup pid assumpMap) rateAssump + calcPoolCashflow (AP.ByPoolId assumpMap) pid v = P.runPool v (Map.lookup pid assumpMap) rateAssump + calcPoolCashflow poolAssump pid v = P.runPool v (Just poolAssump) rateAssump + in + sequenceA $ + Map.mapWithKey + (\k v -> + let + poolBegStats = P.issuanceStat v + in + do + assetCfs <- calcPoolCashflow poolAssumpType k v + let (poolCf,_) = P.aggPool poolBegStats assetCfs + return (poolCf, if flag then + Just $ fst <$> assetCfs + else + Nothing)) + pm + +runPoolType flag (MultiPool pm) mAssumps mNonPerfAssump + = sequenceA $ + Map.map (\p -> + do + assetFlows <- P.runPool p mAssumps (AP.interest =<< mNonPerfAssump) + let (poolCf, poolStatMap) = P.aggPool (P.issuanceStat p) assetFlows + return (poolCf, if flag then + Just $ fst <$> assetFlows + else + Nothing)) + pm + +runPoolType flag (ResecDeal dm) mAssumps mNonPerfAssump + = + let + assumpMap = Map.mapWithKey (\_ (UnderlyingDeal uDeal _ _ _) -> + let + dName = name uDeal -- `debug` ("Getting name of underlying deal:"++ (name uDeal)) + mAssump = case mAssumps of + Just (AP.ByDealName assumpMap) -> Map.lookup dName assumpMap + _ -> Nothing + in + (uDeal, mAssump)) + dm + ranMap = Map.mapWithKey (\(DealBondFlow dn bn sd pct) (uDeal, mAssump) -> + let + (poolAssump,dealAssump) = case mAssump of + Nothing -> (Nothing, AP.NonPerfAssumption Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) + Just (_poolAssump, _dealAssump) -> (Just _poolAssump, _dealAssump) + in + do + (dealRunned, _, _, _,_) <- runDeal uDeal (S.fromList []) poolAssump dealAssump + let bondFlow = cutBy Inc Future sd $ concat $ Map.elems $ Map.map (DL.toList . Stmt.getTxns) $ getBondStmtByName dealRunned (Just [bn]) + let bondFlowRated = (\(BondTxn d b i p r c di dioi f t) -> CF.BondFlow d b p i) <$> Stmt.scaleByFactor pct bondFlow + return (CF.CashFlowFrame (0,sd,Nothing) bondFlowRated, Nothing)) + assumpMap + in + sequenceA ranMap + + +-- ^ patch issuance balance for PreClosing Deal +patchIssuanceBalance :: Ast.Asset a => DealStatus -> Map.Map PoolId Balance -> PoolType a -> PoolType a +-- patchIssuanceBalance (Warehousing _) balM pt = patchIssuanceBalance (PreClosing Amortizing) balM pt +patchIssuanceBalance (PreClosing _ ) balM pt = + case pt of + 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 + +patchIssuanceBalance _ bal p = p -- `debug` ("NO patching ?") + + +patchScheduleFlow :: Ast.Asset a => Map.Map PoolId CF.PoolCashflow -> PoolType a -> PoolType a +patchScheduleFlow flowM pt = + case pt of + 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 (MultiPool pM) + = MultiPool $ + Map.mapWithKey + (\k p -> over P.poolIssuanceStat + (Map.insert RuntimeCurrentPoolBalance (Map.findWithDefault 0.0 k balMap)) + p) + pM + +patchRuntimeBal balMap pt = pt + + + + +getInits :: Ast.Asset a => S.Set ExpectReturn -> TestDeal a -> Maybe AP.ApplyAssumptionType -> Maybe AP.NonPerfAssumption + -> Either String (TestDeal a,[ActionOnDate], Map.Map PoolId CF.PoolCashflow, Map.Map PoolId CF.PoolCashflow) +getInits er t@TestDeal{fees=feeMap,pool=thePool,status=status,bonds=bndMap,stats=_stats} mAssumps mNonPerfAssump = + let + expandInspect sd ed (AP.InspectPt dp ds) = [ InspectDS _d [ds] | _d <- genSerialDatesTill2 II sd dp ed ] + expandInspect sd ed (AP.InspectRpt dp dss) = [ InspectDS _d dss | _d <- genSerialDatesTill2 II sd dp ed ] + in + do + (startDate,closingDate,firstPayDate,pActionDates,bActionDates,endDate,custWdates) <- populateDealDates (dates t) status + + let intEarnDates = A.buildEarnIntAction (Map.elems (accounts t)) endDate [] + let intAccRateResetDates = (A.buildRateResetDates endDate) <$> (Map.elems (accounts t)) + let iAccIntDates = [ EarnAccInt _d accName | (accName,accIntDates) <- intEarnDates , _d <- accIntDates ] + let iAccRateResetDates = concat [ [ResetAccRate _d accName | _d <- _ds] | rst@(Just (accName, _ds)) <- intAccRateResetDates, isJust rst ] + + --fee accrue dates + let _feeAccrueDates = F.buildFeeAccrueAction (Map.elems feeMap) endDate [] + let feeAccrueDates = [ AccrueFee _d _feeName | (_feeName,feeAccureDates) <- _feeAccrueDates , _d <- feeAccureDates ] + --liquidation facility + let liqResetDates = case liqProvider t of + Nothing -> [] + Just mLiqProvider -> + let + _liqResetDates = CE.buildLiqResetAction (Map.elems mLiqProvider) endDate [] + _liqRateResetDates = CE.buildLiqRateResetAction (Map.elems mLiqProvider) endDate [] + in + [ ResetLiqProvider _d _liqName |(_liqName,__liqResetDates) <- _liqResetDates , _d <- __liqResetDates ] + ++ + [ ResetLiqProviderRate _d _liqName |(_liqName,__liqResetDates) <- _liqRateResetDates , _d <- __liqResetDates ] + --inspect dates + let inspectDates = case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.inspectOn = Just inspectList } -> concatMap (expandInspect startDate endDate) inspectList + _ -> [] + + let financialRptDates = case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.buildFinancialReport= Just dp } + -> let + (s:_ds) = genSerialDatesTill2 II startDate dp endDate + in + [ BuildReport _sd _ed | (_sd,_ed) <- zip (s:_ds) _ds ] -- `debug` ("ds"++ show _ds) + _ -> [] + + let irUpdateSwapDates = case rateSwap t of + Nothing -> [] + Just rsm -> Map.elems $ Map.mapWithKey + (\k x -> let + resetDs = genSerialDatesTill2 EE (HE.rsStartDate x) (HE.rsUpdateDates x) endDate + in + flip CalcIRSwap k <$> resetDs) + rsm + let irSettleSwapDates = case rateSwap t of + Nothing -> [] + Just rsm -> Map.elems $ Map.mapWithKey + (\k x@HE.RateSwap{ HE.rsSettleDates = sDates} -> + case sDates of + Nothing -> [] + Just (sdp,_) -> + let + resetDs = genSerialDatesTill2 EE (HE.rsStartDate x) sdp endDate + in + flip SettleIRSwap k <$> resetDs) + rsm + let rateCapSettleDates = case rateCap t of + Nothing -> [] + Just rcM -> Map.elems $ Map.mapWithKey + (\k x -> let + resetDs = genSerialDatesTill2 EE (HE.rcStartDate x) (HE.rcSettleDates x) endDate + in + flip AccrueCapRate k <$> resetDs) + rcM + -- bond rate resets + let bndRateResets = let + bndWithDate = Map.toList $ Map.map + (\b -> L.buildRateResetDates b closingDate endDate) + bndMap + in + [ ResetBondRate bdate bn | (bn, bdates) <- bndWithDate + , bdate <- bdates ] + + -- bond step ups events + let bndStepUpDates = let + bndWithDate = Map.toList $ Map.map + (\b -> L.buildStepUpDates b closingDate endDate) + bndMap + in + [ StepUpBondRate bdate bn | (bn, bdates) <- bndWithDate , bdate <- bdates ] + + -- mannual triggers + let mannualTrigger = case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.fireTrigger = Just evts} -> [ FireTrigger d cycle n | (d,cycle,n) <- evts] + _ -> [] + + -- make whole assumption + let makeWholeDate = case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.makeWholeWhen = Just (_d,_s,_t)} -> [MakeWhole _d _s _t] + _ -> [] + + -- issue bonds in the future + let bondIssuePlan = case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.issueBondSchedule = Just bndPlan} + -> [ IssueBond _d mPre bGroupName accName b mBal mRate | TsPoint _d (AP.IssueBondEvent mPre bGroupName accName b mBal mRate) <- bndPlan] + ++ [FundBond _d mPre bName accName amount | TsPoint _d (AP.FundingBondEvent mPre bName accName amount) <- bndPlan] + _ -> [] + + -- refinance bonds in the future + let bondRefiPlan = case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.refinance = Just bndPlan} + -> [ RefiBondRate _d accName bName iInfo | TsPoint _d (AP.RefiRate accName bName iInfo) <- bndPlan] + ++ [ RefiBond _d accName bnd | TsPoint _d (AP.RefiBond accName bnd) <- bndPlan] + + _ -> [] + + let extractTestDates (AP.CallOnDates dp _) = [TestCall x | x <- genSerialDatesTill2 EE startDate dp endDate ] + let extractTestDates _ = [] + -- extractTestDates (AP.CallOptions opts) = concat [ extractTestDates opt | opt <- opts ] + -- call test dates + let callDates = case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.callWhen = Just callOpts} + -> concat [ extractTestDates callOpt | callOpt <- callOpts ] + _ -> [] + let stopTestDates = case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.stopRunBy = Just (AP.StopByPre dp pres)} + -> [StopRunTest d pres | d <- genSerialDatesTill2 EI startDate dp endDate] + _ -> [] + let allActionDates = let + __actionDates = let + a = concat [bActionDates,pActionDates,custWdates,iAccIntDates,makeWholeDate + ,feeAccrueDates,liqResetDates,mannualTrigger,concat rateCapSettleDates + ,concat irUpdateSwapDates, concat irSettleSwapDates ,inspectDates, bndRateResets,financialRptDates, stopTestDates + ,bondIssuePlan,bondRefiPlan,callDates, iAccRateResetDates + ,bndStepUpDates] + in + case (dates t,status) of + (PreClosingDates {}, PreClosing _) -> sortBy sortActionOnDate $ DealClosed closingDate:a + _ -> sortBy sortActionOnDate a + _actionDates = __actionDates++[HitStatedMaturity endDate] + in + case mNonPerfAssump of + Just AP.NonPerfAssumption{AP.stopRunBy = Just (AP.StopByDate d)} -> cutBy Exc Past d __actionDates ++ [StopRunFlag d] + _ -> _actionDates + + let newFeeMap = case mNonPerfAssump of + Nothing -> feeMap + Just AP.NonPerfAssumption{AP.projectedExpense = Nothing } -> feeMap + Just AP.NonPerfAssumption{AP.projectedExpense = Just pairs } + -> foldr (\(feeName,feeFlow) accM -> Map.adjust (\v -> v {F.feeType = F.FeeFlow feeFlow}) feeName accM) feeMap pairs + pCfM <- runPoolType True thePool mAssumps mNonPerfAssump + pScheduleCfM <- runPoolType True thePool Nothing mNonPerfAssump + let aggDates = getDates pActionDates + let pCollectionCfAfterCutoff = Map.map + (\(pCf, mAssetFlow) -> + let + pCf' = CF.cutoffCashflow startDate aggDates pCf + in + (pCf' ,(\xs -> [ CF.cutoffCashflow startDate aggDates x | x <- xs ] ) <$> mAssetFlow)) + pCfM + + let pUnstressedAfterCutoff = Map.map + (\(pCf, mAssetFlow) -> + let + pCf' = CF.cutoffCashflow startDate aggDates pCf + in + (pCf' + ,(\xs -> [ CF.cutoffCashflow startDate aggDates x | x <- xs ]) <$> mAssetFlow) + ) + pScheduleCfM + + let poolWithSchedule = patchScheduleFlow pUnstressedAfterCutoff thePool -- `debug` ("D") + let poolWithIssuanceBalance = patchIssuanceBalance + status + ((\(_pflow,_) -> CF.getBegBalCashFlowFrame _pflow) <$> pCollectionCfAfterCutoff) + poolWithSchedule + let poolWithRunPoolBalance = patchRuntimeBal + (Map.map (\(CF.CashFlowFrame (b,_,_) _,_) -> b) pCollectionCfAfterCutoff) + poolWithIssuanceBalance + + let newStat = if (isPreClosing t) then + _stats & (over _4) (`Map.union` (Map.fromList [(BondPaidPeriod,0),(PoolCollectedPeriod,0)])) + else + _stats + return (t {fees = newFeeMap , pool = poolWithRunPoolBalance , stats = newStat} + , allActionDates + , pCollectionCfAfterCutoff + , pUnstressedAfterCutoff) $(deriveJSON defaultOptions ''ExpectReturn) diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -1,7 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE ScopedTypeVariables #-} module Deal.DealAction (performActionWrap,performAction,calcDueFee @@ -100,15 +97,14 @@ = zip (fst <$> bndsWithDue) $ prorataFactors (snd <$> bndsWithDue) amt allocAmtToBonds theOrder amt bndsWithDue = let - sortFn = case theOrder of - W.ByName -> (\(b1,_) (b2,_) -> compare (L.bndName b1) (L.bndName b2)) - W.ByCurrentRate -> (\(b1,_) (b2,_) -> compare (L.bndRate b2) (L.bndRate b1)) - W.ByMaturity -> (\(b1@L.Bond{L.bndOriginInfo=bo1},_) (b2@L.Bond{L.bndOriginInfo=bo2},_) -> compare (L.maturityDate bo1) (L.maturityDate bo2)) - W.ByStartDate -> (\(b1@L.Bond{L.bndOriginInfo=bo1},_) (b2@L.Bond{L.bndOriginInfo=bo2},_) -> compare (L.originDate bo1) (L.originDate bo2)) - -- TODO: how to handle if now names found in the bonds - -- W.ByCustomNames names -> (\(b1,_) (b2,_) -> compare (findIndex (== (L.bndName b1)) names) (findIndex (== (L.bndName b2)) names)) - W.ByCustomNames names -> (\(b1,_) (b2,_) -> compare (elemIndex (L.bndName b1) names) (elemIndex (L.bndName b2) names)) - orderedBonds = sortBy sortFn bndsWithDue + sortFn W.ByName = (\(b1,_) (b2,_) -> compare (L.bndName b1) (L.bndName b2)) + sortFn W.ByCurrentRate = (\(b1,_) (b2,_) -> compare (L.bndRate b2) (L.bndRate b1)) + sortFn W.ByMaturity = (\(b1@L.Bond{L.bndOriginInfo=bo1},_) (b2@L.Bond{L.bndOriginInfo=bo2},_) -> compare (L.maturityDate bo1) (L.maturityDate bo2)) + sortFn W.ByStartDate = (\(b1@L.Bond{L.bndOriginInfo=bo1},_) (b2@L.Bond{L.bndOriginInfo=bo2},_) -> compare (L.originDate bo1) (L.originDate bo2)) + -- TODO: how to handle if now names found in the bonds + sortFn (W.ByCustomNames names) = (\(b1,_) (b2,_) -> compare (elemIndex (L.bndName b1) names) (elemIndex (L.bndName b2) names)) + sortFn (W.ReverseSeq orderBy) = flip (sortFn orderBy) + orderedBonds = sortBy (sortFn theOrder) bndsWithDue orderedAmt = snd <$> orderedBonds in zip diff --git a/src/Deal/DealBase.hs b/src/Deal/DealBase.hs --- a/src/Deal/DealBase.hs +++ b/src/Deal/DealBase.hs @@ -9,13 +9,13 @@ module Deal.DealBase (TestDeal(..),SPV(..),dealBonds,dealFees,dealAccounts,dealPool,PoolType(..),getIssuanceStats ,getAllAsset,getAllAssetList,getAllCollectedFrame,getLatestCollectFrame,getAllCollectedTxns ,getIssuanceStatsConsol,getAllCollectedTxnsList - ,getPoolIds,getBondByName, UnderlyingDeal(..), uDealFutureTxn,viewDealAllBonds,DateDesp(..),ActionOnDate(..) + ,getPoolIds,getBondByName, UnderlyingDeal(..),viewDealAllBonds,DateDesp(..),ActionOnDate(..) ,sortActionOnDate,dealBondGroups ,viewDealBondsByNames,poolTypePool,viewBondsInMap,bondGroupsBonds ,increaseBondPaidPeriod,increasePoolCollectedPeriod ,DealStatFields(..),getDealStatInt,isPreClosing,populateDealDates ,bondTraversal,findBondByNames,updateBondInMap - ,_MultiPool,_ResecDeal,uDealFutureCf,uDealFutureScheduleCf + ,_MultiPool,_ResecDeal,uDealFutureCf,uDealFutureScheduleCf ) where import qualified Accounts as A @@ -39,6 +39,8 @@ import Revolving import Triggers +import Deal.DealCollection (CollectionRule(..)) + import qualified Data.Map as Map import qualified Data.Time as T import qualified Data.Set as S @@ -284,7 +286,7 @@ ,bonds :: Map.Map BondName L.Bond ,pool :: PoolType a ,waterfall :: Map.Map W.ActionWhen W.DistributionSeq - ,collects :: [W.CollectionRule] + ,collects :: [CollectionRule] ,stats :: (BalDealStatMap,RDealStatMap,BDealStatMap,IDealStatMap) ,liqProvider :: Maybe (Map.Map String CE.LiqFacility) ,rateSwap :: Maybe (Map.Map String HE.RateSwap) @@ -297,36 +299,23 @@ data UnderlyingDeal a = UnderlyingDeal { deal :: TestDeal a - ,futureCf :: CF.CashFlowFrame - ,futureScheduleCf :: CF.CashFlowFrame + ,futureCf :: Maybe CF.CashFlowFrame + ,futureScheduleCf :: Maybe CF.CashFlowFrame ,issuanceStat :: Maybe (Map.Map CutoffFields Balance) } deriving (Generic,Eq,Ord,Show) -uDealFutureScheduleCf :: Ast.Asset a => Lens' (UnderlyingDeal a) CF.CashFlowFrame +uDealFutureScheduleCf :: Ast.Asset a => Lens' (UnderlyingDeal a) (Maybe CF.CashFlowFrame) uDealFutureScheduleCf = lens getter setter where getter = futureScheduleCf setter ud newCf = ud {futureScheduleCf = newCf} -uDealFutureCf :: Ast.Asset a => Lens' (UnderlyingDeal a) CF.CashFlowFrame +uDealFutureCf :: Ast.Asset a => Lens' (UnderlyingDeal a) (Maybe CF.CashFlowFrame) uDealFutureCf = lens getter setter where getter = futureCf setter ud newCf = ud {futureCf = newCf} -uDealFutureTxn :: Ast.Asset a => Lens' (UnderlyingDeal a) [CF.TsRow] -uDealFutureTxn = lens getter setter - where - getter ud = view CF.cashflowTxn $ futureCf ud - setter ud newTxn = ud {futureCf = CF.CashFlowFrame (0,toDate "19000101",Nothing) newTxn} - -- let - -- mOriginalCfFrame = futureCf ud - -- in - -- case mOriginalCfFrame of - -- - -- (CF.CashFlowFrame (begBal,begDate,mInt) txns) -> ud {futureCf = CF.CashFlowFrame (0,toDate "19000101",Nothing) newTxn } - - data PoolType a = MultiPool (Map.Map PoolId (P.Pool a)) | ResecDeal (Map.Map PoolId (UnderlyingDeal a)) deriving (Generic, Eq, Ord, Show) @@ -517,48 +506,6 @@ getter = \case ResecDeal dm -> dm setter (ResecDeal dm) newDm = ResecDeal newDm --- schedulePoolFlowLens = poolTypePool . mapped . P.futureScheduleCfLens --- schedulePoolFlowAggLens = schedulePoolFlowLens . _1 . _1 --- scheduleBondFlowLens = poolTypeUnderDeal . mapped . uDealFutureScheduleCf - - --- dealInputCashflow :: Ast.Asset a => Lens' (TestDeal a) (Map.Map PoolId CF.PoolCashflow) --- dealInputCashflow = lens getter setter --- where --- getter d = case pool d of --- MultiPool pm -> Map.map (P.futureScheduleCf) pm --- ResecDeal uds -> Map.map futureScheduleCf uds --- setter d newCfMap = case pool d of --- MultiPool pm -> --- let --- newPm = Map.mapWithKey (\k p -> set (P.poolFutureScheduleCf) (newCfMap Map.! k) p) pm --- in --- set dealPool (MultiPool newPm) d --- ResecDeal pm -> --- let --- newPm = Map.mapWithKey (\k ud ->gset uDealFutureScheduleCf (newCfMap Map.! k) ud) pm --- in --- set dealPool (ResecDeal newPm) d - --- dealCashflow :: Ast.Asset a => Lens' (TestDeal a) (Map.Map PoolId (Maybe CF.CashFlowFrame)) --- dealCashflow = lens getter setter --- where --- getter d = case pool d of --- MultiPool pm -> Map.map P.futureCf pm --- ResecDeal uds -> Map.map futureCf uds --- setter d newCfMap = case pool d of --- MultiPool pm -> let --- newPm = Map.mapWithKey (\k p -> set P.poolFutureCf (newCfMap Map.! k) p) pm --- in --- set dealPool (MultiPool newPm) d --- ResecDeal pm -> --- let --- newPm = Map.mapWithKey --- (\k ud -> set uDealFutureCf (newCfMap Map.! k) ud) --- pm --- in --- set dealPool (ResecDeal newPm) d - getPoolIds :: Ast.Asset a => TestDeal a -> [PoolId] getPoolIds t@TestDeal{pool = pt} = case pt of @@ -620,7 +567,7 @@ let mCf = case poolType of MultiPool pm -> Map.map (view (P.poolFutureCf . _Just . _1 )) pm -- `debug` ("MultiPool" ++ show pm) - ResecDeal uds -> Map.map futureCf uds + ResecDeal uds -> Map.map (fromMaybe CF.emptyCashflow . futureCf) uds in case mPid of Nothing -> mCf -- `debug` ("Nothing when collecting cfs"++show mCf) diff --git a/src/Deal/DealCollection.hs b/src/Deal/DealCollection.hs new file mode 100644 --- /dev/null +++ b/src/Deal/DealCollection.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE DeriveGeneric #-} + +module Deal.DealCollection + ( depositInflow + , depositPoolFlow + , readProceeds + , extractTxnsFromFlowFrameMap + , CollectionRule(..) + ) where + +import GHC.Generics + +import Data.Aeson.TH +import Data.Aeson.Types + +import qualified Accounts as A +import qualified Waterfall as W +import qualified Cashflow as CF +import qualified Data.Map as Map hiding (mapEither) + +import Data.List +import Control.Monad +import Types +import Util +import Lib +import Control.Lens hiding (element) + +data CollectionRule = Collect (Maybe [PoolId]) PoolSource AccountName -- ^ collect a pool source from pool collection and deposit to an account + | CollectByPct (Maybe [PoolId]) PoolSource [(Rate,AccountName)] -- ^ collect a pool source from pool collection and deposit to multiple accounts with percentages + deriving (Show,Generic,Eq,Ord) + + +readProceeds :: PoolSource -> CF.TsRow -> Either String Balance +readProceeds CollectedInterest x = return $ CF.mflowInterest x +readProceeds CollectedPrincipal x = return $ CF.mflowPrincipal x +readProceeds CollectedRecoveries x = return $ CF.mflowRecovery x +readProceeds CollectedPrepayment x = return $ CF.mflowPrepayment x +readProceeds CollectedRental x = return $ CF.mflowRental x +readProceeds CollectedPrepaymentPenalty x = return $ CF.mflowPrepaymentPenalty x +readProceeds CollectedCash x = return $ CF.tsTotalCash x +readProceeds CollectedFeePaid x = return $ CF.mflowFeePaid x +readProceeds a _ = Left $ " Failed to find pool cashflow field from pool cashflow rule "++show a + + +extractTxnsFromFlowFrameMap :: Maybe [PoolId] -> Map.Map PoolId CF.PoolCashflow -> [CF.TsRow] +extractTxnsFromFlowFrameMap mPids pflowMap = + let + extractTxns :: Map.Map PoolId CF.PoolCashflow -> [CF.TsRow] + extractTxns m = concatMap (view (_1 . CF.cashflowTxn)) $ Map.elems m + in + case mPids of + Nothing -> extractTxns pflowMap + Just pids -> extractTxns $ Map.filterWithKey (\k _ -> k `elem` pids) pflowMap + + +-- ^ deposit cash to account by collection rule +depositInflow :: Date -> CollectionRule -> Map.Map PoolId CF.PoolCashflow -> Map.Map AccountName A.Account -> Either String (Map.Map AccountName A.Account) +depositInflow d (Collect mPids s an) pFlowMap amap + = do + amts <- traverse (readProceeds s) txns + let amt = sum amts + return $ Map.adjust (A.deposit amt d (PoolInflow mPids s)) an amap + where + txns = extractTxnsFromFlowFrameMap mPids pFlowMap + + +depositInflow d (CollectByPct mPids s splitRules) pFlowMap amap --TODO need to check 100% + = do + amts <- traverse (readProceeds s) txns + let amt = sum amts + let amtsToAccs = [ (an, mulBR amt splitRate) | (splitRate, an) <- splitRules] + return $ + foldr + (\(accName,accAmt) accM -> + Map.adjust (A.deposit accAmt d (PoolInflow mPids s)) accName accM) + amap + amtsToAccs + where + txns = extractTxnsFromFlowFrameMap mPids pFlowMap + + +-- ^ deposit cash to account by pool map CF and rules +depositPoolFlow :: [CollectionRule] -> Date -> Map.Map PoolId CF.PoolCashflow -> Map.Map String A.Account -> Either String (Map.Map String A.Account) +depositPoolFlow rules d pFlowMap amap + = foldM (\acc rule -> depositInflow d rule pFlowMap acc) amap rules + + +$(deriveJSON defaultOptions ''CollectionRule) diff --git a/src/Deal/DealRun.hs b/src/Deal/DealRun.hs new file mode 100644 --- /dev/null +++ b/src/Deal/DealRun.hs @@ -0,0 +1,745 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Deal.DealRun ( + run + ,accrueRC +) where + +import qualified Data.Set as S +import qualified Data.DList as DL +import Data.List +import Control.Lens hiding (element) +import Control.Lens.TH +import Control.Monad +import Data.Maybe +import Data.Either +import Data.Either.Utils +import Control.Monad.Loops (allM,anyM) + +import qualified Asset as Ast +import qualified Cashflow as CF +import qualified Accounts as A +import qualified Data.Map as Map hiding (mapEither) +import qualified Waterfall as W +import qualified Liability as L +import qualified Reports as Rpt +import qualified Pool as P +import qualified Assumptions as AP +import qualified Hedge as HE +import qualified CreditEnhancement as CE +import qualified InterestRate as IR +import Triggers + +import Deal.DealBase +import Deal.DealAction +import Deal.DealQuery +import Deal.DealCollection +import Revolving +import Hedge +import Stmt +import Types + +import Util +import Lib +-- ^ execute effects of trigger: making changes to deal +-- TODO seems position of arugments can be changed : f :: a -> b -> m a => f:: b -> a -> m a +runEffects :: Ast.Asset a => (TestDeal a, RunContext a, [ActionOnDate], DL.DList ResultComponent) -> Date -> TriggerEffect + -> Either String (TestDeal a, RunContext a, [ActionOnDate], DL.DList ResultComponent) +runEffects (t@TestDeal{accounts = accMap, fees = feeMap ,status=st, bonds = bondMap, pool=pt + ,collects = collRules}, rc, actions, logs) d te + = case te of + DealStatusTo _ds -> return (t {status = _ds}, rc, actions, logs) + DoAccrueFee fns -> do + newFeeList <- sequenceA $ calcDueFee t d <$> (feeMap Map.!) <$> fns + let newFeeMap = Map.fromList (zip fns newFeeList) <> feeMap + return (t {fees = newFeeMap}, rc, actions, logs) + ChangeReserveBalance accName rAmt -> + return (t {accounts = Map.adjust (set A.accTypeLens (Just rAmt)) accName accMap } + , rc, actions, logs) + + TriggerEffects efs -> foldM (`runEffects` d) (t, rc, actions, logs) efs + + RunActions wActions -> do + (newT, newRc, newLogs) <- foldM (performActionWrap d) (t, rc, DL.empty) wActions + return (newT, newRc, actions, DL.append logs newLogs) + + ChangeBondRate bName bRateType bRate -> + let + -- accrual rate + -- set current rate + -- update rate component + updateFn b = L.accrueInt d b + & set L.interestInfoTraversal bRateType + & set L.curRatesTraversal bRate + -- updated deal + t' = t {bonds = updateBondInMap bName updateFn bondMap} + -- build bond rate reset actions + newActions = case getBondByName t' True bName of + Just bnd -> [ ResetBondRate _d bName | _d <- L.buildRateResetDates bnd d (getDate (last actions))] + Nothing -> [] + in + return (t' , rc, sortBy sortActionOnDate (newActions++actions), logs) + + DoNothing -> return (t, rc, actions, DL.empty) + _ -> Left $ "Date:"++ show d++" Failed to match trigger effects: "++show te + +setBondStepUpRate :: Date -> [RateAssumption] -> L.Bond -> Either String L.Bond +setBondStepUpRate d ras b@(L.Bond _ _ _ ii (Just sp) _ _ _ _ _ _ _ _ _) + = return $ + let + newII = L.stepUpInterestInfo sp ii + newRate = AP.applyFloatRate ii d ras + in + (L.accrueInt d b) { L.bndInterestInfo = newII, L.bndRate = newRate } + +setBondStepUpRate d ras b@(L.MultiIntBond bn _ _ iis (Just sps) _ _ _ _ _ _ _ _ _) + = return $ + let + newIIs = zipWith L.stepUpInterestInfo sps iis + newRates = (\x -> AP.applyFloatRate x d ras) <$> newIIs + in + (L.accrueInt d b) { L.bndInterestInfos = newIIs, L.bndRates = newRates } -- `debug` (show d ++ ">> accure due to step up rate "++ bn) + +setBondStepUpRate d ras bg@(L.BondGroup bMap pt) + = do + m <- mapM (setBondStepUpRate d ras) bMap + return $ L.BondGroup m pt + +-- ^ 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 _ _ L.OriginalInfo{ L.originDate = od} ii _ bal currentRate _ dueInt _ Nothing _ _ _) + = setBondNewRate t d ras b {L.bndDueIntDate = Just od} + +-- ^ Floater rate +setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Floater br idx _spd rset dc mf mc) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) + = return $ (L.accrueInt d b){ L.bndRate = AP.applyFloatRate ii d ras } + +-- ^ Fix rate, do nothing +setBondNewRate t d ras b@(L.Bond _ _ _ L.Fix {} _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) + = return b + +-- ^ Ref rate +setBondNewRate t d ras b@(L.Bond _ _ _ (L.RefRate sr ds factor _) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) + = do + let b' = L.accrueInt d b + rate <- queryCompound t d (patchDateToStats d ds) + return b' {L.bndRate = fromRational (rate * toRational factor) } + +-- ^ cap & floor & IoI +setBondNewRate t d ras b@(L.Bond _ _ _ ii _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) + = return $ (L.accrueInt d b) { L.bndRate = AP.applyFloatRate ii d ras} + +-- ^ bond group +setBondNewRate t d ras bg@(L.BondGroup bMap pt) + = do + m <- mapM (setBondNewRate t d ras) bMap + return $ L.BondGroup m pt + +-- ^ apply all rates for multi-int bond +setBondNewRate t d ras b@(L.MultiIntBond bn _ _ iis _ bal currentRates _ dueInts dueIoIs _ _ _ _) + = let + newRates = AP.applyFloatRate <$> iis <*> pure d <*> pure ras + b' = L.accrueInt d b -- `debug` ("accrue due to new rate "++ bn) + in + return $ b' { L.bndRates = newRates } + +-- ^ accure rate cap +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 = return rc + | otherwise = do + r <- AP.lookupRate0 rs index d + balance <- case notional of + Fixed bal -> Right . toRational $ bal + Base ds -> queryCompound t d (patchDateToStats d ds) + Schedule ts -> return $ 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 -> IR.calcInt (fromRational balance) sd d accRate DC_ACT_365F + Just lstD -> IR.calcInt (fromRational balance) lstD d accRate DC_ACT_365F + + let newAmt = amt + addAmt -- `debug` ("Accrue AMT"++ show addAmt) + let newStmt = appendStmt (IrsTxn d newAmt addAmt 0 0 0 SwapAccrue) mstmt + return $ rc { rcLastStlDate = Just d ,rcNetCash = newAmt, rcStmt = newStmt } + +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 _ -> return rs + HE.Schedule ts -> return $ 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) ) + +updateRateSwapRate :: Ast.Asset a => TestDeal a -> Maybe [RateAssumption] -> Date -> HE.RateSwap -> Either String HE.RateSwap +updateRateSwapRate t Nothing _ _ = Left "Failed to update rate swap: No rate input assumption" +updateRateSwapRate t (Just rAssumps) d rs@HE.RateSwap{ HE.rsType = rt } + = let + getRate x = AP.lookupRate rAssumps x d + in + do + (pRate,rRate) <- case rt of + HE.FloatingToFloating flter1 flter2 -> + do + r1 <- getRate flter1 + r2 <- getRate flter2 + return (r1, r2) + HE.FloatingToFixed flter r -> + do + _r <- getRate flter + return (_r, r) + HE.FixedToFloating r flter -> + do + _r <- getRate flter + return (r, _r) + HE.FormulaToFloating ds flter -> + do + _r <- queryCompound t d (patchDateToStats d ds) + r <- getRate flter + return (fromRational _r, r) + HE.FloatingToFormula flter ds -> + do + r <- getRate flter + _r <- queryCompound t d (patchDateToStats d ds) + return (r, fromRational _r) + return rs {HE.rsPayingRate = pRate, HE.rsReceivingRate = rRate } + +updateLiqProviderRate :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> CE.LiqFacility -> CE.LiqFacility +updateLiqProviderRate t d ras liq@CE.LiqFacility{CE.liqRateType = mRt, CE.liqPremiumRateType = mPrt + , CE.liqRate = mr, CE.liqPremiumRate = mPr } + = let + newMr = AP.evalFloaterRate d ras <$> mRt + newMpr = AP.evalFloaterRate d ras <$> mPrt + -- TODO probably need to accure int when interest rate changes ? + in + liq {CE.liqRate = newMr, CE.liqPremiumRate = newMpr } + +runTriggers :: Ast.Asset a => (TestDeal a, RunContext a, [ActionOnDate]) -> Date -> DealCycle -> Either String (TestDeal a, RunContext a, [ActionOnDate], DL.DList ResultComponent) +runTriggers (t@TestDeal{status=oldStatus, triggers = Nothing},rc, actions) d dcycle = return (t, rc, actions, DL.empty) +runTriggers (t@TestDeal{status=oldStatus, triggers = Just trgM},rc, actions) d dcycle = + do + let trgsMap = Map.findWithDefault Map.empty dcycle trgM + let trgsToTest = Map.filter + (\trg -> (not (trgStatus trg) || trgStatus trg && trgCurable trg)) + trgsMap + triggeredTrgs <- mapM (testTrigger t d) trgsToTest + let triggeredEffects = [ trgEffects _trg | _trg <- Map.elems triggeredTrgs, (trgStatus _trg) ] + (newDeal, newRc, newActions, logsFromTrigger) <- foldM (`runEffects` d) (t,rc,actions, DL.empty) triggeredEffects + let newStatus = status newDeal + let newLogs = DL.fromList [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 + , DL.append newLogs logsFromTrigger) -- `debug` ("New logs from trigger"++ show d ++">>>"++show newLogs) + +appendCollectedCF :: Ast.Asset a => Date -> TestDeal a -> Map.Map PoolId CF.PoolCashflow -> TestDeal a +-- ^ append cashflow frame (consolidate by a date) into deals collected pool +appendCollectedCF d t@TestDeal { pool = pt } poolInflowMap + = let + newPt = case pt of + MultiPool poolM -> + MultiPool $ + Map.foldrWithKey + (\k (CF.CashFlowFrame st txnCollected, mAssetFlow) acc -> + let + currentStats = case view (P.poolFutureCf . _Just . _1 . CF.cashflowTxn) (acc Map.! k) of + [] -> P.poolBegStats (acc Map.! k) + txns -> fromMaybe (0,0,0,0,0,0) $ view CF.txnCumulativeStats (last txns) + balInCollected = case length txnCollected of + 0 -> 0 + _ -> view CF.tsRowBalance $ last txnCollected + txnToAppend = CF.patchCumulative currentStats [] txnCollected + -- insert aggregated pool flow + accUpdated = Map.adjust + (\_v -> case (P.futureCf _v) of + Nothing -> set P.poolFutureCf (Just (CF.CashFlowFrame st txnCollected , Nothing)) _v + Just _ -> over (P.poolFutureCf . _Just . _1 . CF.cashflowTxn) (++ txnToAppend) _v + ) + k + acc + -- insert breakdown asset flow + accUpdated' = case mAssetFlow of + Nothing -> accUpdated + Just collectedAssetFlow -> + let + appendFn Nothing = Just collectedAssetFlow + appendFn (Just cfs) + | length cfs == length collectedAssetFlow + = Just $ [ origin & over CF.cashflowTxn (++ (view CF.cashflowTxn new)) | (origin,new) <- zip cfs collectedAssetFlow ] + | length collectedAssetFlow > length cfs + = let + dummyCashFrames = replicate (length collectedAssetFlow - length cfs) CF.emptyCashflow + in + Just $ [ origin & over (CF.cashflowTxn) (++ (view CF.cashflowTxn new)) | (origin,new) <- zip (cfs++dummyCashFrames) collectedAssetFlow ] + | otherwise = error "incomping cashflow number shall greater than existing cashflow number" + in + accUpdated & ix k %~ (over (P.poolFutureCf . _Just . _2) appendFn) + in + Map.adjust + (over P.poolIssuanceStat (Map.insert RuntimeCurrentPoolBalance balInCollected)) + k accUpdated') + poolM + poolInflowMap + ResecDeal uds -> + ResecDeal $ + Map.foldrWithKey + (\k (CF.CashFlowFrame _ newTxns, _) acc-> + Map.adjust (over uDealFutureCf (`CF.appendMCashFlow` newTxns)) k acc) + uds + poolInflowMap + in + t {pool = newPt} -- `debug` ("after insert bal"++ show newPt) + + +run :: Ast.Asset a => TestDeal a -> Map.Map PoolId CF.PoolCashflow -> Maybe [ActionOnDate] -> Maybe [RateAssumption] -> Maybe ([Pre],[Pre]) + -> Maybe (Map.Map String (RevolvingPool,AP.ApplyAssumptionType)) -> DL.DList ResultComponent + -> Either String (TestDeal a, DL.DList ResultComponent, Map.Map PoolId CF.PoolCashflow) +run t@TestDeal{status=(Ended endedDate)} pCfM ads _ _ _ log = return (t,DL.snoc log (EndRun endedDate "By Status:Ended"), pCfM) +run t pCfM (Just []) _ _ _ log = return (t,DL.snoc log (EndRun Nothing "No Actions"), pCfM) +run t pCfM (Just [HitStatedMaturity d]) _ _ _ log = return (t, DL.snoc log (EndRun (Just d) "Stop: Stated Maturity"), pCfM) +run t pCfM (Just (StopRunFlag d:_)) _ _ _ log = return (t, DL.snoc log (EndRun (Just d) "Stop Run Flag"), pCfM) +run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status=dStatus + ,waterfall=waterfallM,name=dealName,pool=pt,stats=_stat} + poolFlowMap (Just (ad:ads)) rates calls rAssump log + | futureCashToCollectFlag && (queryCompound t (getDate ad) AllAccBalance == Right 0) && (dStatus /= Revolving) && (dStatus /= Warehousing Nothing) --TODO need to use prsim here to cover all warehouse status + = do + let runContext = RunContext poolFlowMap rAssump rates --- `debug` ("ending at date " ++ show (getDate ad)) + (finalDeal,_,newLogs) <- foldM (performActionWrap (getDate ad)) (t,runContext,log) cleanUpActions + return (finalDeal + , DL.snoc newLogs (EndRun (Just (getDate ad)) "No Pool Cashflow/All Account is zero/Not revolving") + , poolFlowMap) + | otherwise + = case ad of + PoolCollection d _ -> + if any (> 0) remainCollectionNum then + let + cutOffPoolFlowMap = Map.map (\(pflow,mAssetFlow) -> + (CF.splitCashFlowFrameByDate pflow d EqToLeft + ,(\xs -> [ CF.splitCashFlowFrameByDate x d EqToLeft | x <- xs ]) <$> mAssetFlow)) + poolFlowMap + collectedFlow = Map.map (\(p,mAstFlow) -> (fst p, (\xs -> [ fst x | x <- xs ]) <$> mAstFlow)) cutOffPoolFlowMap -- `debug` ("PoolCollection : "++ show d ++ " splited"++ show cutOffPoolFlowMap++"\n input pflow"++ show poolFlowMap) + -- outstandingFlow = Map.map (CF.insertBegTsRow d . snd) cutOffPoolFlowMap + outstandingFlow = Map.map (\(p,mAstFlow) -> (snd p, (\xs -> [ snd x | x <- xs ]) <$> mAstFlow)) cutOffPoolFlowMap + -- deposit cashflow to SPV from external pool cf + in + do + accs <- depositPoolFlow (collects t) d collectedFlow accMap -- `debug` ("PoolCollection: deposit >>"++ show d++">>>"++ show collectedFlow++"\n") + let dAfterDeposit = (appendCollectedCF d t collectedFlow) {accounts=accs} + -- newScheduleFlowMap = Map.map (over CF.cashflowTxn (cutBy Exc Future d)) (fromMaybe Map.empty (getScheduledCashflow t Nothing)) + let newPt = case (pool dAfterDeposit) of + MultiPool pm -> MultiPool $ + (over (mapped . P.poolFutureScheduleCf . _Just . _1 . CF.cashflowTxn) (cutBy Exc Future d)) pm + ResecDeal dMap -> ResecDeal $ + (over (mapped . uDealFutureScheduleCf . _Just . CF.cashflowTxn) (cutBy Exc Future d)) dMap + let runContext = RunContext outstandingFlow rAssump rates -- `debug` ("PoolCollection: before rc >>"++ show d++">>>"++ show (pool dAfterDeposit)) + (dRunWithTrigger0, rc1, ads2, newLogs0) <- runTriggers (dAfterDeposit {pool = newPt},runContext,ads) d EndCollection + let eopActionsLog = DL.fromList [ RunningWaterfall d W.EndOfPoolCollection | Map.member W.EndOfPoolCollection waterfallM ] -- `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 (increasePoolCollectedPeriod dRunWithTrigger1 ) + (runPoolFlow rc3) + (Just ads3) + rates + calls + rAssump + (DL.concat [newLogs0,newLogs,eopActionsLog,newLogs1]) + else + run t 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 + let logsBeforeDist = DL.concat [newLogs0 , DL.fromList [ 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 (dealAfterCleanUp, DL.concat [logsBeforeDist,DL.fromList (newStLogs++[EndRun (Just d) "Clean Up"]),endingLogs], poolFlowMap) -- `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 (increaseBondPaidPeriod dRunWithTrigger1) + (runPoolFlow rc3) + (Just ads2) + rates + calls + rAssump + (DL.concat [newLogsWaterfall, newLogs2 ,logsBeforeDist,DL.fromList [RunningWaterfall d waterfallKey]]) -- `debug` ("In RunWaterfall Date"++show d++"after run waterfall 3>>"++ show (pool dRunWithTrigger1)++" status>>"++ show (status dRunWithTrigger1)) + + -- Custom waterfall execution action from custom dates + RunWaterfall d wName -> + let + runContext = RunContext poolFlowMap rAssump rates + waterfallKey = W.CustomWaterfall wName + in + do + waterfallToExe <- maybeToEither + ("No waterfall distribution found on date "++show d++" with waterfall key "++show waterfallKey) $ + Map.lookup waterfallKey waterfallM + let logsBeforeDist =[ WarningMsg (" No waterfall distribution found on date "++show d++" with waterfall key "++show waterfallKey) + | Map.notMember waterfallKey waterfallM ] + (dAfterWaterfall, rc2, newLogsWaterfall) <- foldM (performActionWrap d) (t,runContext,log) waterfallToExe -- `debug` (show d ++ " running action"++ show waterfallToExe) + run dAfterWaterfall (runPoolFlow rc2) (Just ads) rates calls rAssump + (DL.concat [newLogsWaterfall,DL.fromList (logsBeforeDist ++ [RunningWaterfall d waterfallKey])]) -- `debug` ("size of logs"++ show (length newLogsWaterfall)++ ">>"++ show d++ show (length logsBeforeDist)) + + 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 -> + do + fToAcc <- maybeToEither + ("Failed to find fee "++feeName) + (Map.lookup feeName feeMap) + 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 + + DealClosed d -> + let + w = Map.findWithDefault [] W.OnClosingDay (waterfall t) + rc = RunContext poolFlowMap rAssump rates + logForClosed = [RunningWaterfall d W.OnClosingDay| not (null w)] + in + do + newSt <- case dStatus of + (PreClosing st) -> return 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 + (DL.concat [newLog, DL.fromList ([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 + + CalcIRSwap d sn -> + case rateSwap t of + Nothing -> Left $ " No rate swaps modeled when looking for "++ sn + Just rSwap -> + do + newRateSwap_rate <- adjustM (updateRateSwapRate t rates d) sn rSwap + 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 + + SettleIRSwap d sn -> + case rateSwap t of + Nothing -> Left $ " No rate swaps modeled when looking for "++ sn + Just rSwap -> + do + acc <- case HE.rsSettleDates (rSwap Map.! sn) of + Nothing -> Left $ "No settle date found for "++ sn + Just (_, _accName) -> return $ accMap Map.! _accName + let accBal = A.accBalance acc + let rs = rSwap Map.! sn + let settleAmt = HE.rsNetCash rs + let accName = A.accName acc + case (settleAmt <0, accBal < abs settleAmt) of + (True, True) -> + let + newAcc = Map.adjust (A.draw accBal d (SwapOutSettle sn)) accName accMap + newRsMap = Just $ Map.adjust (HE.payoutIRS d accBal) sn rSwap + in + run (t{accounts = newAcc, rateSwap = newRsMap}) poolFlowMap (Just ads) rates calls rAssump + $ DL.snoc log (WarningMsg $ "Settle Rate Swap Error: "++ show d ++" Insufficient balance to settle "++ sn) + -- Left $ "Settle Rate Swap Error: "++ show d ++" Insufficient balance to settle "++ sn + (True, False) -> + let + newAcc = Map.adjust (A.draw (abs settleAmt) d (SwapOutSettle sn)) accName accMap + newRsMap = Just $ Map.adjust (HE.payoutIRS d settleAmt) sn rSwap + in + run (t{accounts = newAcc, rateSwap = newRsMap}) poolFlowMap (Just ads) rates calls rAssump log + (False, _) -> + let + newAcc = Map.adjust (A.deposit settleAmt d (SwapInSettle sn)) accName accMap + newRsMap = Just $ Map.adjust (HE.receiveIRS d) sn rSwap + in + run (t{accounts = newAcc, rateSwap = newRsMap}) 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 $ DL.append log (DL.fromList 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 + + StepUpBondRate d bn -> + let + bnd = bndMap Map.! bn -- `debug` ("StepUpBondRate--------------"++ show bn) + in + do + newBndMap <- adjustM (setBondStepUpRate d (fromMaybe [] rates)) bn bndMap + run t{bonds = newBndMap } poolFlowMap (Just ads) rates calls rAssump log + + ResetAccRate d accName -> + do + newAccMap <- adjustM + (\a@(A.Account _ _ (Just (A.InvestmentAccount idx spd dp dp1 lastDay _)) _ _) + -> do + newRate <- AP.lookupRate (fromMaybe [] rates) (idx,spd) d + let accWithNewInt = A.depositInt d a + return accWithNewInt { A.accInterest = Just (A.InvestmentAccount idx spd dp dp1 lastDay newRate)}) + accName accMap + 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 + let newlog = FinancialReport sd ed bsReport cashReport + run t poolFlowMap (Just ads) rates calls rAssump $ DL.snoc 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 = do + tm <- mTrgMap + cycM <- Map.lookup cyc tm + trg <- Map.lookup n cycM + return $ trgEffects trg + + runContext = RunContext poolFlowMap rAssump rates + in + do + (newT, rc@(RunContext newPool _ _), adsFromTrigger, newLogsFromTrigger) + <- case triggerEffects of + Nothing -> return (t, runContext, ads, DL.empty) -- `debug` "Nothing found on effects" + Just efs -> runEffects (t, runContext, ads, DL.empty) d efs + let (oldStatus,newStatus) = (status t,status newT) + let stChangeLogs = DL.fromList [DealStatusChangeTo d oldStatus newStatus "by Manual fireTrigger" | oldStatus /= newStatus] + run newT {triggers = Just triggerFired} newPool (Just ads) rates calls rAssump $ DL.concat [log,stChangeLogs,newLogsFromTrigger] + + MakeWhole d spd walTbl -> + let + schedulePoolFlowMap = case pt of + MultiPool pMap -> Map.map (view (P.poolFutureScheduleCf._Just._1) ) pMap + ResecDeal uDealMap -> Map.map (view (uDealFutureScheduleCf . _Just)) uDealMap + in + do + factor <- liftA2 + (/) + (queryCompound t d (FutureCurrentPoolBegBalance Nothing)) + (queryCompound t d (FutureCurrentSchedulePoolBegBalance Nothing)) + let reduceCfs = Map.map (\f -> (over CF.cashflowTxn (\xs -> CF.scaleTsRow factor <$> xs) f, Nothing ) ) 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 (Just d)} Map.empty (Just []) rates calls rAssump $ DL.snoc log (EndRun (Just d) "MakeWhole call") + + FundBond d Nothing bName accName fundAmt -> + let + newAcc = Map.adjust (A.deposit fundAmt d (FundWith bName fundAmt)) accName accMap + in + do + let bndFunded = L.fundWith d fundAmt $ bndMap Map.! bName + run t{accounts = newAcc, bonds = Map.insert bName bndFunded bndMap} + poolFlowMap (Just ads) rates calls rAssump log + + FundBond d (Just p) bName accName fundAmt -> + let + newAcc = Map.adjust (A.deposit fundAmt d (FundWith bName fundAmt)) accName accMap + in + do + flag <- testPre d t p + case flag of + False -> run t poolFlowMap (Just ads) rates calls rAssump (DL.snoc log (WarningMsg ("Failed to fund bond"++ bName++ ":" ++show p))) + True -> + do + let bndFunded = L.fundWith d fundAmt $ bndMap Map.! bName + run t{accounts = newAcc, bonds = Map.insert bName bndFunded bndMap} + poolFlowMap (Just ads) rates calls rAssump log + + + 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 (DL.snoc 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 -> return $ L.originRate (L.bndOriginInfo bnd) + let newBonds = case Map.lookup bGroupName bndMap of + Nothing -> bndMap + Just L.Bond {} -> bndMap + Just (L.BondGroup bndGrpMap pt) -> 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) pt) + 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) + isResetActionEvent (ResetBondRate _ bName ) = False + isResetActionEvent _ = True + filteredAds = filter isResetActionEvent ads + newRate = L.getBeginRate iInfo + in + do + nBnd <- calcDueInt t d $ bndMap Map.! bName + let dueIntToPay = L.getTotalDueInt 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 0 | d <- resetDates ] + -- TODO tobe fix + let bResetActions = [] + 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 -> Left "Undefined action: RefiBond" + + 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 + DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call"] + else + DL.fromList [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 (dealAfterCleanUp, DL.snoc (endingLogs `DL.append` newStLogs) (EndRun (Just d) "Clean Up"), poolFlowMap) -- `debug` ("Called ! "++ show d) + _ -> run t poolFlowMap (Just ads) rates calls rAssump log + + StopRunTest d pres -> + do + flags::[Bool] <- sequenceA $ [ (testPre d t pre) | pre <- pres ] + case all id flags of + True -> return (t, DL.snoc log (EndRun (Just d) ("Stop Run Test by:"++ show (zip pres flags))), poolFlowMap) + _ -> 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)) + remainCollectionNum = Map.elems $ Map.map (\(x,_) -> CF.sizeCashFlowFrame x ) poolFlowMap + futureCashToCollectFlag = and $ Map.elems $ Map.map (\(pcf,_) -> all CF.isEmptyRow2 (view CF.cashflowTxn pcf)) poolFlowMap + +-- run :: Ast.Asset a => TestDeal a -> Map.Map PoolId CF.PoolCashflow -> Maybe [ActionOnDate] -> Maybe [RateAssumption] -> Maybe ([Pre],[Pre]) +-- -> Maybe (Map.Map String (RevolvingPool,AP.ApplyAssumptionType)) -> DL.DList ResultComponent +-- -> Either String (TestDeal a, DL.DList ResultComponent, Map.Map PoolId CF.PoolCashflow) + +-- run t empty Nothing Nothing Nothing Nothing log +-- = do +-- (t, ads, pcf, unStressPcf) <- getInits S.empty t Nothing Nothing +-- run t pcf (Just ads) Nothing Nothing Nothing log -- `debug` ("Init Done >>Last Action#"++show (length ads)++"F/L"++show (head ads)++show (last ads)) + +run t empty _ _ _ _ log = return (t, log ,empty) -- `debug` ("End with pool CF is []") diff --git a/src/Deal/DealValidation.hs b/src/Deal/DealValidation.hs --- a/src/Deal/DealValidation.hs +++ b/src/Deal/DealValidation.hs @@ -25,6 +25,8 @@ import qualified Assumptions as AP import qualified InterestRate as IR +import Deal.DealCollection (CollectionRule(..)) + import Control.Lens hiding (element) import Control.Lens.TH @@ -301,23 +303,23 @@ Nothing -> [] -- note fee is not tested -validateAggRule :: [W.CollectionRule] -> [PoolId] -> [ResultComponent] +validateAggRule :: [CollectionRule] -> [PoolId] -> [ResultComponent] validateAggRule rules validPids = [ ErrorMsg ("Pool source "++show ps++" has a weight of "++show r) | ((pid,ps),r) <- Map.toList oustandingPs ] ++ [ ErrorMsg ("Pool Id not found "++show ospid++" in "++ show validPids) | ospid <- osPid ] where - countWeight (W.Collect (Just pids) ps _) = Map.fromList [((pid,ps),1.0) | pid <- pids] - countWeight (W.Collect Nothing ps _) = Map.fromList [((PoolConsol,ps),1.0)] - countWeight (W.CollectByPct (Just pids) ps lst) = Map.fromList [((pid,ps), pct) | pid <- pids, pct <- fst <$> lst] - countWeight (W.CollectByPct Nothing ps lst) = Map.fromList [((PoolConsol, ps),pct)| pct <- fst <$> lst] + countWeight (Collect (Just pids) ps _) = Map.fromList [((pid,ps),1.0) | pid <- pids] + countWeight (Collect Nothing ps _) = Map.fromList [((PoolConsol,ps),1.0)] + countWeight (CollectByPct (Just pids) ps lst) = Map.fromList [((pid,ps), pct) | pid <- pids, pct <- fst <$> lst] + countWeight (CollectByPct Nothing ps lst) = Map.fromList [((PoolConsol, ps),pct)| pct <- fst <$> lst] sumMap = foldl1 (Map.unionWith (+)) $ countWeight <$> rules oustandingPs = Map.filter (> 1.0) sumMap - getPids (W.Collect (Just pids) _ _) = pids - getPids (W.Collect Nothing ps _) = [PoolConsol] - getPids (W.CollectByPct (Just pids) _ _) = pids - getPids (W.CollectByPct Nothing _ _ ) = [PoolConsol] + getPids (Collect (Just pids) _ _) = pids + getPids (Collect Nothing ps _) = [PoolConsol] + getPids (CollectByPct (Just pids) _ _) = pids + getPids (CollectByPct Nothing _ _ ) = [PoolConsol] osPid = Set.elems $ Set.difference (Set.fromList (concat (getPids <$> rules))) (Set.fromList validPids) diff --git a/src/Pool.hs b/src/Pool.hs --- a/src/Pool.hs +++ b/src/Pool.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TupleSections #-} module Pool (Pool(..),aggPool ,getIssuanceField @@ -8,6 +9,7 @@ ,poolFutureScheduleCf ,poolBegStats,calcLiquidationAmount,pricingPoolFlow ,futureScheduleCfLens,futureCfLens, poolFutureCf + ,runPool ) where @@ -16,15 +18,19 @@ ,getIntervalDays,zipWith9,mkTs,periodsBetween ,mkRateTs,daysBetween, ) +import Control.Parallel.Strategies import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) import qualified Assumptions as A import qualified Analytics as AN import qualified AssetClass.AssetBase as ACM +import AssetClass.Mortgage import AssetClass.AssetCashflow import Asset (Asset(..)) import qualified Data.Map as Map import Data.Ratio +import qualified Data.Set as S +import Data.List import Data.Aeson hiding (json) import Language.Haskell.TH import GHC.Generics @@ -40,6 +46,7 @@ import Util import Cashflow (CashFlowFrame) import qualified Stmt as CF +import Stmt import Debug.Trace debug = flip trace @@ -190,7 +197,114 @@ in AN.pv21 discountRate d futureDates futureCfCash + -- | run a pool of assets ,use asOfDate of Pool to cutoff cashflow yields from assets with assumptions supplied +runPool :: Asset a => Pool a -> Maybe A.ApplyAssumptionType -> Maybe [RateAssumption] + -> Either String [(CF.CashFlowFrame, Map.Map CutoffFields Balance)] +-- schedule cashflow just ignores the interest rate assumption +runPool (Pool [] (Just (cf,_)) _ asof _ _ ) Nothing _ = Right [(cf, Map.empty)] +-- schedule cashflow with stress assumption +runPool (Pool [] (Just (CF.CashFlowFrame _ txn,_)) _ asof _ (Just dp)) (Just (A.PoolLevel assumps)) mRates + = sequenceA [ projCashflow (ACM.ScheduleMortgageFlow asof txn dp) asof assumps mRates ] + +-- project contractual cashflow if nothing found in pool perf assumption +-- use interest rate assumption +runPool (Pool as _ _ asof _ _) Nothing mRates + = do + cf <- sequenceA $ parMap rdeepseq (\x -> calcCashflow x asof mRates) as + return [ (x, Map.empty) | x <- cf ] +-- asset cashflow with credit stress +---- By pool level +runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates + = sequenceA $ parMap rdeepseq (\x -> projCashflow x asof assumps mRates) as +---- By index +runPool (Pool as _ Nothing asof _ _) (Just (A.ByIndex idxAssumps)) mRates = + let + numAssets = length as + in + do + _assumps <- traverse (A.lookupAssumptionByIdx idxAssumps) [0..(pred numAssets)] -- `debug` ("Num assets"++ show numAssets) + sequenceA $ parMap rdeepseq (\(x, a) -> projCashflow x asof a mRates) (zip as _assumps) + +---- By Obligor +runPool (Pool as _ Nothing asof _ _) (Just (A.ByObligor obligorRules)) mRates = + let + matchAssets [] _ [] = Right [(CF.CashFlowFrame (0,epocDate,Nothing) [], Map.empty)] + matchAssets cfs [] [] = sequenceA cfs + -- matchAssets cfs [] astList = sequenceA $ cfs ++ ((\x -> (\y -> (y, Map.empty)) <$> (Ast.calcCashflow x asof mRates)) <$> astList) + matchAssets cfs [] astList = let + poolCfs = parMap rdeepseq (\x -> calcCashflow x asof mRates) astList + poolCfs' = (\x -> (, Map.empty) <$> x) <$> poolCfs + in + sequenceA $ cfs ++ poolCfs' + matchAssets cfs (rule:rules) astList = + case rule of + A.ObligorById ids assetPerf + -> let + idSet = S.fromList ids + (matchedAsts,unMatchedAsts) = partition + (\x -> case getObligorId x of + Just oid -> S.member oid idSet + Nothing -> False) + astList + matchedCfs = parMap rdeepseq (\x -> projCashflow x asof assetPerf mRates) matchedAsts + in + matchAssets (cfs ++ matchedCfs) rules unMatchedAsts + A.ObligorByTag tags tagRule assetPerf -> + let + obrTags = S.fromList tags + + matchRuleFn A.TagEq s1 s2 = s1 == s2 + matchRuleFn A.TagSubset s1 s2 = s1 `S.isSubsetOf` s2 + matchRuleFn A.TagSuperset s1 s2 = s2 `S.isSubsetOf` s1 + matchRuleFn A.TagAny s1 s2 = not $ S.null $ S.intersection s1 s2 + matchRuleFn (A.TagNot tRule) s1 s2 = not $ matchRuleFn tRule s1 s2 + + (matchedAsts,unMatchedAsts) = partition (\x -> matchRuleFn tagRule (getObligorTags x) obrTags) astList + matchedCfs = parMap rdeepseq (\x -> projCashflow x asof assetPerf mRates) matchedAsts + in + matchAssets (cfs ++ matchedCfs) rules unMatchedAsts + A.ObligorByField fieldRules assetPerf -> + let + matchRuleFn (A.FieldIn fv fvals) Nothing = False + matchRuleFn (A.FieldIn fv fvals) (Just fm) = case Map.lookup fv fm of + Just (Left v) -> v `elem` fvals + Nothing -> False + matchRuleFn (A.FieldCmp fv cmp dv) (Just fm) = case Map.lookup fv fm of + Just (Right v) -> case cmp of + G -> v > dv + L -> v < dv + GE -> v >= dv + LE -> v <= dv + Nothing -> False + matchRuleFn (A.FieldInRange fv rt dv1 dv2) (Just fm) = + case Map.lookup fv fm of + Just (Right v) -> case rt of + II -> v <= dv2 && v >= dv1 + IE -> v <= dv2 && v > dv1 + EI -> v < dv2 && v >= dv1 + EE -> v < dv2 && v > dv1 + _ -> False + Nothing -> False + matchRuleFn (A.FieldNot fRule) fm = not $ matchRuleFn fRule fm + + matchRulesFn fs fm = all (`matchRuleFn` fm) fs + + (matchedAsts,unMatchedAsts) = partition (matchRulesFn fieldRules . getObligorFields) astList + matchedCfs = parMap rdeepseq (\x -> projCashflow x asof assetPerf mRates) matchedAsts + in + matchAssets (cfs ++ matchedCfs) rules unMatchedAsts + A.ObligorByDefault assetPerf -> + matchAssets + (cfs ++ (parMap rdeepseq (\x -> projCashflow x asof assetPerf mRates) astList)) + [] + [] + in + matchAssets [] obligorRules as + +-- safe net to catch other cases +runPool _a _b _c = Left $ "[Run Pool]: Failed to match" ++ show _a ++ show _b ++ show _c + $(deriveJSON defaultOptions ''Pool) diff --git a/src/Stmt.hs b/src/Stmt.hs --- a/src/Stmt.hs +++ b/src/Stmt.hs @@ -13,7 +13,6 @@ ,getFlow,FlowDirection(..), aggByTxnComment,scaleByFactor ,scaleTxn,isEmptyTxn, statementTxns, viewBalanceAsOf,filterTxn ,HasStmt(..),Txn(..) - ,getAllTxns,hasEmptyTxn ) where diff --git a/src/Triggers.hs b/src/Triggers.hs --- a/src/Triggers.hs +++ b/src/Triggers.hs @@ -14,7 +14,7 @@ import Lib import Types import Accounts (ReserveAmount) -import Waterfall (Action,CollectionRule) +import Waterfall (Action) import Data.Aeson ( defaultOptions ) import Language.Haskell.TH import Data.Aeson.TH @@ -24,19 +24,17 @@ import Data.Map import GHC.Generics import Control.Lens --- import qualified Liability as L +import Deal.DealCollection (CollectionRule(..)) type TriggerName = String - data TriggerEffect = DealStatusTo DealStatus -- ^ change deal status | DoAccrueFee FeeNames -- ^ accure fee | AddTrigger Trigger -- ^ add a new trigger | ChangeReserveBalance String ReserveAmount -- ^ update reserve target balance | CloseDeal (Int, DatePattern) (Int, DatePattern) (PricingMethod, AccountName, Maybe DealStats) - (Maybe [CollectionRule]) - -- ^ close the deal + (Maybe [CollectionRule]) -- ^ close the deal | BuyAsset AccountName PricingMethod -- ^ buy asset from the assumption using funds from account | ChangeBondRate BondName L.InterestInfo IRate -- ^ change bond rate | TriggerEffects [TriggerEffect] -- ^ a combination of effects above diff --git a/src/Waterfall.hs b/src/Waterfall.hs --- a/src/Waterfall.hs +++ b/src/Waterfall.hs @@ -4,7 +4,7 @@ {-# LANGUAGE DeriveGeneric #-} module Waterfall - (PoolSource(..),Action(..),DistributionSeq(..),CollectionRule(..) + (PoolSource(..),Action(..),DistributionSeq(..) ,ActionWhen(..),BookType(..),ExtraSupport(..),PayOrderBy(..)) where @@ -45,7 +45,7 @@ | ByMaturity | ByStartDate | ByCustomNames [String] - -- | InverseSeq PayOrderBy + | ReverseSeq PayOrderBy deriving (Show,Generic,Eq,Ord) type BookLedger = (BookDirection, LedgerName) @@ -127,12 +127,7 @@ type DistributionSeq = [Action] -data CollectionRule = Collect (Maybe [PoolId]) PoolSource AccountName -- ^ collect a pool source from pool collection and deposit to an account - | CollectByPct (Maybe [PoolId]) PoolSource [(Rate,AccountName)] -- ^ collect a pool source from pool collection and deposit to multiple accounts with percentages - deriving (Show,Generic,Eq,Ord) - $(deriveJSON defaultOptions ''BookType) $(deriveJSON defaultOptions ''ExtraSupport) $(deriveJSON defaultOptions ''PayOrderBy) $(deriveJSON defaultOptions ''Action) -$(deriveJSON defaultOptions ''CollectionRule) diff --git a/test/DealTest/DealTest.hs b/test/DealTest/DealTest.hs --- a/test/DealTest/DealTest.hs +++ b/test/DealTest/DealTest.hs @@ -25,7 +25,7 @@ import qualified Triggers as Trg import Lib import Types - +import Deal.DealCollection (CollectionRule(..)) import qualified Data.Map as Map import qualified Data.Time as T import qualified Data.Set as S @@ -104,8 +104,8 @@ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] - ,D.collects = [W.Collect Nothing W.CollectedInterest "General" - ,W.Collect Nothing W.CollectedPrincipal "General"] + ,D.collects = [Collect Nothing W.CollectedInterest "General" + ,Collect Nothing W.CollectedPrincipal "General"] ,D.liqProvider = Nothing ,D.rateCap = Nothing ,D.triggers = Nothing diff --git a/test/DealTest/MultiPoolDealTest.hs b/test/DealTest/MultiPoolDealTest.hs --- a/test/DealTest/MultiPoolDealTest.hs +++ b/test/DealTest/MultiPoolDealTest.hs @@ -25,6 +25,7 @@ import qualified Triggers as Trg import Lib import Types +import Deal.DealCollection (CollectionRule(..)) import qualified Data.Map as Map import qualified Data.Time as T @@ -89,9 +90,8 @@ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] - ,D.collects = [W.Collect (Just [PoolName "PoolA",PoolName "PoolB"]) W.CollectedInterest "General" - ,W.Collect (Just [PoolName "PoolA",PoolName "PoolB"]) W.CollectedPrincipal "General" - ] + ,D.collects = [Collect (Just [PoolName "PoolA",PoolName "PoolB"]) CollectedInterest "General" + ,Collect (Just [PoolName "PoolA",PoolName "PoolB"]) CollectedPrincipal "General"] ,D.liqProvider = Nothing ,D.rateCap = Nothing ,D.triggers = Nothing diff --git a/test/DealTest/ResecDealTest.hs b/test/DealTest/ResecDealTest.hs --- a/test/DealTest/ResecDealTest.hs +++ b/test/DealTest/ResecDealTest.hs @@ -25,6 +25,7 @@ import qualified Triggers as Trg import Lib import Types +import Deal.DealCollection (CollectionRule(..)) import qualified Data.Map as Map import qualified Data.Time as T @@ -86,8 +87,8 @@ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] - ,D.collects = [W.Collect Nothing W.CollectedInterest "General" - ,W.Collect Nothing W.CollectedPrincipal "General"] + ,D.collects = [Collect Nothing W.CollectedInterest "General" + ,Collect Nothing W.CollectedPrincipal "General"] } resecDeal = D.TestDeal { @@ -121,11 +122,11 @@ ] ) ,D.pool = D.ResecDeal (Map.fromList [(DealBondFlow "base case" "A" (toDate "20200101") 0.25 - , D.UnderlyingDeal baseCase CF.emptyCashflow CF.emptyCashflow Nothing)]) + , D.UnderlyingDeal baseCase (Just CF.emptyCashflow) (Just CF.emptyCashflow) Nothing)]) ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] - ,D.collects = [W.Collect Nothing W.CollectedInterest "General" - ,W.Collect Nothing W.CollectedPrincipal "General"] + ,D.collects = [Collect Nothing W.CollectedInterest "General" + ,Collect Nothing W.CollectedPrincipal "General"] } diff --git a/test/DealTest/RevolvingTest.hs b/test/DealTest/RevolvingTest.hs --- a/test/DealTest/RevolvingTest.hs +++ b/test/DealTest/RevolvingTest.hs @@ -13,6 +13,7 @@ import qualified AssetClass.AssetBase as AB import qualified Expense as F import qualified Deal.DealBase as D +import Deal.DealCollection (CollectionRule(..)) import qualified Deal as DR import qualified Liability as L import qualified Waterfall as W @@ -87,9 +88,8 @@ (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] - ,D.collects = [W.Collect (Just [PoolName "PoolA",PoolName "PoolB"]) W.CollectedInterest "General" - ,W.Collect (Just [PoolName "PoolA",PoolName "PoolB"]) W.CollectedPrincipal "General" - ] + ,D.collects = [Collect (Just [PoolName "PoolA",PoolName "PoolB"]) CollectedInterest "General" + ,Collect (Just [PoolName "PoolA",PoolName "PoolB"]) CollectedPrincipal "General"] ,D.liqProvider = Nothing ,D.rateCap = Nothing ,D.triggers = Nothing @@ -108,10 +108,9 @@ 24 AB.Current)] rAssump = Just (AP.AvailableAssets (R.ConstantAsset $ AB.LO <$> poolAssets) - (AP.PoolLevel ((AP.LoanAssump Nothing Nothing Nothing Nothing) + (AP.PoolLevel (AP.LoanAssump Nothing Nothing Nothing Nothing ,AP.DummyDelinqAssump - ,AP.DummyDefaultAssump)) - ) + ,AP.DummyDefaultAssump))) inspectVars = [AP.InspectRpt MonthEnd [FutureCurrentPoolBalance Nothing ,FutureCurrentPoolBalance (Just [PoolName "PoolA"]) ,FutureCurrentPoolBalance (Just [PoolName "PoolB"]) @@ -130,7 +129,5 @@ ,testCase "empty pool flow" $ assertEqual "empty pool flow" 0 - -- (P.futureCf (D.pool baseCase)) 0 ] - diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -641,11 +641,11 @@ ,A.DummyDefaultAssump)) poolCf = fst . head $ - case D.runPool pool assump1 Nothing of + case P.runPool pool assump1 Nothing of Left errorMsg -> undefined `debug` ("Error in pool run"++show errorMsg) Right x -> x `debug` ("pool run resp"++show x) poolCf2 = fst . head $ - case D.runPool pool assump2 Nothing of + case P.runPool pool assump2 Nothing of Left _ -> undefined Right x -> x in diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -9,6 +9,7 @@ import qualified Accounts as A import qualified Stmt as Stmt +import Deal.DealCollection (CollectionRule(..)) import qualified Pool as P import qualified Asset as Ast import qualified AssetClass.Mortgage as ACM @@ -147,8 +148,8 @@ ,(W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] - ,D.collects = [W.Collect Nothing W.CollectedInterest "General" - ,W.Collect Nothing W.CollectedPrincipal "General"] + ,D.collects = [Collect Nothing W.CollectedInterest "General" + ,Collect Nothing W.CollectedPrincipal "General"] ,D.custom = Nothing ,D.liqProvider = Just $ Map.fromList $ [("Liq1",CE.LiqFacility @@ -259,7 +260,7 @@ ,(W.PayPrin Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["B"] Nothing) ])] - ,D.collects = [W.Collect Nothing W.CollectedCash "General"] + ,D.collects = [Collect Nothing W.CollectedCash "General"] ,D.custom = Nothing ,D.liqProvider = Nothing ,D.triggers = Nothing diff --git a/test/UT/DealTest2.hs b/test/UT/DealTest2.hs --- a/test/UT/DealTest2.hs +++ b/test/UT/DealTest2.hs @@ -7,6 +7,7 @@ import Deal import Deal.DealQuery (queryCompound) +import Deal.DealCollection (CollectionRule(..)) import qualified Accounts as A import qualified Stmt as S import qualified Pool as P @@ -130,7 +131,7 @@ ,(W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] - ,D.collects = [W.Collect Nothing W.CollectedCash "General"] + ,D.collects = [Collect Nothing W.CollectedCash "General"] ,D.custom = Nothing ,D.liqProvider = Nothing ,D.triggers = Nothing diff --git a/test/UT/RateHedgeTest.hs b/test/UT/RateHedgeTest.hs --- a/test/UT/RateHedgeTest.hs +++ b/test/UT/RateHedgeTest.hs @@ -9,7 +9,7 @@ import Types import Util import Stmt -import Deal (accrueRC) +import Deal.DealRun (accrueRC) import Data.Ratio import UT.DealTest (td2) import Hedge (RateSwap(..),RateCap(..),RateSwapBase(..),rcNetCash)