{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleInstances #-} module Deal.DealBase (TestDeal(..),SPV(..),dealBonds,dealFees,dealAccounts,dealPool,PoolType(..),getIssuanceStats ,getAllAsset,getAllAssetList,getAllCollectedFrame,getLatestCollectFrame,getAllCollectedTxns ,getIssuanceStatsConsol,getAllCollectedTxnsList ,getPoolIds,getBondByName, UnderlyingDeal(..), uDealFutureTxn,viewDealAllBonds,DateDesp(..),ActionOnDate(..) ,sortActionOnDate,dealBondGroups ,viewDealBondsByNames,poolTypePool,viewBondsInMap,bondGroupsBonds ,increaseBondPaidPeriod,increasePoolCollectedPeriod ,DealStatFields(..),getDealStatInt,isPreClosing,populateDealDates ,bondTraversal,findBondByNames,updateBondInMap ,_MultiPool,_ResecDeal,uDealFutureCf,uDealFutureScheduleCf ) where import qualified Accounts as A import qualified Ledger as LD import qualified Asset as Ast 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 qualified Call as C import qualified InterestRate as IR 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 Data.DList as DL import Data.List import Data.Fixed import Data.Maybe import Data.Ratio 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.Lens hiding (element) import Control.Lens.TH import Data.IntMap (filterWithKey) import qualified Data.Text as T import Text.Read (readMaybe) import qualified Pool as P import qualified Types as CF import Debug.Trace import qualified Control.Lens as P debug = flip trace data DealComp = CompBond | CompAccount | CompFee | CompPool | CompTrigger | CompLedger | CompRateSwap | CompRateCap | CompCurrencySwap | CompLiqProvider deriving (Show,Eq,Ord,Generic,Read) data ActionTypeOnDate = DoSettle | DoAccrue | DoUpdateRate data ActionOnDate = EarnAccInt Date AccName -- ^ sweep bank account interest | ChangeDealStatusTo Date DealStatus -- ^ change deal status | AccrueFee Date FeeName -- ^ accure fee | ResetLiqProvider Date String -- ^ reset credit for liquidity provider | ResetLiqProviderRate Date String -- ^ accure interest/premium amount for liquidity provider | PoolCollection Date String -- ^ collect pool cashflow and deposit to accounts | RunWaterfall Date String -- ^ execute waterfall on distribution date | DealClosed Date -- ^ actions to perform at the deal closing day, and enter a new deal status | FireTrigger Date DealCycle String -- ^ fire a trigger | InspectDS Date [DealStats] -- ^ inspect formulas | CalcIRSwap Date String -- ^ calc interest rate swap dates | SettleIRSwap Date String -- ^ settle interest rate swap dates | AccrueCapRate Date String -- ^ reset interest rate cap dates | ResetBondRate Date String -- ^ reset bond interest rate per bond's interest rate info | StepUpBondRate Date String -- ^ reset bond interest rate per bond's interest rate info | ResetSrtRate Date String | ResetAccRate Date String | AccrueSrt Date String | MakeWhole Date Spread (Table Float Spread) | IssueBond Date (Maybe Pre) String AccName L.Bond (Maybe DealStats) (Maybe DealStats) | FundBond Date (Maybe Pre) String AccName Amount | RefiBondRate Date AccountName BondName L.InterestInfo | RefiBond Date AccountName L.Bond | BuildReport StartDate EndDate -- ^ build cashflow report between dates and balance report at end date | StopRunFlag Date -- ^ stop the run with a message | StopRunTest Date [Pre] -- ^ stop the run with a condition | HitStatedMaturity Date -- ^ hit the stated maturity date | TestCall Date -- ^ test call dates deriving (Show,Generic,Read) instance Ord ActionOnDate where compare a1 a2 = compare (getDate a1) (getDate a2) instance Eq ActionOnDate where a1 == a2 = getDate a1 == getDate a2 instance TimeSeries ActionOnDate where getDate (RunWaterfall d _) = d getDate (ResetLiqProvider d _) = d getDate (PoolCollection d _) = d getDate (EarnAccInt d _) = d getDate (AccrueFee d _) = d getDate (DealClosed d) = d getDate (FireTrigger d _ _) = d getDate (ChangeDealStatusTo d _ ) = d getDate (InspectDS d _ ) = d getDate (CalcIRSwap d _ ) = d getDate (SettleIRSwap d _ ) = d getDate (AccrueCapRate d _ ) = d getDate (ResetBondRate d _) = d getDate (StepUpBondRate d _) = d getDate (ResetAccRate d _ ) = d getDate (MakeWhole d _ _) = d getDate (BuildReport sd ed) = ed getDate (IssueBond d _ _ _ _ _ _) = d getDate (RefiBondRate d _ _ _) = d getDate (RefiBond d _ _) = d getDate (ResetLiqProviderRate d _) = d getDate (TestCall d) = d getDate (FundBond d _ _ _ _) = d getDate (HitStatedMaturity d) = d getDate (StopRunTest d _) = d getDate x = error $ "Failed to match"++ show x sortActionOnDate :: ActionOnDate -> ActionOnDate -> Ordering sortActionOnDate a1 a2 | d1 == d2 = case (a1,a2) of (PoolCollection {}, DealClosed {}) -> LT -- pool collection should be executed before deal closed (DealClosed {}, PoolCollection {}) -> GT -- pool collection should be executed before deal closed (BuildReport sd1 ed1 ,_) -> GT -- build report should be executed last (_ , BuildReport sd1 ed1) -> LT -- build report should be executed last (TestCall _ ,_) -> GT -- test call should be executed last (_ , TestCall _) -> LT -- test call should be executed last (CalcIRSwap _ _ ,SettleIRSwap _ _) -> LT -- reset interest swap should be first (SettleIRSwap _ _ ,CalcIRSwap _ _) -> GT -- reset interest swap should be first (_ , CalcIRSwap _ _) -> GT -- reset interest swap should be first (CalcIRSwap _ _ ,_) -> LT -- reset interest swap should be first (_ , CalcIRSwap _ _) -> GT -- reset interest swap should be first (StepUpBondRate {} ,_) -> LT -- step up bond rate should be first (_ , StepUpBondRate {}) -> GT -- step up bond rate should be first (ResetBondRate {} ,_) -> LT -- reset bond rate should be first (_ , ResetBondRate {}) -> GT -- reset bond rate should be first (EarnAccInt {} ,_) -> LT -- earn should be first (_ , EarnAccInt {}) -> GT -- earn should be first (ResetLiqProvider {} ,_) -> LT -- reset liq be first (_ , ResetLiqProvider {}) -> GT -- reset liq be first (PoolCollection {}, RunWaterfall {}) -> LT -- pool collection should be executed before waterfall (RunWaterfall {}, PoolCollection {}) -> GT -- pool collection should be executed before waterfall (_,_) -> EQ | otherwise = compare d1 d2 where d1 = getDate a1 d2 = getDate a2 type CutoffDate = Date type ClosingDate = Date type RevolvingDate = Date type StatedDate = Date type DistributionDates = DatePattern type PoolCollectionDates = DatePattern data DateDesp = PreClosingDates CutoffDate ClosingDate (Maybe RevolvingDate) StatedDate (Date,PoolCollectionDates) (Date,DistributionDates) -- -- (last collect,last pay), mRevolving end-date dp1-pool-pay dp2-bond-pay | CurrentDates (Date,Date) (Maybe Date) StatedDate (Date,PoolCollectionDates) (Date,DistributionDates) -- Dict based | GenericDates (Map.Map DateType DatePattern) deriving (Show,Eq, Generic,Ord) populateDealDates :: DateDesp -> DealStatus -> Either String (Date,Date,Date,[ActionOnDate],[ActionOnDate],Date,[ActionOnDate]) populateDealDates (PreClosingDates cutoff closing mRevolving end (firstCollect,poolDp) (firstPay,bondDp)) _ = Right (cutoff,closing,firstPay,pa,ba,end, []) where pa = [ PoolCollection _d "" | _d <- genSerialDatesTill2 IE firstCollect poolDp end ] ba = [ RunWaterfall _d "" | _d <- genSerialDatesTill2 IE firstPay bondDp end ] populateDealDates (CurrentDates (lastCollect,lastPay) mRevolving end (nextCollect,poolDp) (nextPay,bondDp)) _ = Right (lastCollect, lastPay,head futurePayDates, pa, ba, end, []) where futurePayDates = genSerialDatesTill2 IE nextPay bondDp end ba = [ RunWaterfall _d "" | _d <- futurePayDates] futureCollectDates = genSerialDatesTill2 IE nextCollect poolDp end pa = [ PoolCollection _d "" | _d <- futureCollectDates] populateDealDates (GenericDates m) (PreClosing _) = let requiredFields = (CutoffDate, ClosingDate, FirstPayDate, StatedMaturityDate , DistributionDates, CollectionDates) vals = lookupTuple6 requiredFields m isCustomWaterfallKey (CustomExeDates _) _ = True isCustomWaterfallKey _ _ = False custWaterfall = Map.toList $ Map.filterWithKey isCustomWaterfallKey m in case vals of (Just (SingletonDate coffDate), Just (SingletonDate closingDate), Just (SingletonDate fPayDate) , Just (SingletonDate statedDate), Just bondDp, Just poolDp) -> let pa = [ PoolCollection _d "" | _d <- genSerialDatesTill2 IE closingDate poolDp statedDate ] ba = [ RunWaterfall _d "" | _d <- genSerialDatesTill2 IE fPayDate bondDp statedDate ] cu = [ RunWaterfall _d custName | (CustomExeDates custName, custDp) <- custWaterfall , _d <- genSerialDatesTill2 EE closingDate custDp statedDate ] in Right (coffDate, closingDate, fPayDate, pa, ba, statedDate, cu) _ -> Left "Missing required dates in GenericDates in deal status PreClosing" populateDealDates (GenericDates m) _ = let requiredFields = (LastCollectDate, LastPayDate, NextPayDate, StatedMaturityDate , DistributionDates, CollectionDates) vals = lookupTuple6 requiredFields m isCustomWaterfallKey (CustomExeDates _) _ = True isCustomWaterfallKey _ _ = False custWaterfall = Map.toList $ Map.filterWithKey isCustomWaterfallKey m in case vals of (Just (SingletonDate lastCollect), Just (SingletonDate lastPayDate), Just (SingletonDate nextPayDate) , Just (SingletonDate statedDate), Just bondDp, Just poolDp) -> let pa = [ PoolCollection _d "" | _d <- genSerialDatesTill2 EE lastCollect poolDp statedDate ] ba = [ RunWaterfall _d "" | _d <- genSerialDatesTill2 IE nextPayDate bondDp statedDate ] cu = [ RunWaterfall _d custName | (CustomExeDates custName, custDp) <- custWaterfall , _d <- genSerialDatesTill2 EE lastCollect custDp statedDate ] in Right (lastCollect, lastPayDate, nextPayDate, pa, ba, statedDate, cu) -- `debug` ("custom action"++ show cu) _ -> Left "Missing required dates in GenericDates in deal status PreClosing" class SPV a where getBondsByName :: a -> Maybe [String] -> Map.Map String L.Bond getActiveBonds :: a -> [String] -> [L.Bond] getBondBegBal :: a -> String -> Balance getBondStmtByName :: a -> Maybe [String] -> Map.Map String (Maybe Statement) getFeeByName :: a -> Maybe [String] -> Map.Map String F.Fee getAccountByName :: a -> Maybe [String] -> Map.Map String A.Account isResec :: a -> Bool getNextBondPayDate :: a -> Date getOustandingBal :: a -> Balance type BalDealStatMap = Map.Map DealStatFields Balance type RDealStatMap = Map.Map DealStatFields Rate type BDealStatMap = Map.Map DealStatFields Bool type IDealStatMap = Map.Map DealStatFields Int data TestDeal a = TestDeal { name :: DealName ,status :: DealStatus ,dates :: DateDesp ,accounts :: Map.Map AccountName A.Account ,fees :: Map.Map FeeName F.Fee ,bonds :: Map.Map BondName L.Bond ,pool :: PoolType a ,waterfall :: Map.Map W.ActionWhen W.DistributionSeq ,collects :: [W.CollectionRule] ,stats :: (BalDealStatMap,RDealStatMap,BDealStatMap,IDealStatMap) ,liqProvider :: Maybe (Map.Map String CE.LiqFacility) ,rateSwap :: Maybe (Map.Map String HE.RateSwap) ,rateCap :: Maybe (Map.Map String HE.RateCap) ,currencySwap :: Maybe (Map.Map String HE.CurrencySwap) ,custom:: Maybe (Map.Map String CustomDataType) ,triggers :: Maybe (Map.Map DealCycle (Map.Map String Trigger)) ,ledgers :: Maybe (Map.Map String LD.Ledger) } deriving (Show,Generic,Eq,Ord) data UnderlyingDeal a = UnderlyingDeal { deal :: TestDeal a ,futureCf :: CF.CashFlowFrame ,futureScheduleCf :: CF.CashFlowFrame ,issuanceStat :: Maybe (Map.Map CutoffFields Balance) } deriving (Generic,Eq,Ord,Show) uDealFutureScheduleCf :: Ast.Asset a => Lens' (UnderlyingDeal a) CF.CashFlowFrame uDealFutureScheduleCf = lens getter setter where getter = futureScheduleCf setter ud newCf = ud {futureScheduleCf = newCf} uDealFutureCf :: Ast.Asset a => Lens' (UnderlyingDeal a) CF.CashFlowFrame uDealFutureCf = lens getter setter where getter = futureCf setter ud newCf = ud {futureCf = newCf} uDealFutureTxn :: Ast.Asset a => Lens' (UnderlyingDeal a) [CF.TsRow] uDealFutureTxn = lens getter setter where getter ud = view CF.cashflowTxn $ futureCf ud setter ud newTxn = ud {futureCf = CF.CashFlowFrame (0,toDate "19000101",Nothing) newTxn} -- let -- mOriginalCfFrame = futureCf ud -- in -- case mOriginalCfFrame of -- -- (CF.CashFlowFrame (begBal,begDate,mInt) txns) -> ud {futureCf = CF.CashFlowFrame (0,toDate "19000101",Nothing) newTxn } data PoolType a = MultiPool (Map.Map PoolId (P.Pool a)) | ResecDeal (Map.Map PoolId (UnderlyingDeal a)) deriving (Generic, Eq, Ord, Show) makePrisms ''PoolType instance SPV (TestDeal a) where getBondsByName t bns = case bns of Nothing -> bonds t Just _bns -> Map.filterWithKey (\k _ -> S.member k (S.fromList _bns)) (bonds t) getActiveBonds t bns = let bnds = (bonds t Map.!) <$> bns in filter (not . L.isPaidOff) bnds getBondStmtByName t bns = Map.map L.bndStmt bndsM where bndsM = Map.map L.consolStmt $ getBondsByName t bns getNextBondPayDate t = case populateDealDates (dates t) (status t) of Right _dates -> view _3 _dates Left _ -> error "Failed to populate dates" getBondBegBal t bn = case b of Nothing -> 0 Just bnd -> case L.bndStmt bnd of Nothing -> L.getCurBalance bnd -- `debug` ("Getting beg bal nothing"++bn) Just (Statement txns) | DL.empty == txns -> L.getCurBalance bnd | otherwise -> getTxnBegBalance $ head (DL.toList txns) -- `debug` ("Getting beg bal"++bn++"Last smt"++show (head stmts)) where b = find (\x -> ((L.bndName x) == bn)) (viewDealAllBonds t) getFeeByName t fns = case fns of Nothing -> fees t Just _fns -> Map.filterWithKey (\k _ -> S.member k (S.fromList _fns)) (fees t) getAccountByName t ans = case ans of Nothing -> accounts t Just _ans -> Map.filterWithKey (\k _ -> S.member k (S.fromList _ans)) (accounts t) isResec t = case pool t of ResecDeal _ -> True _ -> False getOustandingBal t@TestDeal{ bonds = bndMap, fees= feeMap, liqProvider = mliqMap, rateSwap = rsMap} = let bndBal = sum $ getOutstandingAmount <$> Map.elems bndMap feeBal = sum $ getOutstandingAmount <$> Map.elems feeMap lqBalace m | not (Map.null m) = sum $ getOutstandingAmount <$> Map.elems m | otherwise = 0 rsBalance m | not (Map.null m) = sum $ getOutstandingAmount <$> Map.elems m | otherwise = 0 in bndBal + feeBal + lqBalace (fromMaybe Map.empty mliqMap) + rsBalance (fromMaybe Map.empty rsMap) isPreClosing :: TestDeal a -> Bool isPreClosing t@TestDeal{ status = PreClosing _ } = True isPreClosing _ = False -- ^ list all bonds and bond groups in list viewDealAllBonds :: TestDeal a -> [L.Bond] viewDealAllBonds d = let bs = Map.elems (bonds d) view a@(L.Bond {} ) = [a] view a@(L.BondGroup bMap _) = Map.elems bMap view a@(L.MultiIntBond {}) = [a] in concat $ view <$> bs -- ^ flatten all bonds/bond groups in a map viewBondsInMap :: TestDeal a -> Map.Map String L.Bond viewBondsInMap t@TestDeal{ bonds = bndMap } = let bnds = viewDealAllBonds t bndNames = L.bndName <$> bnds in Map.fromList $ zip bndNames bnds -- ^ support bond group viewDealBondsByNames :: Ast.Asset a => TestDeal a -> [BondName] -> [L.Bond] viewDealBondsByNames _ [] = [] viewDealBondsByNames t@TestDeal{bonds= bndMap } bndNames = let -- bonds and bond groups bnds = filter (\b -> L.bndName b `elem` bndNames) $ viewDealAllBonds t -- bndsFromGrp = $ Map.filter (\L.BondGroup {} -> True) bndMap bndsFromGrp = Map.foldrWithKey (\k (L.BondGroup bMap _) acc -> if k `elem` bndNames then acc ++ Map.elems bMap else acc) [] (view dealBondGroups t ) in bnds ++ bndsFromGrp -- ^ find bonds with first match findBondByNames :: Map.Map String L.Bond -> [BondName] -> Either String [L.Bond] findBondByNames bMap bNames = let (firstMatch, notMatched) = Map.partitionWithKey (\k _ -> k `elem` bNames) bMap remainNames::[String] = bNames \\ Map.keys firstMatch listOfBondGrps::[Map.Map String L.Bond] = [ bM | (bM,_) <-catMaybes $ (preview L._BondGroup) <$> Map.elems notMatched ] (secondMatch, notMatched2) = Map.partitionWithKey (\k _ -> k `elem` remainNames) $ Map.unions listOfBondGrps in if Map.null notMatched2 then Right $ Map.elems firstMatch ++ Map.elems secondMatch else Left $ "Failed to find bonds by names:"++ show (Map.keys notMatched2) -- ^ not support bond group dealBonds :: Ast.Asset a => Lens' (TestDeal a) (Map.Map BondName L.Bond) dealBonds = lens getter setter where getter d = bonds d setter d newBndMap = d {bonds = newBndMap} -- ^ get & set bond group only dealBondGroups :: Ast.Asset a => Lens' (TestDeal a) (Map.Map BondName L.Bond) dealBondGroups = lens getter setter where getter d = Map.filter (has L._BondGroup) (bonds d) setter d newBndMap = d {bonds = Map.filter (has L._BondGroup) newBndMap} bondGroupsBonds :: Lens' L.Bond (Map.Map BondName L.Bond) bondGroupsBonds = lens getter setter where getter (L.BondGroup bMap _) = bMap getter _ = Map.empty setter (L.BondGroup b x) newBMap = L.BondGroup newBMap x setter x _ = x updateBondInMap :: BondName -> (L.Bond -> L.Bond) -> Map.Map BondName L.Bond -> Map.Map BondName L.Bond updateBondInMap bName f bMap = let fn _bName (L.BondGroup subMap bt) = L.BondGroup (Map.adjust f _bName subMap) bt fn _bName bnd | _bName == bName = f bnd | otherwise = bnd in Map.mapWithKey fn bMap dealAccounts :: Ast.Asset a => Lens' (TestDeal a) (Map.Map AccountName A.Account) dealAccounts = lens getter setter where getter d = accounts d setter d newAccMap = d {accounts = newAccMap} dealFees :: Ast.Asset a => Lens' (TestDeal a) (Map.Map FeeName F.Fee) dealFees = lens getter setter where getter d = fees d setter d newFeeMap = d {fees = newFeeMap} dealPool :: Ast.Asset a => Lens' (TestDeal a) (PoolType a) dealPool = lens getter setter where getter d = pool d setter d newPool = d {pool = newPool} poolTypePool :: Ast.Asset a => Lens' (PoolType a) (Map.Map PoolId (P.Pool a)) poolTypePool = lens getter setter where getter = \case MultiPool pm -> pm setter (MultiPool pm) newPm = MultiPool newPm poolTypeUnderDeal :: Ast.Asset a => Lens' (PoolType a) (Map.Map PoolId (UnderlyingDeal a)) poolTypeUnderDeal = lens getter setter where getter = \case ResecDeal dm -> dm setter (ResecDeal dm) newDm = ResecDeal newDm -- schedulePoolFlowLens = poolTypePool . mapped . P.futureScheduleCfLens -- schedulePoolFlowAggLens = schedulePoolFlowLens . _1 . _1 -- scheduleBondFlowLens = poolTypeUnderDeal . mapped . uDealFutureScheduleCf -- dealInputCashflow :: Ast.Asset a => Lens' (TestDeal a) (Map.Map PoolId CF.PoolCashflow) -- dealInputCashflow = lens getter setter -- where -- getter d = case pool d of -- MultiPool pm -> Map.map (P.futureScheduleCf) pm -- ResecDeal uds -> Map.map futureScheduleCf uds -- setter d newCfMap = case pool d of -- MultiPool pm -> -- let -- newPm = Map.mapWithKey (\k p -> set (P.poolFutureScheduleCf) (newCfMap Map.! k) p) pm -- in -- set dealPool (MultiPool newPm) d -- ResecDeal pm -> -- let -- newPm = Map.mapWithKey (\k ud ->gset uDealFutureScheduleCf (newCfMap Map.! k) ud) pm -- in -- set dealPool (ResecDeal newPm) d -- dealCashflow :: Ast.Asset a => Lens' (TestDeal a) (Map.Map PoolId (Maybe CF.CashFlowFrame)) -- dealCashflow = lens getter setter -- where -- getter d = case pool d of -- MultiPool pm -> Map.map P.futureCf pm -- ResecDeal uds -> Map.map futureCf uds -- setter d newCfMap = case pool d of -- MultiPool pm -> let -- newPm = Map.mapWithKey (\k p -> set P.poolFutureCf (newCfMap Map.! k) p) pm -- in -- set dealPool (MultiPool newPm) d -- ResecDeal pm -> -- let -- newPm = Map.mapWithKey -- (\k ud -> set uDealFutureCf (newCfMap Map.! k) ud) -- pm -- in -- set dealPool (ResecDeal newPm) d getPoolIds :: Ast.Asset a => TestDeal a -> [PoolId] getPoolIds t@TestDeal{pool = pt} = case pt of MultiPool pm -> Map.keys pm ResecDeal pm -> Map.keys pm _ -> error "failed to match pool type in pool ids" -- ^ to handle with bond group, with flag to good deep if it is a bond group getBondByName :: Ast.Asset a => TestDeal a -> Bool -> BondName -> Maybe L.Bond getBondByName t False bName = Map.lookup bName (bonds t) getBondByName t True bName = let bnds = viewDealAllBonds t in find (\b -> L.bndName b == bName) bnds -- ^ get issuance pool stat from pool map getIssuanceStats :: Ast.Asset a => TestDeal a -> Maybe [PoolId] -> Map.Map PoolId (Map.Map CutoffFields Balance) getIssuanceStats t@TestDeal{pool = pt} mPoolId = case pt of ResecDeal uDeals -> let selecteduDeals = case mPoolId of Nothing -> uDeals Just pns -> Map.filterWithKey (\k _ -> k `elem` pns ) uDeals in Map.map (fromMaybe Map.empty . issuanceStat) selecteduDeals MultiPool pm -> let selectedPools = case mPoolId of Nothing -> pm Just pns -> Map.filterWithKey (\k _ -> k `elem` pns ) pm in Map.map (fromMaybe Map.empty . P.issuanceStat) selectedPools getIssuanceStatsConsol :: Ast.Asset a => TestDeal a -> Maybe [PoolId] -> Map.Map CutoffFields Balance getIssuanceStatsConsol t mPns = let ms = getIssuanceStats t mPns in Map.unionsWith (+) $ Map.elems ms getAllAsset :: TestDeal a -> Maybe [PoolId] -> Map.Map PoolId [a] getAllAsset t@TestDeal{pool = pt} mPns = let assetMap = case pt of MultiPool pm -> Map.map P.assets pm ResecDeal _ -> Map.empty -- ResecDeal pm -> Map.mapWithKey (\(UnderlyingBond (bn,hpct,sd), d) -> getAllAsset d Nothing) pm in case mPns of Nothing -> assetMap Just pns -> Map.filterWithKey (\k _ -> k `elem` pns ) assetMap getAllAssetList :: Ast.Asset a => TestDeal a -> [a] getAllAssetList t = concat $ Map.elems (getAllAsset t Nothing) getAllCollectedFrame :: Ast.Asset a => TestDeal a -> Maybe [PoolId] -> Map.Map PoolId CF.CashFlowFrame getAllCollectedFrame t@TestDeal{pool = poolType} mPid = let mCf = case poolType of MultiPool pm -> Map.map (view (P.poolFutureCf . _Just . _1 )) pm -- `debug` ("MultiPool" ++ show pm) ResecDeal uds -> Map.map futureCf uds in case mPid of Nothing -> mCf -- `debug` ("Nothing when collecting cfs"++show mCf) Just pids -> Map.filterWithKey (\k _ -> k `elem` pids) mCf -- `debug` ("Just when collecting cfs"++show mCf) getLatestCollectFrame :: Ast.Asset a => TestDeal a -> Maybe [PoolId] -> Map.Map PoolId (Maybe CF.TsRow) getLatestCollectFrame t mPns = Map.map (\case (CF.CashFlowFrame (_,_,_) []) -> Nothing (CF.CashFlowFrame (_,_,_) txns) -> Just $ last txns ) (getAllCollectedFrame t mPns) getAllCollectedTxns :: Ast.Asset a => TestDeal a -> Maybe [PoolId] -> Map.Map PoolId [CF.TsRow] getAllCollectedTxns t mPns = Map.map (view CF.cashflowTxn) (getAllCollectedFrame t mPns) getAllCollectedTxnsList :: Ast.Asset a => TestDeal a -> Maybe [PoolId] -> [CF.TsRow] getAllCollectedTxnsList t mPns = concat listOfTxns where listOfTxns = Map.elems $ getAllCollectedTxns t mPns increasePoolCollectedPeriod :: TestDeal a -> TestDeal a increasePoolCollectedPeriod t@TestDeal{stats = (balMap,rateMap,boolMap,intMap)} = let intMap' = Map.insertWith (+) PoolCollectedPeriod 1 intMap in t {stats = (balMap,rateMap,boolMap,intMap')} increaseBondPaidPeriod :: TestDeal a -> TestDeal a increaseBondPaidPeriod t@TestDeal{stats = (balMap,rateMap,boolMap,intMap)} = let intMap' = Map.insertWith (+) BondPaidPeriod 1 intMap in t {stats = (balMap,rateMap,boolMap,intMap')} getDealStatInt :: TestDeal a -> DealStatFields -> Maybe Int getDealStatInt t@TestDeal{stats = (balMap,rateMap,boolMap,intMap)} f = Map.lookup f intMap bondTraversal :: Traversal' (TestDeal a) L.Bond bondTraversal f t@TestDeal{bonds = bndMap} = (\newBndMap -> t {bonds = newBndMap}) <$> traverse f bndMap data UnderBond b = UnderBond BondName Rate (TestDeal b) opts :: JSONKeyOptions opts = defaultJSONKeyOptions instance ToJSONKey DealStatFields where toJSONKey = genericToJSONKey opts instance FromJSONKey DealStatFields where fromJSONKey = genericFromJSONKey opts $(concat <$> traverse (deriveJSON defaultOptions) [''TestDeal, ''UnderlyingDeal, ''PoolType, ''DateDesp, ''ActionOnDate])