{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# 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 (Just 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 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)
-- <Legacy Test>, <Test on dates>
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)
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 osPoolFlow))
, bndPricing
, osPoolFlow & mapped . _1 . CF.cashflowTxn %~ CF.dropTailEmptyTxns
& mapped . _2 . _Just . each . CF.cashflowTxn %~ CF.dropTailEmptyTxns
) -- `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
-- TODO: need to add warning if uncollected pool flow is not empty
unCollectedPoolFlowWarning pMap = if sum (Map.elems (Map.map (CF.sizeCashFlowFrame . view _1) pMap)) > 0 then
DL.singleton $ WarningMsg "Oustanding pool cashflow hasn't been collected yet"
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
$(deriveJSON defaultOptions ''ExpectReturn)