Hastructure-0.50.0: src/Deal/DealAction.hs
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Deal.DealAction (performActionWrap,performAction,calcDueFee
,testTrigger,RunContext(..),updateLiqProvider
,calcDueInt,priceAssetUnion
,priceAssetUnionList,inspectVars,inspectListVars)
where
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 Hedge as HE
import qualified Waterfall as W
import qualified Cashflow as CF
import qualified Assumptions as AP
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 qualified Analytics as AN
import Deal.DealBase
import Deal.DealQuery
import Deal.DealDate
import Stmt
import Lib
import Util
import DateUtil
import Types
import Revolving
import Triggers
import qualified Data.Map as Map
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.Applicative
import Debug.Trace
import Cashflow (CashFlowFrame(CashFlowFrame))
import Control.Lens hiding (element)
import Control.Lens.TH
import Control.Lens.Extras (is)
import Control.Monad
import GHC.Real (infinity)
import Data.OpenApi (HasPatch(patch))
debug = flip trace
-- ^ Test triggers
testTrigger :: Ast.Asset a => TestDeal a -> Date -> Trigger -> Either String Trigger
testTrigger t d trigger@Trigger{trgStatus=st,trgCurable=curable,trgCondition=cond,trgStmt = tStmt}
| not curable && st = Right trigger
| otherwise = let
(memo, newStM) = testPre2 d t cond
in
do
newSt <- newStM
return trigger { trgStatus = newSt
, trgStmt = Stmt.appendStmt (TrgTxn d newSt (Stmt.Tag memo)) tStmt }
pricingAssets :: PricingMethod -> [(ACM.AssetUnion,AP.AssetPerf)] -> Maybe [RateAssumption] -> Date
-> Either String [PriceResult]
pricingAssets pm assetsAndAssump ras d
= let
pricingResults = (\(ast,perf) -> priceAssetUnion ast d pm perf ras) <$> assetsAndAssump
in
sequenceA pricingResults
-- actual payout amount to bond with due mounts
allocAmtToBonds :: W.PayOrderBy -> Amount -> [(L.Bond,Amount)] -> [(L.Bond,Amount)]
allocAmtToBonds W.ByProRataCurBal amt bndsWithDue
= 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
orderedAmt = snd <$> orderedBonds
in
zip
(fst <$> orderedBonds)
$ paySeqLiabilitiesAmt amt orderedAmt
calcDueFee :: Ast.Asset a => TestDeal a -> Date -> F.Fee -> Either String F.Fee
calcDueFee t calcDay f@(F.Fee fn (F.FixFee amt) fs fd fdDay fa _ _)
| isJust fdDay = Right f
| calcDay >= fs && isNothing fdDay = Right f { F.feeDue = amt, F.feeDueDate = Just calcDay} -- `debug` ("DEBUG--> init with amt "++show(fd)++show amt)
| otherwise = Right f
calcDueFee t calcDay f@(F.Fee fn (F.AnnualRateFee feeBase r) fs fd Nothing fa lpd _)
| calcDay >= fs = calcDueFee t calcDay f {F.feeDueDate = Just fs }
| otherwise = Right f
-- ^ annualized % fee base on pool balance amount
calcDueFee t@TestDeal{pool = pool} calcDay f@(F.Fee fn (F.AnnualRateFee feeBase _r) fs fd (Just _fdDay) fa lpd _)
= let
accrueStart = _fdDay
patchedDs = patchDatesToStats t accrueStart calcDay feeBase
in
do
r <- queryCompound t calcDay _r
baseBal <- queryCompound t calcDay patchedDs
let newDue = baseBal * r
return f { F.feeDue=fd+ fromRational newDue, F.feeDueDate = Just calcDay }
calcDueFee t calcDay f@(F.Fee fn (F.PctFee ds _r ) fs fd fdDay fa lpd _)
= let
lastBegDay = fromMaybe fs fdDay
in
do
r <- queryCompound t calcDay _r
baseBal <- queryCompound t calcDay (patchDateToStats calcDay ds)
return f { F.feeDue = fd + fromRational (baseBal * r), F.feeDueDate = Just calcDay }
calcDueFee t calcDay f@(F.Fee fn (F.FeeFlow ts) fs fd _ fa mflpd _)
= Right $
f{ F.feeDue = newFeeDue ,F.feeDueDate = Just calcDay ,F.feeType = F.FeeFlow futureDue}
where
(currentNewDue,futureDue) = splitTsByDate ts calcDay
cumulativeDue = sumValTs currentNewDue
newFeeDue = cumulativeDue + fd
calcDueFee t calcDay f@(F.Fee fn (F.RecurFee p amt) fs fd mLastAccDate fa _ _)
| periodGaps == 0 = Right f
| otherwise = Right f { F.feeDue = amt * fromIntegral periodGaps + fd
, F.feeDueDate = Just (T.addDays 1 calcDay) }
where
accDates = case mLastAccDate of
Nothing -> genSerialDatesTill2 NO_IE (T.addDays 1 fs) p calcDay
Just lastAccDate -> genSerialDatesTill2 NO_IE lastAccDate p calcDay
periodGaps = length accDates
calcDueFee t calcDay f@(F.Fee fn (F.NumFee p s amt) fs fd Nothing fa lpd _)
| calcDay >= fs = calcDueFee t calcDay f {F.feeDueDate = Just fs }
| otherwise = Right f
calcDueFee t calcDay f@(F.Fee fn (F.NumFee p s amt) fs fd (Just _fdDay) fa lpd _)
| _fdDay == calcDay = Right f
| periodGap == 0 = Right f
| otherwise = do
baseCount <- queryCompound t calcDay (patchDateToStats calcDay s)
let newFeeDueAmt = (fromRational baseCount) * amt * fromIntegral periodGap -- `debug` ("amt"++show amt++">>"++show baseCount++">>"++show periodGap)
return f { F.feeDue = fd+newFeeDueAmt , F.feeDueDate = Just calcDay }
where
dueDates = projDatesByPattern p _fdDay (pred calcDay)
periodGap = length dueDates -- `debug` ("Due Dates"++ show dueDates)
calcDueFee t calcDay f@(F.Fee fn (F.TargetBalanceFee dsDue dsPaid) fs fd _ fa lpd _)
= do
let dsDueD = patchDateToStats calcDay dsDue
let dsPaidD = patchDateToStats calcDay dsPaid
dueAmt <- max 0 <$> (liftA2) (-) (queryCompound t calcDay dsDueD) (queryCompound t calcDay dsPaidD)
return f { F.feeDue = fromRational dueAmt, F.feeDueDate = Just calcDay}
calcDueFee t@TestDeal{ pool = pool } calcDay f@(F.Fee fn (F.ByCollectPeriod amt) fs fd fdday fa lpd _)
= Right $ f {F.feeDue = dueAmt + fd, F.feeDueDate = Just calcDay}
where
txnsDates = getDate <$> getAllCollectedTxnsList t (Just [PoolConsol])
pastPeriods = case fdday of
Nothing -> subDates II fs calcDay txnsDates
Just lastFeeDueDay -> subDates EI lastFeeDueDay calcDay txnsDates
dueAmt = fromRational $ mulBInt amt (length pastPeriods)
calcDueFee t calcDay f@(F.Fee fn (F.AmtByTbl _ ds tbl) fs fd fdday fa lpd _)
= do
lookupVal <- queryCompound t calcDay (patchDateToStats calcDay ds)
let dueAmt = fromMaybe 0.0 $ lookupTable tbl Up ( fromRational lookupVal >=)
return f {F.feeDue = dueAmt + fd, F.feeDueDate = Just calcDay}
calcDueFee t calcDay f@(F.Fee fn (F.FeeFlowByPoolPeriod pc) fs fd fdday fa lpd stmt)
= do
currentPoolPeriod <- queryCompound t calcDay (DealStatInt PoolCollectedPeriod)
feePaidAmt <- queryCompound t calcDay (FeePaidAmt [fn])
let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentPoolPeriod)))
return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay}
calcDueFee t calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lpd stmt)
= do
currentBondPeriod <- queryCompound t calcDay (DealStatInt BondPaidPeriod)
feePaidAmt <- queryCompound t calcDay (FeePaidAmt [fn])
let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentBondPeriod)))
return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay}
disableLiqProvider :: Ast.Asset a => TestDeal a -> Date -> CE.LiqFacility -> CE.LiqFacility
disableLiqProvider _ d liq@CE.LiqFacility{CE.liqEnds = Just endDate }
| d > endDate = liq{CE.liqCredit = Just 0}
| otherwise = liq
disableLiqProvider _ d liq@CE.LiqFacility{CE.liqEnds = Nothing } = liq
-- refresh available balance
---- for Replenish Support and ByPct
updateLiqProvider :: Ast.Asset a => TestDeal a -> Date -> CE.LiqFacility -> CE.LiqFacility
updateLiqProvider t d liq@CE.LiqFacility{CE.liqType = liqType, CE.liqCredit = curCredit}
= disableLiqProvider t d $ liq { CE.liqCredit = newCredit }
where
-- TODO ,need to remove due int and due fee
newCredit = case liqType of
-- CE.ReplenishSupport _ b -> max b <$> curCredit
CE.ByPct ds _r -> case (* _r) <$> (queryCompound t d (patchDateToStats d ds)) of
Left y -> Nothing -- TODO tobe fix error
Right x -> (min (fromRational x)) <$> curCredit
_ -> curCredit
-- ^TODO : to be replace from L.accrueInt
-- Not possible to use L.accrueInt, since the interest may use formula to query on deal's stats
calcDueInt :: Ast.Asset a => TestDeal a -> Date -> L.Bond -> Either String L.Bond
calcDueInt t d b@(L.BondGroup bMap pt)
= do
m <- mapM (calcDueInt t d) bMap
return $ L.BondGroup m pt
-- first time to accrue interest\
-- use default date to start to accrue
calcDueInt t@TestDeal{ status = st} d b@(L.Bond _ bt oi io _ bal r dp _ di Nothing _ _ _ )
| bal+di == 0 && (bt /= L.IO) = Right b
| otherwise =
do
sd <- getClosingDate (dates t)
b' <- calcDueInt t d (b {L.bndDueIntDate = Just sd }) -- `debug` ("hit")
return b'
-- Interest Only Bond with Reference Balance
calcDueInt t d b@(L.Bond _ L.IO oi (L.RefBal refBal ii) _ bal r dp dInt dioi (Just lastIntDueDay) _ _ _ )
= do
balUsed <- queryCompound t d refBal -- `debug` ("Hit acc int"++show d ++" bond name"++ L.bndName b)
let newDueInt = IR.calcInt (fromRational balUsed) lastIntDueDay d r
(fromMaybe DC_ACT_365F (L.getDayCountFromInfo ii)) -- `debug` ("Balused" ++ show (fromRational balUsed) ++ "lastIntDueDay"++show lastIntDueDay ++ "d"++show d ++ "r"++show r)
return b { L.bndDueInt = newDueInt + dInt, L.bndDueIntDate = Just d }
-- Z bond
calcDueInt t d b@(L.Bond bn L.Z bo bi _ bond_bal bond_rate _ _ _ _ lstIntPay _ _)
= Right $ b {L.bndDueInt = 0 }
-- Won't accrue interest for Equity bond
calcDueInt t d b@(L.Bond _ L.Equity _ _ _ _ _ _ _ _ _ _ _ _)
= Right b
-- accrued with interest over interest
calcDueInt t d b@(L.Bond bn bt bo (L.WithIoI intInfo ioiIntInfo) _ bond_bal bond_rate _ intDue ioiIntDue (Just int_due_date) lstIntPay _ _ )
=
let
ioiRate = case ioiIntInfo of
L.OverCurrRateBy factor -> bond_rate * fromRational (1+factor)
L.OverFixSpread spd -> bond_rate + spd
newIoiInt = IR.calcInt intDue int_due_date d ioiRate DC_ACT_365F
ioiInt = newIoiInt + ioiIntDue -- add ioi int due with new accrued ioi int
newBond = b { L.bndDueIntOverInt = ioiInt, L.bndInterestInfo = intInfo }
in
do
newBondWithIntInfo <- calcDueInt t d newBond
return newBondWithIntInfo { L.bndInterestInfo = L.WithIoI intInfo ioiIntInfo}
-- TODO: to enable override rate & balance
-- accure interest by rate
calcDueInt t d b@(L.MultiIntBond {})
= Right $ L.accrueInt d b
calcDueInt t d b@(L.Bond {})
= Right $ L.accrueInt d b -- `debug` ("Hit to defualt accru"++ show (L.bndName b))
-- ^ modify due principal for bond
calcDuePrin :: Ast.Asset a => TestDeal a -> Date -> L.Bond -> Either String L.Bond
calcDuePrin t d b@(L.BondGroup bMap pt)
= do
m <- sequenceA $ Map.map (calcDuePrin t d) bMap
return $ L.BondGroup m pt
calcDuePrin t d b =
let
bondBal = L.bndBalance b
in
do
tBal <- calcBondTargetBalance t d b
return $ b {L.bndDuePrin = max 0 (bondBal - tBal) }
priceAssetUnion :: ACM.AssetUnion -> Date -> PricingMethod -> AP.AssetPerf -> Maybe [RateAssumption]
-> Either String PriceResult
priceAssetUnion (ACM.MO m) d pm aps mras = Ast.priceAsset m d pm aps mras Inc
priceAssetUnion (ACM.LO m) d pm aps mras = Ast.priceAsset m d pm aps mras Inc
priceAssetUnion (ACM.IL m) d pm aps mras = Ast.priceAsset m d pm aps mras Inc
priceAssetUnion (ACM.LS m) d pm aps mras = Ast.priceAsset m d pm aps mras Inc
priceAssetUnion (ACM.RE m) d pm aps mras = Ast.priceAsset m d pm aps mras Inc
priceAssetUnion (ACM.PF m) d pm aps mras = Ast.priceAsset m d pm aps mras Inc
priceAssetUnion (ACM.FA m) d pm aps mras = Ast.priceAsset m d pm aps mras Inc
priceAssetUnionList :: [ACM.AssetUnion] -> Date -> PricingMethod -> AP.ApplyAssumptionType -> Maybe [RateAssumption]
-> Either String [PriceResult]
priceAssetUnionList assetList d pm (AP.PoolLevel assetPerf) mRates
= sequenceA [ priceAssetUnion asset d pm assetPerf mRates | asset <- assetList ]
-- | this would used in `static` revolving ,which assumes the revolving pool will decrease
splitAssetUnion :: [Rate] -> ACM.AssetUnion -> [ACM.AssetUnion]
splitAssetUnion rs (ACM.MO m) = [ ACM.MO a | a <- Ast.splitWith m rs]
splitAssetUnion rs (ACM.LO m) = [ ACM.LO a | a <- Ast.splitWith m rs]
splitAssetUnion rs (ACM.IL m) = [ ACM.IL a | a <- Ast.splitWith m rs]
splitAssetUnion rs (ACM.LS m) = [ ACM.LS a | a <- Ast.splitWith m rs]
splitAssetUnion rs (ACM.RE m) = [ ACM.RE a | a <- Ast.splitWith m rs]
splitAssetUnion rs (ACM.FA m) = [ ACM.FA a | a <- Ast.splitWith m rs]
-- ^ return assets bought and pool after bought
buyRevolvingPool :: Date -> Rate -> RevolvingPool -> ([ACM.AssetUnion],RevolvingPool)
buyRevolvingPool _ 0 rp = ([],rp)
buyRevolvingPool _ r rp@(StaticAsset assets)
= let
splitRatios = if r >= 1 then
[1.0,0]
else
[r,1-r]
splitedAssets = splitAssetUnion splitRatios <$> assets
assetBought = head <$> splitedAssets
assetRemains = last <$> splitedAssets
in
(assetBought ,StaticAsset assetRemains)
buyRevolvingPool _ r rp@(ConstantAsset assets)
= let
splitedAssets = splitAssetUnion [r,0] <$> assets
assetBought = head <$> splitedAssets
in
(assetBought ,rp)
buyRevolvingPool d r rp@(AssetCurve aus)
= let
splitRatios = if r >= 1 then
[1.0,0]
else
[r,1-r]
assets = lookupAssetAvailable rp d
splitedAssets = splitAssetUnion splitRatios <$> assets
assetBought = head <$> splitedAssets
in
(assetBought, rp)
data RunContext a = RunContext{
runPoolFlow:: Map.Map PoolId CF.PoolCashflow
,revolvingAssump:: Maybe (Map.Map String (RevolvingPool ,AP.ApplyAssumptionType))
,revolvingInterestRateAssump:: Maybe [RateAssumption]
}
deriving (Show)
updateOriginDate2 :: Date -> ACM.AssetUnion -> ACM.AssetUnion
updateOriginDate2 d (ACM.LO m) = ACM.LO $ updateOriginDate m (Ast.calcAlignDate m d)
updateOriginDate2 d (ACM.MO m) = ACM.MO $ updateOriginDate m (Ast.calcAlignDate m d)
updateOriginDate2 d (ACM.IL m) = ACM.IL $ updateOriginDate m (Ast.calcAlignDate m d)
updateOriginDate2 d (ACM.LS m) = ACM.LS $ updateOriginDate m (Ast.calcAlignDate m d)
updateOriginDate2 d (ACM.RE m) = ACM.RE $ updateOriginDate m (Ast.calcAlignDate m d)
-- ^ get available supports in balance
evalExtraSupportBalance :: Ast.Asset a => Date -> TestDeal a -> W.ExtraSupport -> Either String Balance
evalExtraSupportBalance d t (W.WithCondition pre s)
= do
flag <- testPre d t pre
if flag then
evalExtraSupportBalance d t s
else
return 0
evalExtraSupportBalance d t@TestDeal{accounts=accMap} (W.SupportAccount an _)
= return $ A.accBalance $ accMap Map.! an
evalExtraSupportBalance d t@TestDeal{liqProvider=Just liqMap} (W.SupportLiqFacility liqName)
= return 1e100
-- = [ fromMaybe 1e100 (CE.liqCredit (liqMap Map.! liqName))] -- `debug` ("Returning"++ show [ fromMaybe 1e100 (CE.liqCredit (liqMap Map.! liqName))])
-- = [ fromMaybe (fromRational (toRational infinity)) (CE.liqCredit (liqMap Map.! liqName))] -- `debug` ("Returning"++ show [ fromMaybe 1e100 (CE.liqCredit (liqMap Map.! liqName))])
evalExtraSupportBalance d t (W.MultiSupport supports)
= sum <$> (sequenceA [ (evalExtraSupportBalance d t sp) | sp <- supports ])
-- ^ draw support from a deal , return updated deal,and remaining oustanding amount
drawExtraSupport :: Date -> Amount -> W.ExtraSupport -> TestDeal a -> (TestDeal a, Amount)
-- ^ draw account support and book ledger
drawExtraSupport d amt (W.SupportAccount an (Just (dr, ln))) t@TestDeal{accounts=accMap, ledgers= Just ledgerMap}
= let
drawAmt = min (A.accBalance (accMap Map.! an)) amt
oustandingAmt = amt - drawAmt
in
(t {accounts = Map.adjust (A.draw drawAmt d Types.SupportDraw) an accMap
,ledgers = Just $ Map.adjust (LD.entryLog drawAmt d (TxnDirection dr)) ln ledgerMap}
, oustandingAmt)
-- ^ draw account support
drawExtraSupport d amt (W.SupportAccount an Nothing) t@TestDeal{accounts=accMap}
= let
drawAmt = min (A.accBalance (accMap Map.! an)) amt
oustandingAmt = amt - drawAmt
in
(t {accounts = Map.adjust (A.draw drawAmt d Types.SupportDraw) an accMap }
, oustandingAmt)
-- ^ draw support from liquidity facility
drawExtraSupport d amt (W.SupportLiqFacility liqName) t@TestDeal{liqProvider= Just liqMap}
= let
theLiqProvider = liqMap Map.! liqName
drawAmt = case CE.liqCredit theLiqProvider of
Nothing -> amt -- `debug` ("From amt"++ show amt)
Just b -> min amt b -- `debug` ("From Just"++ show b++">>"++show amt)
oustandingAmt = amt - drawAmt -- `debug` ("Draw Amt"++show drawAmt++">>"++ show amt ++">>>")
in
(t {liqProvider = Just (Map.adjust (CE.draw drawAmt d) liqName liqMap)}
, oustandingAmt)
-- ^ draw multiple supports by sequence
drawExtraSupport d amt (W.MultiSupport supports) t
= foldr
(\support (deal,remainAmt) -> drawExtraSupport d remainAmt support deal)
(t, amt)
supports
inspectListVars :: Ast.Asset a => TestDeal a -> Date -> [DealStats] -> Either String [ResultComponent]
inspectListVars t d dss = sequenceA [ inspectVars t d ds | ds <- dss]
inspectVars :: Ast.Asset a => TestDeal a -> Date -> DealStats -> Either String ResultComponent
inspectVars t d ds =
case getDealStatType ds of
RtnRate -> do
q <- queryCompound t d (patchDateToStats d ds)
return $ InspectRate d ds $ fromRational q
RtnBool -> do
q <- queryDealBool t (patchDateToStats d ds) d
return $ InspectBool d ds q
RtnInt -> do
q <- queryCompound t d (patchDateToStats d ds)
return $ InspectInt d ds $ round . fromRational $ q
_ -> do
q <- queryCompound t d (patchDateToStats d ds)
return $ InspectBal d ds $ fromRational q
showInspection :: ResultComponent -> String
showInspection (InspectRate d ds r) = show r
showInspection (InspectBool d ds r) = show r
showInspection (InspectInt d ds r) = show r
showInspection (InspectBal d ds r) = show r
showInspection x = error $ "not implemented for showing ResultComponent " ++ show x
calcAvailFund :: Ast.Asset a => TestDeal a -> Date -> A.Account -> Maybe W.ExtraSupport -> Either String Balance
calcAvailFund t d acc Nothing = Right $ A.accBalance acc
calcAvailFund t d acc (Just support) = ((A.accBalance acc) +) <$> evalExtraSupportBalance d t support
-- ^ Deal, Date , cap balance, due balance
applyLimit :: Ast.Asset a => TestDeal a -> Date -> Balance -> Balance -> Maybe Limit -> Either String Balance
applyLimit t d availBal dueBal Nothing = Right $ min availBal dueBal
applyLimit t d availBal dueBal (Just limit) =
(min dueBal) <$>
case limit of
DueCapAmt amt -> Right $ min amt availBal
DS ds -> do
v <- queryCompound t d (patchDateToStats d ds)
return (min (fromRational v) availBal)
DuePct pct -> Right $ min availBal $ mulBR dueBal pct
x -> Left $ "Date:"++show d ++" Unsupported limit found:"++ show x
calcAvailAfterLimit :: Ast.Asset a => TestDeal a -> Date -> A.Account -> Maybe W.ExtraSupport
-> Balance -> (Maybe Limit) -> Either String Balance
calcAvailAfterLimit t d acc mSupport dueAmt mLimit
= let
availFund = case mSupport of
Nothing -> Right $ A.accBalance acc
Just support -> ((A.accBalance acc) +) <$> evalExtraSupportBalance d t support
in
do
r <- (min dueAmt) <$>
case mLimit of
Nothing -> availFund
Just (DueCapAmt amt) -> min amt <$> availFund
Just (DS ds) -> liftA2 min (fromRational <$> (queryCompound t d (patchDateToStats d ds))) availFund
Just (DuePct pct) -> min (mulBR dueAmt pct) <$> availFund
_ -> Left ("Failed to find <limit> type"++ show mLimit)
if r < 0 then
(Left ("Negative value when calculates Limit:"++ show mLimit++ "but got from availFund"++ show availFund))
else
return r
updateSupport :: Ast.Asset a => Date -> Maybe W.ExtraSupport -> Balance -> TestDeal a -> TestDeal a
updateSupport _ Nothing _ t = t
updateSupport d (Just support) bal t = fst $ drawExtraSupport d bal support t
performActionWrap :: Ast.Asset a => Date -> (TestDeal a, RunContext a, DL.DList ResultComponent)
-> W.Action -> Either String (TestDeal a, RunContext a, DL.DList ResultComponent)
performActionWrap d (t, rc, logs) (W.BuyAsset ml pricingMethod accName pId)
= performActionWrap d (t, rc, logs) (W.BuyAssetFrom ml pricingMethod accName (Just "Consol") pId)
performActionWrap d
(t@TestDeal{ accounts = accsMap , pool = pt}
,rc@RunContext{runPoolFlow=pFlowMap
,revolvingAssump=Just rMap
,revolvingInterestRateAssump = mRates}
,logs)
(W.BuyAssetFrom ml pricingMethod accName mRevolvingPoolName pId)
=
let
revolvingPoolName = fromMaybe "Consol" mRevolvingPoolName
(assetForSale::RevolvingPool, perfAssumps::AP.ApplyAssumptionType) = rMap Map.! revolvingPoolName -- `debug` ("Getting pool"++ revolvingPoolName)
_assets = lookupAssetAvailable assetForSale d
assets = updateOriginDate2 d <$> _assets -- `debug` ("Asset on revolv"++ show _assets)
accBal = A.accBalance $ accsMap Map.! accName
pIdToChange = fromMaybe PoolConsol pId --`debug` ("purchase date"++ show d++ "\n" ++ show assetBought)
in
do
limitAmt <- case ml of
Just (DS ds) -> queryCompound t d (patchDateToStats d ds)
Just (DueCapAmt amt) -> Right (toRational amt)
Just (DuePct pct) -> Right $ toRational (mulBR accBal pct)
Nothing -> Right (toRational accBal)
let availBal = min (fromRational limitAmt) accBal -- `debug` ("Date"++ show d ++" Value on r -asset "++ show valuationOnAvailableAssets)
valOnAvailableAssets <- priceAssetUnionList assets d pricingMethod perfAssumps mRates
let valuationOnAvailableAssets = sum $ getPriceValue <$> valOnAvailableAssets
let purchaseAmt = case assetForSale of
(StaticAsset _) -> min availBal valuationOnAvailableAssets -- `debug` ("Valuation on rpool"++show valuationOnAvailableAssets)
ConstantAsset _ -> availBal
AssetCurve _ -> min availBal valuationOnAvailableAssets
let purchaseRatio = divideBB purchaseAmt valuationOnAvailableAssets -- `debug` ("In Buy >>> Date"++ show d ++ " Purchase Amt"++show purchaseAmt++">> avail value on availAsset"++ show valuationOnAvailableAssets )
let (assetBought,poolAfterBought) = buyRevolvingPool d (toRational purchaseRatio) assetForSale -- `debug` ("In Buy >>> date "++ show d ++ "purchase ratio"++ show purchaseRatio)
let boughtAssetBal = sum $ curBal <$> assetBought -- `debug` ("In Buy >>> Asset bought 0 \n"++ show assetBought++ "pflow map\n"++ show pFlowMap++" p id to change\n"++ show pIdToChange)
-- update runtime balance
let newPt = case pt of
MultiPool pm -> MultiPool $ Map.adjust
(over P.poolIssuanceStat (Map.adjust (+ boughtAssetBal) RuntimeCurrentPoolBalance))
pIdToChange
pm
ResecDeal _ -> error "Not implement on buy resec deal"
let newAccMap = Map.adjust (A.draw purchaseAmt d (PurchaseAsset revolvingPoolName boughtAssetBal)) accName accsMap -- `debug` ("Asset bought total bal"++ show boughtAssetBal)
(cfBought ,_)<- projAssetUnionList [updateOriginDate2 d ast | ast <- assetBought ] d perfAssumps mRates -- `debug` ("Date: " ++ show d ++ "Asset bought"++ show [updateOriginDate2 d ast | ast <- assetBought ])
let newPcf = Map.adjust (\(cfOrigin@(CF.CashFlowFrame st trs), mAflow) ->
let
dsInterval = getDate <$> trs
boughtCfDates = getDate <$> view CF.cashflowTxn cfBought
newAggDates = case (dsInterval,boughtCfDates) of
([],[]) -> []
(_,[]) -> []
([],_) -> boughtCfDates
(oDs,bDs) ->
let
lastOdate = last oDs
lastBdate = last bDs
in
if lastOdate > lastBdate then
[]
else
sliceDates (SliceAfter lastOdate) bDs
-- TODO: the cfOrigin may not have correct beg balance ,which doesn't match all the amortization of cashflow txn
mergedCf = CF.mergePoolCf2 cfOrigin cfBought
in
((over CF.cashflowTxn (`CF.aggTsByDates` (dsInterval ++ newAggDates)) mergedCf), (++ [cfBought]) <$> mAflow)
)
pIdToChange
pFlowMap
let newRc = rc {runPoolFlow = newPcf -- `debug` ("In Buy>>>"++show d ++ "New run pool >> \n"++ show newPcf)
,revolvingAssump = Just (Map.insert revolvingPoolName (poolAfterBought, perfAssumps) rMap)}
return (t { accounts = newAccMap , pool = newPt}, newRc, logs)
performActionWrap d
(t
,rc@RunContext{runPoolFlow=pcf
,revolvingAssump=Nothing
,revolvingInterestRateAssump=mRates}
,logs)
(W.BuyAsset ml pricingMethod accName _)
= Left $ "Date:"++ show d ++"Missing revolving Assumption(asset assumption & asset to buy)" ++ name t
performActionWrap d
(t
,rc@RunContext{runPoolFlow=pcf
,revolvingAssump=Nothing
,revolvingInterestRateAssump=mRates}
,logs)
(W.BuyAssetFrom _ _ _ _ _)
= Left $ "Date:"++ show d ++"Missing revolving Assumption(asset assumption & asset to buy)" ++ name t
-- TODO need to set a limit to sell
performActionWrap d
(t@TestDeal{accounts = accMap, pool = pt}
,rc@RunContext{runPoolFlow = pcf}
,logs)
(W.LiquidatePool lm an mPid)
= let
liqFunction = \(p@P.Pool{ P.issuanceStat = m} )
-> over (P.poolFutureScheduleCf . _Just . _1) (CF.extendCashFlow d) $
over (P.poolFutureCf . _Just . _1 ) (CF.extendCashFlow d) $
p { P.issuanceStat = Just (Map.insert RuntimeCurrentPoolBalance 0 (fromMaybe Map.empty m)) }
poolMapToLiq = case (pt, mPid) of
(MultiPool pm, Nothing) -> pm
(MultiPool pm,Just pids) -> let
selectedPids = S.fromList pids
in
Map.filterWithKey (\k v -> S.member k selectedPids) pm
(ResecDeal _,_) -> error "Not implement on liquidate resec deal"
liqAmtByPool = Map.mapWithKey (\k p -> P.pricingPoolFlow d p (pcf Map.! k) lm) poolMapToLiq -- `debug` ("pool id to liq"++ show poolMapToLiq)
liqAmt = sum $ Map.elems liqAmtByPool
-- Update collected cashflow
newPt = case (pt, mPid) of
(MultiPool pm, Nothing) -> MultiPool $ Map.map liqFunction pm
(MultiPool pm, Just pids) -> let
selectedPids = S.fromList pids
selectedPoolMap = Map.filterWithKey (\k v -> S.member k selectedPids) pm
in
MultiPool $ Map.union (Map.map liqFunction selectedPoolMap) pm
(ResecDeal _,_) -> error "Not implement on liquidate resec deal"
liqComment = LiquidationProceeds (fromMaybe [] mPid)
accMapAfterLiq = Map.adjust (A.deposit liqAmt d liqComment) an accMap
-- REMOVE future cf
newPfInRc = foldr (Map.adjust (set (_1 . CF.cashflowTxn) [])) pcf (Map.keys poolMapToLiq)
-- Update current balance to zero
in
Right (t {accounts = accMapAfterLiq , pool = newPt} , rc {runPoolFlow = newPfInRc}, logs)
performActionWrap d (t, rc, logs) (W.WatchVal ms dss)
= (inspectListVars t d dss) >>= (\vs -> Right (t, rc, DL.snoc logs (InspectWaterfall d ms dss (showInspection <$> vs))))
performActionWrap d (t, rc, logs) (W.ActionWithPre p actions)
= do
flag <- testPre d t p
if flag then
foldM (performActionWrap d) (t,rc,logs) actions
else
return (t, rc, logs)
performActionWrap d (t, rc, logs) (W.ActionWithPre2 p actionsTrue actionsFalse)
= do
flag <- testPre d t p
if flag then
foldM (performActionWrap d) (t,rc,logs) actionsTrue
else
foldM (performActionWrap d) (t,rc,logs) actionsFalse
performActionWrap d (t, rc, logs) (W.ChangeStatus mPre newSt)
= case mPre of
Nothing -> return (t {status=newSt} , rc, logs)
Just p ->
do
flag <- testPre d t p
if flag then
return (t {status=newSt} , rc, logs)
else
return (t, rc, logs)
-- ^ go down to performAction
performActionWrap d (t, rc, logs) a
= do
dealAfterExe <- performAction d t a
return (dealAfterExe, rc, logs)
performAction :: Ast.Asset a => Date -> TestDeal a -> W.Action -> Either String (TestDeal a)
performAction d t@TestDeal{accounts=accMap, ledgers = Just ledgerM}
(W.TransferAndBook mLimit an1 an2 (dr, lName) mComment)
= let
sourceAcc = accMap Map.! an1
targetAcc = accMap Map.! an2
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an1) Nothing (A.accBalance sourceAcc) mLimit
in
do
transferAmt <- actualPaidOut
let accMapAfterDraw = Map.adjust (A.draw transferAmt d (TxnComments [Transfer an1 an2,(BookLedgerBy dr lName)])) an1 accMap -- `debug` (">>PDL >>Ledger bal"++show d ++ show targetAmt)
let accMapAfterDeposit = Map.adjust (A.deposit transferAmt d (TxnComments [Transfer an1 an2,(BookLedgerBy dr lName)])) an2 accMapAfterDraw
let newLedgerM = Map.adjust (LD.entryLog transferAmt d (TxnDirection dr)) lName ledgerM
return t {accounts = accMapAfterDeposit, ledgers = Just newLedgerM}
performAction d t@TestDeal{accounts=accMap} (W.Transfer mLimit an1 an2 mComment)
= let
sourceAcc = accMap Map.! an1
targetAcc = accMap Map.! an2
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an1) Nothing (A.accBalance sourceAcc) mLimit
in
do
transferAmt <- actualPaidOut
let accMapAfterDraw = Map.adjust (A.draw transferAmt d (Transfer an1 an2)) an1 accMap -- `debug` (">>PDL >>Ledger bal"++show d ++ show targetAmt)
let accMapAfterDeposit = Map.adjust (A.deposit transferAmt d (Transfer an1 an2)) an2 accMapAfterDraw
return t {accounts = accMapAfterDeposit}
performAction d t@TestDeal{accounts=accMap} (W.TransferMultiple sourceAccList targetAcc mComment)
= foldM (\acc (mLimit, sourceAccName) ->
performAction d acc (W.Transfer mLimit sourceAccName targetAcc mComment))
t
sourceAccList
-- ^ book ledger
performAction d t@TestDeal{ledgers= Just ledgerM} (W.BookBy (W.Till ledger dr ds)) =
do
targetAmt <- queryCompound t d ds
let (bookDirection, amtToBook) = LD.bookToTarget (ledgerM Map.! ledger) (dr, fromRational targetAmt)
let newLedgerM = Map.adjust (LD.entryLogByDr bookDirection amtToBook d Nothing) ledger ledgerM
return $ t {ledgers = Just newLedgerM }
performAction d t@TestDeal{ledgers= Just ledgerM} (W.BookBy (W.ByDS ledger dr ds)) =
do
amtToBook <- queryCompound t d ds
let newLedgerM = Map.adjust (LD.entryLogByDr dr (fromRational amtToBook) d Nothing) ledger ledgerM
return $ t {ledgers = Just newLedgerM }
-- ^ it will book ledgers by order with mandatory caps which describes by a <formula>
-- ^ ds -> value to book
-- ^ ledgersList -> list of ledgers to book
performAction d t@TestDeal{ledgers= Just ledgerM} (W.BookBy (W.PDL dr ds ledgersList)) =
let
ledgerCaps = sequenceA [ queryCompound t d ledgerCap | ledgerCap <- snd <$> ledgersList ]
ledgerNames = fst <$> ledgersList
in
do
amtToBook <- queryCompound t d ds
ledgCaps <- ledgerCaps
let amtBookedToLedgers = paySeqLiabilitiesAmt (fromRational amtToBook) (fromRational <$> ledgCaps) --`debug` ("amt to book"++ show amtToBook)
let newLedgerM = foldr
(\(ln,amt) acc -> Map.adjust (LD.entryLogByDr dr amt d Nothing) ln acc)
ledgerM
(zip ledgerNames amtBookedToLedgers) --`debug` ("amts to book"++ show amtBookedToLedgers)
return $ t {ledgers = Just newLedgerM}
-- ^ pay fee sequentially, but not accrued
performAction d t@TestDeal{fees=feeMap, accounts=accMap} (W.PayFeeBySeq mLimit an fns mSupport) =
let
availAccBal = A.accBalance (accMap Map.! an)
feesToPay = map (feeMap Map.!) fns
totalFeeDue = sum $ map F.feeDue feesToPay
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalFeeDue mLimit
in
do
paidOutAmt <- actualPaidOut
let (feesPaid, remainAmt) = paySequentially d paidOutAmt F.feeDue (F.payFee d) [] feesToPay
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (SeqPayFee fns)) an accMap
,fees = Map.fromList (zip fns feesPaid) <> feeMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
-- ^ pay out fee in pro-rata fashion
performAction d t@TestDeal{fees=feeMap, accounts=accMap} (W.PayFee mLimit an fns mSupport) =
let
availAccBal = A.accBalance (accMap Map.! an)
feesToPay = map (feeMap Map.!) fns
totalFeeDue = sum $ map F.feeDue feesToPay
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalFeeDue mLimit
in
do
paidOutAmt <- actualPaidOut
let (feesPaid, remainAmt) = payProRata d paidOutAmt F.feeDue (F.payFee d) feesToPay
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (SeqPayFee fns)) an accMap
,fees = Map.fromList (zip fns feesPaid) <> feeMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
performAction d t (W.AccrueAndPayIntBySeq mLimit an bnds mSupport)
= do
dealWithBondDue <- performAction d t (W.CalcBondInt bnds)
performAction d dealWithBondDue (W.PayIntBySeq mLimit an bnds mSupport)
performAction d t@TestDeal{bonds=bndMap, accounts=accMap, liqProvider=liqMap}
(W.PayIntOverIntBySeq mLimit an bnds mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsList = (Map.!) bndMap <$> bnds
dueAmts = L.getDueIntOverInt <$> bndsList
totalDue = sum dueAmts
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit
in
do
paidOutAmt <- actualPaidOut
let (bondsPaid, remainAmt) = paySequentially d paidOutAmt L.getDueIntOverInt (L.payInt d) [] bndsList
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayInt bnds)) an accMap
,bonds = Map.fromList (zip bnds bondsPaid) <> bndMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
performAction d t@TestDeal{bonds=bndMap, accounts=accMap, liqProvider=liqMap}
(W.PayIntBySeq mLimit an bnds mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsList = (Map.!) bndMap <$> bnds
dueAmts = L.getTotalDueInt <$> bndsList
totalDue = sum dueAmts
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit
in
do
paidOutAmt <- actualPaidOut
let (bondsPaid, remainAmt) = paySequentially d paidOutAmt L.getTotalDueInt (L.payInt d) [] bndsList
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayInt bnds)) an accMap
,bonds = Map.fromList (zip bnds bondsPaid) <> bndMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
performAction d t@TestDeal{bonds=bndMap,accounts=accMap}
(W.PayIntOverInt mLimit an bnds mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsList = (Map.!) bndMap <$> bnds
dueAmts = L.getDueIntOverInt <$> bndsList
totalDue = sum dueAmts
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit
in
do
paidOutAmt <- actualPaidOut
let (bondsPaid, remainAmt) = payProRata d paidOutAmt L.getDueIntOverInt (L.payInt d) bndsList
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayInt bnds)) an accMap
,bonds = Map.fromList (zip bnds bondsPaid) <> bndMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
performAction d t@TestDeal{bonds=bndMap,accounts=accMap}
(W.PayInt mLimit an bnds mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsList = (Map.!) bndMap <$> bnds
dueAmts = L.getTotalDueInt <$> bndsList
totalDue = sum dueAmts
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit
in
do
paidOutAmt <- actualPaidOut
let (bondsPaid, remainAmt) = payProRata d paidOutAmt L.getTotalDueInt (L.payInt d) bndsList
let accPaidOut = (min availAccBal paidOutAmt)
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayInt bnds)) an accMap
,bonds = Map.fromList (zip bnds bondsPaid) <> bndMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
performAction d t@TestDeal{bonds=bndMap,accounts=accMap,ledgers= Just ledgerM}
(W.PayIntAndBook mLimit an bnds mSupport (dr, lName))
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsList = (Map.!) bndMap <$> bnds
dueAmts = L.getTotalDueInt <$> bndsList
totalDue = sum dueAmts
actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit
in
do
paidOutAmt <- actualPaidOut
let (bondsPaid, remainAmt) = payProRata d paidOutAmt L.getTotalDueInt (L.payInt d) bndsList
let accPaidOut = min availAccBal paidOutAmt
let newLedgerM = Map.adjust (LD.entryLogByDr dr paidOutAmt d Nothing) lName ledgerM
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayInt bnds)) an accMap
,bonds = Map.fromList (zip bnds bondsPaid) <> bndMap
,ledgers = Just newLedgerM}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
performAction d t (W.AccrueAndPayInt mLimit an bnds mSupport) =
do
dealWithBondDue <- performAction d t (W.CalcBondInt bnds)
performAction d dealWithBondDue (W.PayInt mLimit an bnds mSupport)
performAction d t (W.CalcAndPayFee mLimit ans fees mSupport) =
do
dealWithFeeDue <- performAction d t (W.CalcFee fees)
performAction d dealWithFeeDue (W.PayFee mLimit ans fees mSupport)
performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayIntResidual mLimit an bndName) =
let
availBal = A.accBalance $ accMap Map.! an
in
do
limitAmt <- applyLimit t d availBal availBal mLimit
return $ t {accounts = Map.adjust (A.draw limitAmt d (PayYield bndName)) an accMap
, bonds = Map.adjust (L.payYield d limitAmt) bndName bndMap}
-- TODO check for multi interest bond
performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayIntByRateIndex mLimit an bndNames idx mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsList = filter (is L._MultiIntBond) $ (Map.!) bndMap <$> bndNames
bndNames_ = L.bndName <$> bndsList
in
do
totalDue <- queryCompound t d (CurrentDueBondIntTotalAt idx bndNames_)
actualPaidOut <- calcAvailAfterLimit t d (accMap Map.! an) mSupport (fromRational totalDue) mLimit -- `debug` ("Date "++ show d ++" total due"++show (fromRational totalDue))
let (paidBonds, _) = payProRata d actualPaidOut (`L.getTotalDueIntAt` idx) (L.payIntByIndex d idx) bndsList -- `debug` ("Date"++show d++" paid out amt"++show (L.bndDueInts (paidBonds!!0)))
let accMap1 = accMap -- `debug` ("Date"++show d++" paid out amt"++show (L.bndDueInts (paidBonds!!0)))
return $ t {accounts = Map.adjust (A.draw actualPaidOut d (PayInt bndNames_)) an accMap1
, bonds = Map.fromList (zip bndNames_ paidBonds) <> bndMap}
performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayIntByRateIndexBySeq mLimit an bndNames idx mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsList = filter (is L._MultiIntBond) $ (Map.!) bndMap <$> bndNames
bndNames_ = L.bndName <$> bndsList
in
do
totalDue <- queryCompound t d (CurrentDueBondIntAt idx bndNames_)
actualPaidOut <- calcAvailAfterLimit t d (accMap Map.! an) mSupport (fromRational totalDue) mLimit
let (paidBonds, _) = paySequentially d actualPaidOut (`L.getTotalDueIntAt` idx) (L.payIntByIndex d idx) [] bndsList
return $ t {accounts = Map.adjust (A.draw actualPaidOut d (PayInt bndNames_)) an accMap
, bonds = Map.fromList (zip bndNames_ paidBonds) <> bndMap}
performAction d t@TestDeal{fees=feeMap,accounts=accMap} (W.PayFeeResidual mlimit an feeName) =
let
availBal = A.accBalance $ accMap Map.! an
in
do
paidOutAmt <- applyLimit t d availBal availBal mlimit
let accMapAfterPay = Map.adjust (A.draw paidOutAmt d (PayFeeYield feeName)) an accMap
let feeMapAfterPay = Map.adjust (F.payResidualFee d paidOutAmt) feeName feeMap
return $ t {accounts = accMapAfterPay, fees = feeMapAfterPay}
performAction d t@TestDeal{bonds=bndMap,accounts=accMap}
(W.PayPrinBySeq mLimit an bnds mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsList = (Map.!) bndMap <$> bnds
bndsToPay = filter (not . L.isPaidOff) bndsList
bndsToPayNames = L.bndName <$> bndsToPay
in
do
bndsWithDue <- sequenceA $ calcDuePrin t d <$> bndsToPay
let bndsDueAmts = L.bndDuePrin <$> bndsWithDue
let totalDue = sum bndsDueAmts -- `debug` ("Date"++show d++" due amt"++show bndsDueAmts)
let actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit
paidOutAmt <- actualPaidOut -- `debug` ("Date"++show d++" paid out amt"++show actualPaidOut)
let (bondsPaid, remainAmt) = paySequentially d paidOutAmt L.bndDuePrin (L.payPrin d) [] bndsWithDue
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayPrin bndsToPayNames)) an accMap
,bonds = Map.fromList (zip bndsToPayNames bondsPaid) <> bndMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
performAction d t@TestDeal{bonds=bndMap,accounts=accMap}
(W.PayPrinGroup mLimit an bndGrpName by mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bg@(L.BondGroup bndsMap pt) = bndMap Map.! bndGrpName
bndsToPay = Map.filter (not . L.isPaidOff) bndsMap
bndsToPayNames = L.bndName <$> Map.elems bndsToPay
in
do
bndsWithDueMap <- sequenceA $ Map.map (calcDuePrin t d) bndsToPay
bgGap <- queryCompound t d (BondBalanceGapAt d bndGrpName)
let bndsDueAmtsMap = Map.map (\x -> (x, L.bndDuePrin x)) bndsWithDueMap
let actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport (fromRational bgGap) mLimit
paidOutAmt <- actualPaidOut
let payOutPlan = allocAmtToBonds by paidOutAmt (Map.elems bndsDueAmtsMap) -- `debug` (">date"++ show payAmount)
let payOutPlanWithBondName = [ (L.bndName bnd,amt) | (bnd,amt) <- payOutPlan] -- `debug` (">date"++show d++"payOutPlan"++ show payOutPlan)
let bndMapAfterPay = foldr
(\(bndName, _amt) acc -> Map.adjust (L.payPrin d _amt) bndName acc)
bndsMap
payOutPlanWithBondName -- `debug` (">date"++show d++"payoutPlan"++ show payOutPlanWithBondName)
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayGroupPrin bndsToPayNames)) an accMap
,bonds = Map.insert bndGrpName (L.BondGroup bndMapAfterPay pt) bndMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
-- ^ accure interest and payout interest to a bond group with sequence input "by"
performAction d t@TestDeal{bonds=bndMap} (W.AccrueAndPayIntGroup mLimit an bndName by mSupport)
= do
dAfterAcc <- performAction d t (W.AccrueIntGroup [bndName])-- `debug` ("Acc due int grp"++ show (getDueInt (bndMap Map.! bndName)))
performAction d dAfterAcc (W.PayIntGroup mLimit an bndName by mSupport)
-- ^ accrue interest for a group of bonds
performAction d t@TestDeal{bonds=bndMap} (W.AccrueIntGroup bndNames)
= do
let bondGrp = Map.filterWithKey (\k _ -> S.member k (S.fromList bndNames)) bndMap
bondGrpAccrued <- mapM (calcDueInt t d) bondGrp
return t {bonds = bondGrpAccrued <> bndMap}
-- ^ pay interest for a group of bonds with sequence input "by"
performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayIntGroup mLimit an bndGrpName by mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
L.BondGroup bndsMap pt = bndMap Map.! bndGrpName
bndsToPay = Map.filter (not . L.isPaidOff) bndsMap
bndsToPayNames = L.bndName <$> Map.elems bndsToPay
in
do
bndsWithDueMap <- mapM (calcDueInt t d) bndsToPay
let bndsDueAmtsMap = Map.map (\x -> (x, L.getTotalDueInt x)) bndsWithDueMap
let totalDue = sum $ snd <$> Map.elems bndsDueAmtsMap -- `debug` (">date"++show d++" due amt"++show bndsDueAmtsMap)
let actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit
paidOutAmt <- actualPaidOut
let payOutPlan = allocAmtToBonds by paidOutAmt (Map.elems bndsDueAmtsMap) -- `debug` (">date"++ show payAmount)
let payOutPlanWithBondName = [ (L.bndName bnd,amt) | (bnd,amt) <- payOutPlan] -- `debug` (">date"++show d++"payOutPlan"++ show payOutPlan)
let bndMapAfterPay = foldr
(\(bndName, _amt) acc -> Map.adjust (L.payInt d _amt) bndName acc)
bndsMap
payOutPlanWithBondName -- `debug` (">date"++show d++"payoutPlan"++ show payOutPlanWithBondName)
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayGroupInt bndsToPayNames)) an accMap
,bonds = Map.insert bndGrpName (L.BondGroup bndMapAfterPay pt) bndMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayPrinWithDue an bnds Nothing)
= Right $ t {accounts = accMapAfterPay, bonds = bndMapUpdated}
where
acc = accMap Map.! an
availBal = A.accBalance acc
bndsToPay = getActiveBonds t bnds
bndsToPayNames = L.bndName <$> bndsToPay
bndsDueAmts = L.bndDuePrin <$> bndsToPay
actualPaidOut = min availBal $ sum bndsDueAmts
(bndsPaid, remainAmt) = payProRata d actualPaidOut L.bndDuePrin (L.payPrin d) bndsToPay
bndMapUpdated = (Map.fromList $ zip bndsToPayNames bndsPaid) <> bndMap
accMapAfterPay = Map.adjust (A.draw actualPaidOut d (PayPrin bnds)) an accMap
performAction d t@TestDeal{bonds=bndMap,accounts=accMap} (W.PayPrin mLimit an bnds mSupport)
= let
availAccBal = A.accBalance (accMap Map.! an)
bndsToPay = getActiveBonds t bnds
in
do
bndsWithDue <- sequenceA $ calcDuePrin t d <$> bndsToPay
let bndsDueAmts = L.bndDuePrin <$> bndsWithDue
let bndsToPayNames = L.bndName <$> bndsWithDue
let totalDue = sum bndsDueAmts
let actualPaidOut = calcAvailAfterLimit t d (accMap Map.! an) mSupport totalDue mLimit
paidOutAmt <- actualPaidOut
let (bondsPaid, remainAmt) = payProRata d paidOutAmt L.bndDuePrin (L.payPrin d) bndsWithDue
let accPaidOut = min availAccBal paidOutAmt
let dealAfterAcc = t {accounts = Map.adjust (A.draw accPaidOut d (PayPrin bndsToPayNames)) an accMap
,bonds = Map.fromList (zip bndsToPayNames bondsPaid) <> bndMap}
let supportPaidOut = paidOutAmt - accPaidOut
return $ updateSupport d mSupport supportPaidOut dealAfterAcc
-- ^ pay principal without any limit
performAction d t@TestDeal{accounts=accMap, bonds=bndMap} (W.PayPrinResidual an bnds) =
Right $ t {accounts = accMapAfterPay, bonds = bndMapUpdated} -- `debug` ("Bond Prin Pay Result"++show(bndMapUpdated))
where
acc = accMap Map.! an
bndsToPay = getActiveBonds t bnds
bndsToPayNames = L.bndName <$> bndsToPay
availBal = A.accBalance acc
bndsDueAmts = map L.getCurBalance bndsToPay
actualPaidOut = min availBal $ sum bndsDueAmts -- `debug` ("bonds totoal due ->"++show(bndsDueAmts))
bndsAmountToBePaid = zip bndsToPay (prorataFactors bndsDueAmts actualPaidOut)
bndsPaid = map (\(l,amt) -> L.payPrin d amt l) bndsAmountToBePaid -- `debug` ("pay bonds "++show bnds ++"pay prin->>>To"++show(prorataFactors bndsDueAmts availBal))
bndMapUpdated = (Map.fromList $ zip bndsToPayNames bndsPaid) <> bndMap
accMapAfterPay = Map.adjust (A.draw actualPaidOut d (PayPrin bnds)) an accMap
performAction d t@TestDeal{accounts=accMap, bonds=bndMap} (W.FundWith mlimit an bnd) =
do
fundAmt_ <- case mlimit of
Just (DS ds) -> queryCompound t d (patchDateToStats d ds)
Just (DueCapAmt amt) -> Right $ toRational amt
_ -> Left $ "Date:"++show d ++"Not valid limit for funding with bond"++ show bnd
let fundAmt = fromRational fundAmt_
let accMapAfterFund = Map.adjust (A.deposit fundAmt d (FundWith bnd fundAmt)) an accMap
let bndFunded = L.fundWith d fundAmt $ bndMap Map.! bnd
return $ t {accounts = accMapAfterFund, bonds= Map.fromList [(bnd,bndFunded)] <> bndMap }
-- ^ write off bonds and book
performAction d t@TestDeal{bonds = bndMap, ledgers = Just ledgerM }
(W.WriteOffAndBook mLimit bnd (dr,lName))
= let
bndToWriteOff = bndMap Map.! bnd
bndBal = L.bndBalance bndToWriteOff
in
do
writeAmt <- applyLimit t d bndBal bndBal mLimit
let newLedgerM = Map.adjust (LD.entryLogByDr dr writeAmt d (Just (WriteOff bnd writeAmt))) lName ledgerM
bndWritedOff <- L.writeOff d writeAmt bndToWriteOff
return $ t {bonds = Map.fromList [(bnd,bndWritedOff)] <> bndMap, ledgers = Just newLedgerM}
performAction d t@TestDeal{bonds=bndMap} (W.WriteOff mlimit bnd)
= do
writeAmt <- case mlimit of
Just (DS ds) -> queryCompound t d (patchDateToStats d ds)
Just (DueCapAmt amt) -> Right $ toRational amt
Nothing -> Right $ toRational . L.bndBalance $ bndMap Map.! bnd
x -> Left $ "Date:"++show d ++"not supported type to determine the amount to write off"++ show x
let writeAmtCapped = min (fromRational writeAmt) $ L.bndBalance $ bndMap Map.! bnd
bndWritedOff <- L.writeOff d writeAmtCapped $ bndMap Map.! bnd
return $ t {bonds = Map.fromList [(bnd,bndWritedOff)] <> bndMap}
performAction d t@TestDeal{bonds=bndMap, ledgers = Just ledgerM}
(W.WriteOffBySeqAndBook mLimit bnds (dr,lName))
= do
bndsToWriteOff <- mapM (calcDueInt t d . (bndMap Map.!)) bnds
let totalBondBal = sum $ L.bndBalance <$> bndsToWriteOff
-- total amount to be write off
writeAmt <- applyLimit t d totalBondBal totalBondBal mLimit
(bndWrited, _) <- paySeqM d writeAmt L.bndBalance (L.writeOff d) (Right []) bndsToWriteOff
let bndMapUpdated = lstToMapByFn L.bndName bndWrited
let newLedgerM = Map.adjust (LD.entryLogByDr dr writeAmt d Nothing) lName ledgerM
return t {bonds = bndMapUpdated <> bndMap, ledgers = Just newLedgerM}
performAction d t@TestDeal{bonds=bndMap } (W.WriteOffBySeq mLimit bnds)
= do
bondsToWriteOff <- mapM (calcDueInt t d . (bndMap Map.!)) bnds
let totalBondBal = sum $ L.bndBalance <$> bondsToWriteOff
writeAmt <- applyLimit t d totalBondBal totalBondBal mLimit
(bndWrited, _) <- paySeqM d writeAmt L.bndBalance (L.writeOff d) (Right []) bondsToWriteOff
let bndMapUpdated = lstToMapByFn L.bndName bndWrited
return t {bonds = bndMapUpdated <> bndMap }
performAction d t@TestDeal{fees=feeMap} (W.CalcFee fns)
= do
newFeeMap <- mapM (calcDueFee t d) $ getFeeByName t (Just fns)
return t {fees = newFeeMap <> feeMap }
-- performAction d t@TestDeal{bonds=bndMap} (W.CalcBondIntBy bn dsBal dsRate)
-- = let
-- mBnd = case getBondByName t bn of
-- Just b -> Right b
-- Nothing -> Left $ "Cant find bond in deal"++ show bn
-- in
-- do
-- bal <- queryCompound t d (patchDateToStats d dsBal)
-- rate <- queryCompound t d (patchDateToStats d dsRate)
-- bnd <- mBnd
-- let dc = DC_ACT_365F
-- let dueInt = L.calcDueInt bnd bal rate dc
-- newBondMap <- mapM (calcDueInt t d mBalDs mRateDs) $ getBondsByName t (Just bns)
--
-- return t {bonds = newBondMap <> bndMap}
performAction d t@TestDeal{bonds=bndMap} (W.CalcBondInt bns)
= do
newBondMap <- mapM (calcDueInt t d) $ getBondsByName t (Just bns)
return t {bonds = newBondMap <> bndMap}
-- ^ set due prin mannually
performAction d t@TestDeal{bonds=bndMap} (W.CalcBondPrin2 mLimit bnds)
= let
bndsToPay = filter (not . L.isPaidOff) $ map (bndMap Map.!) bnds
bndsToPayNames = L.bndName <$> bndsToPay
in
do
bndsDueAmts <- sequenceA $ (L.bndDuePrin <$>) <$> (calcDuePrin t d) <$> bndsToPay
let totalDue = sum bndsDueAmts
bookCap <- applyLimit t d totalDue totalDue mLimit
let bndsAmountToBook = zip bndsToPayNames $ prorataFactors bndsDueAmts bookCap
let newBndMap = foldr
(\(bn,amt) acc -> Map.adjust (\b -> b {L.bndDuePrin = amt}) bn acc)
bndMap
bndsAmountToBook -- `debug` ("Calc Bond Prin"++ show bndsAmountToBePaid)
return $ t {bonds = newBndMap} -- `debug` ("New map after calc due"++ show (Map.mapWithKey (\k v -> (k, L.bndDuePrin v)) newBndMap))
performAction d t@TestDeal{bonds=bndMap, accounts = accMap} (W.CalcBondPrin mLimit accName bnds mSupport)
= let
accBal = A.accBalance $ accMap Map.! accName
bndsToPay = filter (not . L.isPaidOff) $ map (bndMap Map.!) bnds
bndsToPayNames = L.bndName <$> bndsToPay
in
do
bndsDueAmts <- sequenceA $ (L.bndDuePrin <$>) <$> (calcDuePrin t d) <$> bndsToPay
availBal <- calcAvailFund t d (accMap Map.! accName) mSupport
limitCap <- applyLimit t d availBal (sum bndsDueAmts) mLimit
let payAmount = min limitCap availBal
let bndsAmountToBePaid = zip bndsToPayNames $ prorataFactors bndsDueAmts payAmount -- (bond, amt-allocated)
let newBndMap = foldr
(\(bn,amt) acc -> Map.adjust (\b -> b {L.bndDuePrin = amt}) bn acc)
bndMap
bndsAmountToBePaid -- `debug` ("Calc Bond Prin"++ show bndsAmountToBePaid)
return $ t {bonds = newBndMap}
-- ^ draw cash and deposit to account
performAction d t@TestDeal{accounts=accs, liqProvider = Just _liqProvider} (W.LiqSupport mLimit pName CE.LiqToAcc ans)
| length ans == 1
= let
liq = _liqProvider Map.! pName
[an] = ans
in
do
transferAmt <- case (CE.liqCredit liq, mLimit) of
(Nothing, Nothing) -> Left $ "Date:"++show d ++"Can't deposit unlimit cash to an account in LiqSupport(Account):"++ show pName ++ ":"++ show an
(Just av, Nothing) -> Right . toRational $ av
(Nothing, Just (DS ds)) -> queryCompound t d (patchDateToStats d ds) -- `debug` ("hit with ds"++ show ds)
(Just av, Just (DS ds)) -> (min (toRational av)) <$> queryCompound t d (patchDateToStats d ds)
(_ , Just _x) -> Left $ "Date:"++show d ++"Not support limit in LiqSupport(Account)"++ show _x
let dAmt = fromRational transferAmt
return t { accounts = Map.adjust (A.deposit dAmt d (LiquidationSupport pName)) an accs
, liqProvider = Just $ Map.adjust (CE.draw dAmt d) pName _liqProvider }
| otherwise = Left $ "Date:"++show d ++"There should only one account for LiqToAcc of LiqSupport"
-- TODO : add pay fee by sequence
performAction d t@TestDeal{fees=feeMap,liqProvider = Just _liqProvider} (W.LiqSupport mLimit pName CE.LiqToFee fns)
= let
liq = _liqProvider Map.! pName
in
do
totalDueFee <- queryCompound t d (CurrentDueFee fns)
supportAmt <- applyLimit t d (fromRational totalDueFee) (fromRational totalDueFee) mLimit
let transferAmt = case CE.liqCredit liq of
Nothing -> supportAmt
(Just v) -> min supportAmt v
let newFeeMap = payInMap d transferAmt F.feeDue (F.payFee d) fns ByProRata feeMap
let newLiqMap = Map.adjust (CE.draw transferAmt d) pName _liqProvider
return $ t { fees = newFeeMap, liqProvider = Just newLiqMap }
-- TODO : add pay int by sequence
-- TODO : may not work for bond group
performAction d t@TestDeal{bonds=bndMap,liqProvider = Just _liqProvider}
(W.LiqSupport mLimit pName CE.LiqToBondInt bns)
= let
liq = _liqProvider Map.! pName
in
do
totalDueInt <- queryCompound t d (CurrentDueBondInt bns)
supportAmt <- applyLimit t d (fromRational totalDueInt) (fromRational totalDueInt) mLimit
let transferAmt = case CE.liqCredit liq of
Nothing -> supportAmt
(Just v) -> min supportAmt v
let newBondMap = payInMap d transferAmt L.getTotalDueInt (L.payInt d) bns ByProRata bndMap
let newLiqMap = Map.adjust (CE.draw transferAmt d) pName _liqProvider
return $ t { bonds = newBondMap, liqProvider = Just newLiqMap }
-- ^ payout due interest / due fee / oustanding balance to liq provider
performAction d t@TestDeal{accounts=accs,liqProvider = Just _liqProvider} (W.LiqRepay mLimit rpt an pName)
=
let
liqDueAmts CE.LiqBal = [ CE.liqBalance $ _liqProvider Map.! pName]
liqDueAmts CE.LiqInt = [ CE.liqDueInt $ _liqProvider Map.! pName ]
liqDueAmts CE.LiqPremium = [ CE.liqDuePremium $ _liqProvider Map.! pName]
liqDueAmts (CE.LiqRepayTypes lrts) = concat $ liqDueAmts <$> lrts
overDrawnBalance = maybe 0 negate (CE.liqCredit $ _liqProvider Map.! pName)
dueBreakdown
| overDrawnBalance > 0 = overDrawnBalance:liqDueAmts rpt
| otherwise = liqDueAmts rpt
liqTotalDues = sum dueBreakdown
cap = min liqTotalDues $ A.accBalance $ accs Map.! an
in
do
transferAmt <- applyLimit t d cap cap mLimit
let paidOutsToLiq = paySeqLiabilitiesAmt transferAmt dueBreakdown
let rptsToPair = case rpt of
CE.LiqRepayTypes lrts -> lrts
x -> [x]
let paidOutWithType
| overDrawnBalance > 0 = zip (CE.LiqOD:rptsToPair) paidOutsToLiq
| otherwise = zip rptsToPair paidOutsToLiq -- `debug` ("rpts To pair"++ show rptsToPair)
let newAccMap = Map.adjust (A.draw transferAmt d (LiquidationSupport pName)) an accs -- `debug` ("repay liq amt"++ show transferAmt)
let newLiqMap = foldl
(\acc (_rpt,_amt) -> Map.adjust (CE.repay _amt d _rpt ) pName acc)
_liqProvider
paidOutWithType
return $ t { accounts = newAccMap, liqProvider = Just newLiqMap } -- paidOutWithType -- `debug` ("paid out"++ show paidOutWithType)
-- ^ pay yield to liq provider
performAction d t@TestDeal{accounts=accs,liqProvider = Just _liqProvider} (W.LiqYield limit an pName)
=
let cap = A.accBalance $ accs Map.! an in
do
transferAmt <- case limit of
Nothing -> Right (toRational cap)
Just (DS ds) -> (min (toRational cap)) <$> (queryCompound t d (patchDateToStats d ds))
_ -> Left $ "Date:"++show d ++"Not implement the limit"++ show limit++"For Pay Yield to liqProvider"
let newAccMap = Map.adjust (A.draw (fromRational transferAmt) d (LiquidationSupport pName)) an accs
let newLiqMap = Map.adjust (CE.repay (fromRational transferAmt) d CE.LiqResidual) pName _liqProvider
return t { accounts = newAccMap, liqProvider = Just newLiqMap }
performAction d t@TestDeal{liqProvider = Just _liqProvider} (W.LiqAccrue liqNames)
= Right $ t {liqProvider = Just updatedLiqProvider}
where
updatedLiqProvider = mapWithinMap ((updateLiqProvider t d) . (CE.accrueLiqProvider d)) liqNames _liqProvider
performAction d t@TestDeal{rateSwap = Just rtSwap } (W.SwapAccrue sName)
=
do
refBal <- case HE.rsNotional (rtSwap Map.! sName) of
(HE.Fixed b) -> Right b
(HE.Base ds) -> fromRational <$> queryCompound t d (patchDateToStats d ds)
(HE.Schedule ts) -> Right . fromRational $ getValByDate ts Inc d
let newRtSwap = Map.adjust
(HE.accrueIRS d)
sName
(Map.adjust (set HE.rsRefBalLens refBal) sName rtSwap)
return $ t { rateSwap = Just newRtSwap }
performAction d t@TestDeal{rateCap = Just rcM, accounts = accsMap } (W.CollectRateCap accName sName)
= Right $ t { rateCap = Just newRcSwap, accounts = newAccMap }
where
receiveAmt = max 0 $ HE.rcNetCash $ rcM Map.! sName
newRcSwap = Map.adjust (HE.receiveRC d) sName rcM -- `debug` ("REceiv AMT"++ show receiveAmt)
newAccMap = Map.adjust (A.deposit receiveAmt d (SwapInSettle sName)) accName accsMap
performAction d t@TestDeal{rateSwap = Just rtSwap, accounts = accsMap } (W.SwapReceive accName sName)
= case (Map.member accName accsMap, Map.member sName rtSwap) of
(False, _) -> Left $ "Date:"++show d ++"Account:"++ show accName ++"not found in SwapReceive"
(_, False) -> Left $ "Date:"++show d ++"Swap:"++ show sName ++"not found in SwapReceive"
_ -> let
receiveAmt = max 0 $ HE.rsNetCash $ rtSwap Map.! sName
newRtSwap = Map.adjust (HE.receiveIRS d) sName rtSwap
newAccMap = Map.adjust (A.deposit receiveAmt d (SwapInSettle sName)) accName accsMap
in
Right $ t { rateSwap = Just newRtSwap, accounts = newAccMap }
performAction d t@TestDeal{rateSwap = Just rtSwap, accounts = accsMap } (W.SwapPay accName sName)
= case (Map.member accName accsMap, Map.member sName rtSwap) of
(False, _) -> Left $ "Date:"++show d ++"Account:"++ show accName ++"not found in SwapPay"
(_, False) -> Left $ "Date:"++show d ++"Swap:"++ show sName ++"not found in SwapPay"
_ -> if (HE.rsNetCash (rtSwap Map.! sName)) < 0 then
let
payoutAmt = negate $ HE.rsNetCash $ rtSwap Map.! sName
availBal = A.accBalance $ accsMap Map.! accName
amtToPay = min payoutAmt availBal
newRtSwap = Map.adjust (HE.payoutIRS d amtToPay) sName rtSwap
newAccMap = Map.adjust (A.draw amtToPay d (SwapOutSettle sName)) accName accsMap
in
Right $ t { rateSwap = Just newRtSwap, accounts = newAccMap }
else
Right t
performAction d t@TestDeal{rateSwap = Just rtSwap, accounts = accsMap } (W.SwapSettle accName sName)
= do
t2 <- performAction d t (W.SwapReceive accName sName)
performAction d t2 (W.SwapPay accName sName)
performAction d t@TestDeal{ triggers = Just trgM } (W.RunTrigger loc tNames)
= do
tList <- newTrgList
return $
let
newTrgMap = Map.fromList $ zip tNames tList
in
t { triggers = Just (Map.insert loc newTrgMap trgM) }
where
triggerM = trgM Map.! loc
triggerList = (triggerM Map.!) <$> tNames
newTrgList = mapM
(testTrigger t d)
triggerList
performAction d t (W.Placeholder mComment) = Right t
performAction d t action = Left $ "failed to match action>>"++show action++">>Deal"++show (name t)