From a1c453d1bf47c33193961a86e4d5c9bf9eb8563c Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Wed, 26 Mar 2025 01:56:53 +0800 Subject: [PATCH 01/53] bump version to-> < 0.45.1 > --- CHANGELOG.md | 4 ++-- app/Main.hs | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e50b14a9..493b4319 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,7 @@ -## 0.45.1 +## 0.44.1 ### 2025-03-25 * BREAK: * FIX: in `Pricing/IRR`, error when holding position is too small @@ -10,7 +10,7 @@ * ENHANCE: engine will auto patch `interest start date` for bonds if it is not modeled. In `PreClosing` status, engine will use `closing date` as bond interest begin date ; In `Non-PreClosing` status, it defaults to use last waterfall distribution date as bond interest begin date. -## 0.45.0 +## 0.44.0 ### 2025-03-21 * BREAK: remove unused `DealDates` : `FixInterval`, `CustomDates` and `PatternInterval`. Since all these can be replace by new `GenericDates` in type `DateDesp` * ENHANCE: now bond with `No last interest accure day` will begin accrue interest from `closing date` if the deal is in `PreClosing` mode, while the bond will use `last bond day` otherwise. diff --git a/app/Main.hs b/app/Main.hs index 46a65555..3e93d264 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -101,7 +101,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.44.2" +version1 = Version "0.45.1" wrapRun :: DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From ab60b99885f83d882f72527a56f4980ff5efa6a5 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Wed, 26 Mar 2025 16:56:44 +0800 Subject: [PATCH 02/53] include Pre: HasPass/IsOutstanding --- src/Types.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index ca3f68ae..3ff30fcb 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1078,8 +1078,8 @@ getDealStatType (FutureCurrentPoolFactor _ _) = RtnRate getDealStatType (BondWaRate _) = RtnRate getDealStatType (PoolWaRate _) = RtnRate getDealStatType (BondRate _) = RtnRate -getDealStatType (DivideRatio {}) = RtnRate -getDealStatType (AvgRatio {}) = RtnRate +getDealStatType DivideRatio {} = RtnRate +getDealStatType AvgRatio {} = RtnRate getDealStatType (DealStatRate _) = RtnRate getDealStatType (Avg dss) = RtnRate getDealStatType (Divide ds1 ds2) = RtnRate @@ -1092,7 +1092,9 @@ getDealStatType ProjCollectPeriodNum = RtnInt getDealStatType (DealStatInt _) = RtnInt getDealStatType (IsMostSenior _ _) = RtnBool -getDealStatType (IsPaidOff {}) = RtnBool +getDealStatType IsPaidOff {} = RtnBool +getDealStatType IsOutstanding {} = RtnBool +getDealStatType HasPassedMaturity {} = RtnBool getDealStatType (TriggersStatus _ _)= RtnBool getDealStatType (IsDealStatus _)= RtnBool getDealStatType TestRate {} = RtnBool From c6515d31cf8bbed6393985090bfecff59a755eaa Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Thu, 27 Mar 2025 23:17:56 +0800 Subject: [PATCH 03/53] move away from stack --- .github/workflows/haskell.yml | 7 +-- Hastructure.cabal | 2 +- package.yaml | 115 ---------------------------------- stack.yaml | 87 ------------------------- 4 files changed, 4 insertions(+), 207 deletions(-) delete mode 100644 package.yaml delete mode 100644 stack.yaml diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 6b47584e..e1a6c5c3 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -35,12 +35,11 @@ jobs: - name: Install dependencies run: | - stack update - stack build + cabal update - name: Build - run: stack build + run: cabal build - name: Run tests - run: stack test + run: cabal test - name: Badge Action uses: emibcn/badge-action@v1.2.4 diff --git a/Hastructure.cabal b/Hastructure.cabal index e23c44b4..ebac08e7 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -67,7 +67,6 @@ library Util Validation Waterfall - WebUI other-modules: Paths_Hastructure hs-source-dirs: @@ -112,6 +111,7 @@ library executable Hastructure-exe main-is: Main.hs other-modules: + GenInterface MainBase Paths_Hastructure hs-source-dirs: diff --git a/package.yaml b/package.yaml deleted file mode 100644 index 7c7634f2..00000000 --- a/package.yaml +++ /dev/null @@ -1,115 +0,0 @@ -name: Hastructure -version: 0.45.0 -github: "yellowbean/Hastructure" -license: BSD3 -author: "Xiaoyu" -maintainer: "always.zhang@gmail.com" -copyright: "2025 Xiaoyu, Zhang" - -extra-source-files: -- README.md -- CHANGELOG.md - -# Metadata used when publishing your package -# synopsis: Short description of your package -category: StructuredFinance;Securitisation;Cashflow - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at - -dependencies: -- base -- Decimal -- hashable -- time -- lens -- generic-lens -- aeson -- aeson-pretty -- text -- bytestring -- template-haskell -- containers -- regex-tdfa -- regex-base -- regex-pcre-builtin -- vector -- wai -- monad-loops -- ieee754 -- servant -- servant-server -- servant-openapi3 -- openapi3 -- swagger2 -- split -- yaml -- lucid -- tabular -- numeric-limits -- scientific -- math-functions -- parallel -- deepseq -- mtl - -library: - source-dirs: - - src - -executables: - Hastructure-exe: - main: Main.hs - source-dirs: app - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - Hastructure - - time - - aeson - - attoparsec-aeson - - text - - containers - - unordered-containers - - containers - - warp - - wai-cors - - base-compat - - http-types - - template-haskell - - yaml - - scientific - - openapi3 - - servant-server - - mtl - - servant - - lucid - - monad-loops - - string-conversions - - attoparsec - - exceptions - - tabular - - math-functions - - servant-checked-exceptions - -tests: - Hastructure-test: - main: MainTest.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - Hastructure - - tasty - - tasty-hunit - - tasty-hspec - - tasty-golden - - -allow-newer: true diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index 465d4c30..00000000 --- a/stack.yaml +++ /dev/null @@ -1,87 +0,0 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -resolver: lts-23.15 -# urls: -# latest-snapshot: http://www.stackage.org/download/snapshots.json -# lts-build-plans: http://www.stackage.org/download/lts-build-plans.json -# nightly-build-plans: http://www.stackage.org/download/nightly-build-plans.json - -# resolver: nightly-2021-12-26 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -#resolver: -# url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/22.yaml - #url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/19/25.yaml -# url: https://www.stackage.org/lts-19.25 -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai -packages: -- . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -extra-deps: -# - time-1.12.2@sha256:88e8493d9130038d3b9968a2530a0900141cd3d938483c83dde56e12b875ebc8,6510 -# - json-schema-0.7.4.2 -# - timeseries-0.4.1@sha256:2c4b6995942e6aa3b474aa29bfc51016448cc3d7b58e46a459c26c60a96883cb,2892 -# - dates-0.2.3.0 -# - currency-codes-3.0.0.1 -## - json-schema-0.7.4.2 -# - aeson-2.1.0.0 -# - base-compat-batteries-0.10.5@sha256:773526cb63fd837a10884c48f62185284596e70c644465c55a1d828918165697,8577 -# - containers-0.5.11.0@sha256:1af9da3baaddc4f4aaea016b07d4c38ddbf702ce3f0df31120531950837996b8,17308 -# - generic-deriving-1.12.4@sha256:f2f9609b5caacb5ff049859e4cd9c459658eaafcbebc6d564442127e1139e09b,4146 -# - time-1.8.0.4@sha256:3f6eddf238b828eb4f82683acce1c3afe64784f0d20114239b738c123316c85c,5494 -# Override default flag values for local packages and extra-deps -# flags: {} - - # Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.7" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor - -# allow-newer : true -pvp-bounds: both \ No newline at end of file From c4d5d711ed2a10cc36d556a82c4c90694cc213af Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Thu, 27 Mar 2025 23:43:23 +0800 Subject: [PATCH 04/53] update cabal --- Hastructure.cabal | 1 - 1 file changed, 1 deletion(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index ebac08e7..0652082c 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -111,7 +111,6 @@ library executable Hastructure-exe main-is: Main.hs other-modules: - GenInterface MainBase Paths_Hastructure hs-source-dirs: From d08a81db77a3defe434dc2e4bc8a9c3f230e3749 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 29 Mar 2025 01:13:43 +0800 Subject: [PATCH 05/53] include UT --- test/DealTest/DealTest.hs | 43 +++++++++++---- test/DealTest/MultiPoolDealTest.hs | 66 ++++++++++++++++------- test/DealTest/RevolvingTest.hs | 85 ++++++++++++++++++++++++++---- test/MainTest.hs | 3 +- 4 files changed, 154 insertions(+), 43 deletions(-) diff --git a/test/DealTest/DealTest.hs b/test/DealTest/DealTest.hs index c8fe7331..12e22fb4 100644 --- a/test/DealTest/DealTest.hs +++ b/test/DealTest/DealTest.hs @@ -72,11 +72,13 @@ baseCase = D.TestDeal { ,L.bndBalance=3000 ,L.bndRate=0.08 ,L.bndDuePrin=0.0 + ,L.bndStepUp = Nothing ,L.bndDueInt=0.0 ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,L.bndStmt=Nothing}) + ,L.bndStmt=Nothing + ,L.bndDueIntOverInt = 0}) ] ) ,D.pool = D.MultiPool $ @@ -96,7 +98,7 @@ baseCase = D.TestDeal { AB.Current] ,P.futureCf=Just (CF.CashFlowFrame dummySt []) ,P.asOfDate = T.fromGregorian 2022 1 1 - ,P.issuanceStat = Nothing + ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance, 4000)] ,P.extendPeriods = Nothing}))]) ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ (W.PayInt Nothing "General" ["A"] Nothing) @@ -104,22 +106,43 @@ baseCase = D.TestDeal { ])] ,D.collects = [W.Collect Nothing W.CollectedInterest "General" ,W.Collect Nothing W.CollectedPrincipal "General"] + ,D.liqProvider = Nothing + ,D.rateCap = Nothing + ,D.triggers = Nothing + ,D.ledgers = Nothing + ,D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) } baseTests = let - (dealAfterRun,poolCf,_,_) = case DR.runDeal baseCase DealPoolFlowPricing Nothing (AP.NonPerfAssumption Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) of - Left e -> error $ "Deal run failed"++ show e - Right x -> x + nonRunAssump = (AP.NonPerfAssumption Nothing Nothing Nothing Nothing Nothing (Just [AP.InspectPt MonthEnd (FutureCurrentPoolBalance Nothing)]) Nothing Nothing Nothing Nothing Nothing Nothing) + (dealAfterRun,poolCf,Just rcs,_) = case DR.runDeal baseCase DealPoolFlowPricing Nothing nonRunAssump of + Left e -> error $ "Deal run failed"++ show e + Right x -> x + inspects = [ rc | rc@(InspectBal {}) <- rcs ] in testGroup "Base Deal Test" - [ testCase "Dates pattern" $ - assertEqual "First Pay" - True - True - ,testCase "empty pool flow" $ + [ testCase "empty pool flow" $ assertEqual "empty pool flow" 0 -- (P.futureCf (D.pool baseCase)) 0 + -- https://docs.google.com/spreadsheets/d/1gmz8LOB01qqfPldquyDn43PJJ1MI016tS-JS5KW3SvM/edit?gid=1325808922#gid=1325808922 + ,testCase "pool current balance (run time)" $ + assertEqual "pool current balance (run time)" + (InspectBal (toDate "20220101") (FutureCurrentPoolBalance Nothing) 4000) + (inspects!!0) + ,testCase "pool current balance (run time 1)" $ + assertEqual "pool current balance (run time 1)" + (InspectBal (toDate "20220131") (FutureCurrentPoolBalance Nothing) 4000) + (inspects!!1) + ,testCase "pool current balance (run time 2)" $ + assertEqual "pool current balance (run time 2)" + (InspectBal (toDate "20220228") (FutureCurrentPoolBalance Nothing) 3946.27) + (inspects!!2) + ,testCase "pool current balance (run time 60)" $ + assertEqual "pool current balance (run time 60)" + (InspectBal (toDate "20270131") (FutureCurrentPoolBalance Nothing) 0.0) + (inspects!!61) ] + diff --git a/test/DealTest/MultiPoolDealTest.hs b/test/DealTest/MultiPoolDealTest.hs index 65025062..e33a5404 100644 --- a/test/DealTest/MultiPoolDealTest.hs +++ b/test/DealTest/MultiPoolDealTest.hs @@ -1,4 +1,4 @@ -module DealTest.MultiPoolDealTest(baseCase,baseTests) +module DealTest.MultiPoolDealTest(baseCase,mPoolbaseTests) where @@ -30,6 +30,9 @@ import qualified Data.Map as Map import qualified Data.Time as T import qualified Data.Set as S +import Debug.Trace +debug = flip trace + dummySt = (0,Lib.toDate "19000101",Nothing) multiPool = Map.fromList [(PoolName "PoolA",P.Pool {P.assets=[AB.Mortgage @@ -37,14 +40,15 @@ multiPool = Map.fromList [(PoolName "PoolA",P.Pool {P.assets=[AB.Mortgage 1000 0.085 60 Nothing AB.Current] ,P.futureCf= Nothing ,P.asOfDate = T.fromGregorian 2022 1 1 - ,P.issuanceStat = Nothing - ,P.extendPeriods = Nothing}) + ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance,1000)] + ,P.extendPeriods = Nothing + }) ,(PoolName "PoolB",(P.Pool {P.assets=[AB.Mortgage AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing} 3000 0.085 60 Nothing AB.Current] ,P.futureCf=Just (CF.CashFlowFrame dummySt []) ,P.asOfDate = T.fromGregorian 2022 1 1 - ,P.issuanceStat = Nothing + ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance,3000)] ,P.extendPeriods = Nothing}))] @@ -72,9 +76,11 @@ baseCase = D.TestDeal { ,L.bndRate=0.08 ,L.bndDuePrin=0.0 ,L.bndDueInt=0.0 + ,L.bndStepUp = Nothing ,L.bndDueIntDate=Nothing ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) + ,L.bndDueIntOverInt = 0 ,L.bndStmt=Nothing}) ] ) @@ -83,24 +89,44 @@ baseCase = D.TestDeal { (W.PayInt Nothing "General" ["A"] Nothing) ,(W.PayPrin Nothing "General" ["A"] Nothing) ])] - ,D.collects = [W.Collect Nothing W.CollectedInterest "General" - ,W.Collect Nothing W.CollectedPrincipal "General"] + ,D.collects = [W.Collect (Just [PoolName "PoolA",PoolName "PoolB"]) W.CollectedInterest "General" + ,W.Collect (Just [PoolName "PoolA",PoolName "PoolB"]) W.CollectedPrincipal "General" + ] + ,D.liqProvider = Nothing + ,D.rateCap = Nothing + ,D.triggers = Nothing + ,D.ledgers = Nothing + ,D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) } -baseTests = +mPoolbaseTests = let - (dealAfterRun,poolCf,_,_) = case DR.runDeal baseCase DealPoolFlowPricing Nothing (AP.NonPerfAssumption Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing) of - Left _ -> undefined - Right x -> x + inspectVars = [AP.InspectRpt MonthEnd [FutureCurrentPoolBalance Nothing + ,FutureCurrentPoolBalance (Just [PoolName "PoolA"]) + ,FutureCurrentPoolBalance (Just [PoolName "PoolB"]) + ,FutureCurrentPoolBalance (Just [PoolName "PoolB",PoolName "PoolA"])] + ] + nonRunAssump = AP.NonPerfAssumption Nothing Nothing Nothing Nothing Nothing (Just inspectVars) Nothing Nothing Nothing Nothing Nothing Nothing + (dealAfterRun,poolCf,Just rcs,_) = case DR.runDeal baseCase DealPoolFlowPricing Nothing nonRunAssump of + Right x -> x + Left y -> error ("Error in running deal"++ show y) + inspects = [ rc | rc@(InspectBal {}) <- rcs ] in - testGroup "Base Deal Test" - [ testCase "Dates pattern" $ - assertEqual "First Pay" - True - True - ,testCase "empty pool flow" $ - assertEqual "empty pool flow" - 0 - -- (P.futureCf (D.pool baseCase)) - 0 + testGroup "Multi Pool Deal Test" + [testCase "pool current balance (run time)" $ + assertEqual "pool current balance (run time)" + (InspectBal (toDate "20220101") (FutureCurrentPoolBalance Nothing) 4000) + (inspects!!0) + ,testCase "pool current balance (run time)" $ + assertEqual "pool current balance (run time)" + (InspectBal (toDate "20220101") (FutureCurrentPoolBalance (Just [PoolName "PoolA"])) 1000) + (inspects!!1) + ,testCase "pool current balance (run time)" $ + assertEqual "pool current balance (run time)" + (InspectBal (toDate "20220101") (FutureCurrentPoolBalance (Just [PoolName "PoolB"])) 3000) + (inspects!!2) + ,testCase "pool current balance (run time)" $ + assertEqual "pool current balance (run time)" + (InspectBal (toDate "20220101") (FutureCurrentPoolBalance (Just [PoolName "PoolB",PoolName "PoolA"])) 4000) + (inspects!!3) ] diff --git a/test/DealTest/RevolvingTest.hs b/test/DealTest/RevolvingTest.hs index 711d0351..1dcde93e 100644 --- a/test/DealTest/RevolvingTest.hs +++ b/test/DealTest/RevolvingTest.hs @@ -8,7 +8,7 @@ import Deal import qualified Accounts as A import qualified Stmt as S -import qualified Asset as P +import qualified Pool as P import qualified AssetClass.Mortgage as ACM import qualified AssetClass.AssetBase as AB import qualified Expense as F @@ -33,7 +33,69 @@ import Types import Control.Lens hiding (element) import Control.Lens.TH -import DealTest.DealTest (emptyCase,baseCase) +multiPool = Map.fromList [(PoolName "PoolA",P.Pool {P.assets=[AB.Mortgage + AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing} + 1000 0.085 60 Nothing AB.Current] + ,P.futureCf= Nothing + ,P.asOfDate = T.fromGregorian 2022 1 1 + ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance,1000)] + ,P.extendPeriods = Nothing + }) + ,(PoolName "PoolB",(P.Pool {P.assets=[AB.Mortgage + AB.MortgageOriginalInfo{ AB.originBalance=4000 ,AB.originRate=Fix DC_ACT_365F 0.085 ,AB.originTerm=60 ,AB.period=Monthly ,AB.startDate=T.fromGregorian 2022 1 1 ,AB.prinType= AB.Level ,AB.prepaymentPenalty = Nothing} + 3000 0.085 60 Nothing AB.Current] + ,P.futureCf= Nothing + ,P.asOfDate = T.fromGregorian 2022 1 1 + ,P.issuanceStat = Just $ Map.fromList [(IssuanceBalance,3000)] + ,P.extendPeriods = Nothing}))] + + +baseCase = D.TestDeal { + D.name = "base case" + ,D.status = Amortizing + ,D.rateSwap = Nothing + ,D.currencySwap = Nothing + ,D.dates = CurrentDates (toDate "20220101",toDate "20220101") Nothing (toDate "20300101") + (toDate "20220201" , MonthFirst) (toDate "20220225" , MonthFirst) + ,D.accounts = (Map.fromList + [("General", (A.Account { A.accName="General" ,A.accBalance=1000.0 ,A.accType=Nothing, A.accInterest=Nothing ,A.accStmt=Nothing }))]) + ,D.fees = Map.empty + ,D.bonds = (Map.fromList [("A" + ,L.Bond{ + L.bndName="A" + ,L.bndType=L.Sequential + ,L.bndOriginInfo= L.OriginalInfo{ + L.originBalance=3000 + ,L.originDate= (T.fromGregorian 2022 1 1) + ,L.originRate= 0.08 + ,L.maturityDate = Nothing} + ,L.bndInterestInfo= L.Fix 0.08 DC_ACT_365F + ,L.bndBalance=3000 + ,L.bndRate=0.08 + ,L.bndDuePrin=0.0 + ,L.bndDueInt=0.0 + ,L.bndStepUp = Nothing + ,L.bndDueIntDate=Nothing + ,L.bndLastIntPay = Just (T.fromGregorian 2022 1 1) + ,L.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) + ,L.bndDueIntOverInt = 0 + ,L.bndStmt=Nothing}) + ] + ) + ,D.pool = D.MultiPool multiPool + ,D.waterfall = Map.fromList [(W.DistributionDay Amortizing, [ + (W.PayInt Nothing "General" ["A"] Nothing) + ,(W.PayPrin Nothing "General" ["A"] Nothing) + ])] + ,D.collects = [W.Collect (Just [PoolName "PoolA",PoolName "PoolB"]) W.CollectedInterest "General" + ,W.Collect (Just [PoolName "PoolA",PoolName "PoolB"]) W.CollectedPrincipal "General" + ] + ,D.liqProvider = Nothing + ,D.rateCap = Nothing + ,D.triggers = Nothing + ,D.ledgers = Nothing + ,D.stats = (Map.empty,Map.empty,Map.empty,Map.empty) +} baseTests = @@ -45,19 +107,20 @@ baseTests = 0.08 24 AB.Current)] - revolvingAssump = Just (AP.AvailableAssets (R.ConstantAsset $ AB.LO <$> poolAssets) + rAssump = Just (AP.AvailableAssets (R.ConstantAsset $ AB.LO <$> poolAssets) (AP.PoolLevel ((AP.LoanAssump Nothing Nothing Nothing Nothing) ,AP.DummyDelinqAssump ,AP.DummyDefaultAssump)) ) - - -- revolvingDeal = set D.dealPool (D.SoloPool P.Pool{P.assets = poolAssets, P.futureCf=Nothing - -- ,P.futureScheduleCf = Nothing, P.asOfDate = toDate "20220101" - -- ,P.issuanceStat = Nothing, P.extendPeriods = Nothing }) baseCase - - -- (dealAfterRun,poolCf,_,_) = DR.runDeal baseCase DealPoolFlowPricing - -- Nothing - -- (AP.NonPerfAssumption Nothing Nothing Nothing revolvingAssump Nothing Nothing Nothing Nothing Nothing Nothing) + inspectVars = [AP.InspectRpt MonthEnd [FutureCurrentPoolBalance Nothing + ,FutureCurrentPoolBalance (Just [PoolName "PoolA"]) + ,FutureCurrentPoolBalance (Just [PoolName "PoolB"]) + ,FutureCurrentPoolBalance (Just [PoolName "PoolB",PoolName "PoolA"])] + ] + nonRunAssump = AP.NonPerfAssumption Nothing Nothing Nothing rAssump Nothing (Just inspectVars) Nothing Nothing Nothing Nothing Nothing Nothing + (dealAfterRun,poolCf,_,_) = case DR.runDeal baseCase DealPoolFlowPricing Nothing nonRunAssump of + Right x -> x + Left y -> error ("Error in running deal"++ show y) in testGroup "Revolving: Single Pool" [ testCase "Asset: Loan" $ diff --git a/test/MainTest.hs b/test/MainTest.hs index 9975f3e8..9b8669eb 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -31,7 +31,6 @@ import qualified Stmt as S import qualified Data.Time as T import qualified Data.Vector as UtilT import qualified UT.UtilTest as RH -import qualified UT.RateHedgeTest as RHT import GHC.Generics (U1(U1)) main = defaultMain tests @@ -108,7 +107,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,AnalyticsT.irrTest ,DealTest.baseTests ,RevolvingTest.baseTests - --,DealMultiTest.baseTests + ,DealMultiTest.mPoolbaseTests ,RHT.capRateTests ,CET.liqTest ] From cfc20b7186bb3e5b01a5d57ab6237c528e2b36de Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 29 Mar 2025 01:14:47 +0800 Subject: [PATCH 06/53] Lift pool current balance query --- src/Deal.hs | 2 +- src/Deal/DealQuery.hs | 8 +++++--- src/Pool.hs | 12 ++++++------ 3 files changed, 12 insertions(+), 10 deletions(-) diff --git a/src/Deal.hs b/src/Deal.hs index 115ef3de..2a892514 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -95,7 +95,7 @@ setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Floater br idx _spd rset dc mf mc) = Right $ (L.accrueInt d b){ L.bndRate = applyFloatRate ii d ras } -- ^ Fix rate, do nothing -setBondNewRate t d ras b@(L.Bond _ _ _ ii@(L.Fix {}) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) +setBondNewRate t d ras b@(L.Bond _ _ _ L.Fix {} _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) = Right b -- ^ Ref rate diff --git a/src/Deal/DealQuery.hs b/src/Deal/DealQuery.hs index 601de3ca..6acda91e 100644 --- a/src/Deal/DealQuery.hs +++ b/src/Deal/DealQuery.hs @@ -394,12 +394,14 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f (Just pids, MultiPool pm) -> if S.isSubsetOf (S.fromList pids) (S.fromList (Map.keys pm)) then let - m = Map.filterWithKey (\k _ -> S.member k (S.fromList pids)) pm + selectedPools = Map.elems $ Map.filterWithKey (\k _ -> S.member k (S.fromList pids)) pm in - Right . toRational $ sum $ Map.elems $ Map.map (`Pl.getIssuanceField` RuntimeCurrentPoolBalance) m + do + currentBals <- sequenceA $ (`Pl.getIssuanceField` RuntimeCurrentPoolBalance) <$> selectedPools + return $ toRational $ sum currentBals else Left $ "Date:"++show d++"Failed to find pool balance" ++ show pids ++ " from deal "++ show (Map.keys pm) - _ -> Left $ "Date:"++show d++"Failed to find pool" ++ show (mPns) ++","++ show pt + _ -> Left $ "Date:"++show d++"Failed to find pool" ++ show mPns ++","++ show pt FutureCurrentSchedulePoolBalance mPns -> let diff --git a/src/Pool.hs b/src/Pool.hs index ea4ee533..d21d2f6e 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -36,10 +36,10 @@ import Control.Lens hiding (element) import Control.Lens.TH import Assumptions (ApplyAssumptionType) -import Debug.Trace import Util import Cashflow (CashFlowFrame) import qualified Stmt as CF +import Debug.Trace debug = flip trace @@ -90,13 +90,13 @@ poolIssuanceStat = lens getter setter -- | get stats of pool -getIssuanceField :: Pool a -> CutoffFields -> Balance +getIssuanceField :: Pool a -> CutoffFields -> Either String Balance getIssuanceField p@Pool{issuanceStat = Just m} s = case Map.lookup s m of - Just r -> r - Nothing -> 0.0 -getIssuanceField Pool{issuanceStat = Nothing} _ - = error "There is no pool stats" + Just r -> Right r + Nothing -> Left $ "Faile dto find field "++ show s ++ "in pool issuance " ++ show m +getIssuanceField Pool{issuanceStat = Nothing} s + = Left $ "There is no pool stats to lookup:" ++ show s poolBegStats :: Pool a -> (Balance,Balance,Balance,Balance,Balance,Balance) poolBegStats p = From dcfae79cb62bc233984cd55bb820dcb371c23862 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 29 Mar 2025 01:32:04 +0800 Subject: [PATCH 07/53] update cabal --- Hastructure.cabal | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 0652082c..73536093 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -1,4 +1,4 @@ -cabal-version: 1.12 +cabal-version: 3.0 -- This file has been generated from package.yaml by hpack version 0.37.0. -- @@ -13,7 +13,7 @@ bug-reports: https://github.com/yellowbean/Hastructure/issues author: Xiaoyu maintainer: always.zhang@gmail.com copyright: 2025 Xiaoyu, Zhang -license: BSD3 +license: BSD-3-Clause license-file: LICENSE build-type: Simple extra-source-files: @@ -103,9 +103,10 @@ library , template-haskell , text , time - , vector , wai , yaml + , vector +-- , proto3-wire default-language: Haskell2010 executable Hastructure-exe @@ -157,11 +158,11 @@ executable Hastructure-exe , text , time , unordered-containers - , vector , wai , wai-cors , warp , yaml +-- , proto3-suite default-language: Haskell2010 test-suite Hastructure-test @@ -228,7 +229,6 @@ test-suite Hastructure-test , template-haskell , text , time - , vector , wai , yaml default-language: Haskell2010 From d4f5004ba68f8e93b3d01824029b1cc559dab6f2 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 29 Mar 2025 01:56:44 +0800 Subject: [PATCH 08/53] add eq to result component --- src/Types.hs | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/src/Types.hs b/src/Types.hs index 3ff30fcb..854cd487 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -32,7 +32,7 @@ module Types ,ActionWhen(..),DealStatFields(..) ,getDealStatType,getPriceValue,preHasTrigger ,MyRatio,HowToPay(..),ApplyRange(..),BondPricingMethod(..) - ,_BondTxn + ,_BondTxn ,_InspectBal ) where @@ -167,6 +167,7 @@ data Index = LPR5Y | BBSW | IRPH -- The IRPH (Índice de Referencia de Préstamos Hipotecarios) is a reference index used in Spain to fix the interest rate of mortgage loans | SONIA + -- deriving (Show,Eq,Generic,Ord,Read, Bounded, Enum, Finite, Named, ProtoEnum) deriving (Show,Eq,Generic,Ord,Read) type Floater = (Index,Spread) @@ -215,7 +216,7 @@ data DatePattern = MonthEnd | SemiAnnual (Int, Int) (Int, Int) | CustomDate [Date] | SingletonDate Date - | DaysInYear [(Int, Int)] + | DaysInYear [(Int, Int)] -- MM/DD | EveryNMonth Date Int | Weekday Int | AllDatePattern [DatePattern] @@ -740,14 +741,14 @@ type BookItems = [BookItem] data BookItem = Item String Balance | ParentItem String BookItems - deriving (Show,Read,Generic) + deriving (Show,Read,Generic,Eq) data BalanceSheetReport = BalanceSheetReport { asset :: BookItem ,liability :: BookItem ,equity :: BookItem ,reportDate :: Date} -- ^ snapshot date of the balance sheet - deriving (Show,Read,Generic) + deriving (Show,Read,Generic,Eq) data CashflowReport = CashflowReport { inflow :: BookItem @@ -755,7 +756,7 @@ data CashflowReport = CashflowReport { ,net :: BookItem ,startDate :: Date ,endDate :: Date } - deriving (Show,Read,Generic) + deriving (Show,Read,Generic,Eq) data Threshold = Below | EqBelow @@ -947,7 +948,9 @@ data ResultComponent = CallAt Date -- ^ | WarningMsg String | EndRun (Maybe Date) String -- ^ end of run with a message -- | SnapshotCashflow Date String CashFlowFrame - deriving (Show, Generic) + deriving (Show, Generic,Eq) + +makePrisms ''ResultComponent listToStrWithComma :: [String] -> String From a88d06ce55cc56aea05d47865843633ea116542f Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 29 Mar 2025 12:02:51 +0800 Subject: [PATCH 09/53] Vector to test --- Hastructure.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/Hastructure.cabal b/Hastructure.cabal index 73536093..57bc3bdc 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -231,4 +231,5 @@ test-suite Hastructure-test , time , wai , yaml + , vector default-language: Haskell2010 From b31abf10986950079eb5fdf9a31782db9138d444 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 29 Mar 2025 21:08:38 +0800 Subject: [PATCH 10/53] clean up --- cabal.project.freeze | 283 +++++++++++++++++++++++++++++++++++++++++ src/Deal/DealAction.hs | 3 +- src/Deal/DealQuery.hs | 2 +- src/Errors.hs | 15 +-- src/GenInterface.hs | 16 +++ src/Liability.hs | 2 +- src/Util.hs | 6 - src/WebUI.hs | 89 ------------- 8 files changed, 306 insertions(+), 110 deletions(-) create mode 100644 cabal.project.freeze create mode 100644 src/GenInterface.hs delete mode 100644 src/WebUI.hs diff --git a/cabal.project.freeze b/cabal.project.freeze new file mode 100644 index 00000000..57c7cc73 --- /dev/null +++ b/cabal.project.freeze @@ -0,0 +1,283 @@ +active-repositories: mirrors.ustc.edu.cn:merge +constraints: any.Cabal ==3.8.1.0, + any.Cabal-syntax ==3.8.1.0, + any.Decimal ==0.5.2, + any.HUnit ==1.6.2.0, + any.OneTuple ==0.4.2, + any.QuickCheck ==2.14.3, + QuickCheck -old-random +templatehaskell, + any.StateVar ==1.2.2, + any.adjunctions ==4.4.3, + any.aeson ==2.1.2.1, + aeson -cffi +ordered-keymap, + any.aeson-pretty ==0.8.10, + aeson-pretty -lib-only, + any.ansi-terminal ==1.1.2, + ansi-terminal -example, + any.ansi-terminal-types ==1.1, + any.appar ==0.1.8, + any.array ==0.5.4.0, + any.asn1-encoding ==0.9.6, + any.asn1-parse ==0.9.5, + any.asn1-types ==0.3.4, + any.assoc ==1.1.1, + assoc -tagged, + any.async ==2.2.5, + async -bench, + any.attoparsec ==0.14.4, + attoparsec -developer, + any.attoparsec-aeson ==2.1.0.0, + any.attoparsec-iso8601 ==1.1.0.0, + any.auto-update ==0.2.6, + any.base ==4.17.0.0, + any.base-compat ==0.13.1, + any.base-compat-batteries ==0.13.1, + any.base-orphans ==0.9.3, + any.base-unicode-symbols ==0.2.4.2, + base-unicode-symbols +base-4-8 -old-base, + any.base64-bytestring ==1.2.1.0, + any.basement ==0.0.16, + any.bifunctors ==5.6.2, + bifunctors +tagged, + any.binary ==0.8.9.1, + any.bitvec ==1.1.5.0, + bitvec +simd, + any.blaze-builder ==0.4.2.3, + any.blaze-html ==0.9.2.0, + any.blaze-markup ==0.8.3.0, + any.boring ==0.2.2, + boring +tagged, + any.bsb-http-chunked ==0.0.0.4, + any.byteorder ==1.0.4, + any.bytestring ==0.11.3.1, + any.cabal-doctest ==1.0.11, + any.call-stack ==0.4.0, + any.case-insensitive ==1.2.1.0, + any.cmdargs ==0.10.22, + cmdargs +quotation -testprog, + any.colour ==2.3.6, + any.comonad ==5.0.9, + comonad +containers +distributive +indexed-traversable, + any.conduit ==1.3.6.1, + any.constraints ==0.14.2, + any.containers ==0.6.6, + any.contravariant ==1.5.5, + contravariant +semigroups +statevar +tagged, + any.cookie ==0.4.6, + any.crypton ==1.0.2, + crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, + any.crypton-x509 ==1.7.7, + any.csv ==0.1.2, + any.data-default ==0.8.0.1, + any.data-default-class ==0.2.0.0, + any.data-fix ==0.3.4, + any.dec ==0.0.6, + any.deepseq ==1.4.8.0, + any.directory ==1.3.7.1, + any.distributive ==0.6.2.1, + distributive +semigroups +tagged, + any.dlist ==1.0, + dlist -werror, + any.easy-file ==0.2.5, + any.exceptions ==0.10.5, + any.fast-logger ==3.2.5, + any.file-embed ==0.0.16.0, + any.filepath ==1.4.2.2, + any.foldable1-classes-compat ==0.1.1, + foldable1-classes-compat +tagged, + any.free ==5.2, + any.generic-lens ==2.2.2.0, + any.generic-lens-core ==2.2.1.0, + any.generically ==0.1.1, + any.generics-sop ==0.5.1.3, + any.ghc-bignum ==1.3, + any.ghc-boot-th ==9.4.4, + any.ghc-prim ==0.9.0, + any.hashable ==1.4.4.0, + hashable +integer-gmp -random-initial-seed, + any.haskell-lexer ==1.2.1, + any.hourglass ==0.2.12, + any.hsc2hs ==0.68.10, + hsc2hs -in-ghc-tree, + any.hspec ==2.11.12, + any.hspec-api ==2.11.12, + any.hspec-core ==2.11.12, + any.hspec-discover ==2.11.12, + any.hspec-expectations ==0.8.4, + any.html ==1.0.1.2, + any.http-api-data ==0.5.1, + http-api-data -use-text-show, + any.http-client ==0.7.19, + http-client +network-uri, + any.http-date ==0.0.11, + any.http-media ==0.8.1.1, + any.http-semantics ==0.3.0, + any.http-types ==0.12.4, + any.http2 ==5.3.9, + http2 -devel -h2spec, + any.ieee754 ==0.8.0, + any.indexed-profunctors ==0.1.1.1, + any.indexed-traversable ==0.1.4, + any.indexed-traversable-instances ==0.1.2, + any.insert-ordered-containers ==0.2.5.3, + any.integer-gmp ==1.1, + any.integer-logarithms ==1.0.4, + integer-logarithms -check-bounds +integer-gmp, + any.invariant ==0.6.4, + any.iproute ==1.7.15, + any.kan-extensions ==5.2.6, + any.lens ==5.2.3, + lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, + any.libyaml ==0.1.4, + libyaml -no-unicode -system-libyaml, + any.libyaml-clib ==0.2.5, + any.logict ==0.8.2.0, + any.lucid ==2.11.20250303, + any.math-functions ==0.3.4.4, + math-functions +system-erf +system-expm1, + any.memory ==0.18.0, + memory +support_bytestring +support_deepseq, + any.mime-types ==0.1.2.0, + any.mmorph ==1.2.0, + any.monad-control ==1.0.3.1, + any.monad-loops ==0.4.3, + monad-loops +base4, + any.mono-traversable ==1.0.21.0, + any.mtl ==2.2.2, + any.network ==3.2.7.0, + network -devel, + any.network-byte-order ==0.1.7, + any.network-control ==0.1.4, + any.network-uri ==2.6.4.2, + any.numeric-limits ==0.1.0.0, + any.old-locale ==1.0.0.7, + any.old-time ==1.1.0.4, + any.openapi3 ==3.2.4, + any.optics-core ==0.4.1.1, + optics-core -explicit-generic-labels, + any.optics-extra ==0.4.2.1, + any.optics-th ==0.4.1, + any.optparse-applicative ==0.18.1.0, + optparse-applicative +process, + any.os-string ==2.0.7, + any.parallel ==3.2.2.0, + any.parsec ==3.1.15.0, + any.pem ==0.2.4, + any.pretty ==1.1.3.6, + any.prettyprinter ==1.7.1, + prettyprinter -buildreadme +text, + any.prettyprinter-ansi-terminal ==1.1.3, + any.primitive ==0.8.0.0, + any.process ==1.6.16.0, + any.profunctors ==5.6.2, + any.psqueues ==0.2.8.1, + any.quickcheck-io ==0.2.0, + any.random ==1.2.1.3, + any.recv ==0.1.0, + any.reflection ==2.1.9, + reflection -slow +template-haskell, + any.regex-base ==0.94.0.3, + any.regex-pcre-builtin ==0.95.2.3.8.44, + any.regex-tdfa ==1.3.2.3, + regex-tdfa +doctest -force-o2, + any.resourcet ==1.3.0, + any.rts ==1.0.2, + any.safe ==0.3.21, + any.scientific ==0.3.7.0, + scientific -bytestring-builder -integer-simple, + any.semialign ==1.3.1, + semialign +semigroupoids, + any.semigroupoids ==6.0.1, + semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, + any.semigroups ==0.20, + semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, + any.servant ==0.20.2, + any.servant-checked-exceptions ==2.2.0.1, + servant-checked-exceptions -buildexample, + any.servant-checked-exceptions-core ==2.2.0.1, + servant-checked-exceptions-core -buildexample, + any.servant-client ==0.20.2, + any.servant-client-core ==0.20.2, + any.servant-docs ==0.13.1, + any.servant-openapi3 ==2.0.1.6, + any.servant-server ==0.20.2, + any.simple-sendfile ==0.2.32, + simple-sendfile +allow-bsd -fallback, + any.singleton-bool ==0.1.8, + any.smallcheck ==1.2.1.1, + any.some ==1.0.6, + some +newtype-unsafe, + any.sop-core ==0.5.0.2, + any.split ==0.2.5, + any.splitmix ==0.1.1, + splitmix -optimised-mixer, + any.stm ==2.5.1.0, + any.streaming-commons ==0.2.3.0, + streaming-commons -use-bytestring-builder, + any.strict ==0.5, + any.string-conversions ==0.4.0.1, + any.swagger2 ==2.8.9, + any.tabular ==0.2.2.8, + any.tagged ==0.8.9, + tagged +deepseq +transformers, + any.tasty ==1.5.3, + tasty +unix, + any.tasty-golden ==2.3.5, + tasty-golden -build-example, + any.tasty-hspec ==1.2.0.4, + any.tasty-hunit ==0.10.2, + any.tasty-quickcheck ==0.11.1, + any.tasty-smallcheck ==0.8.2, + any.template-haskell ==2.19.0.0, + any.temporary ==1.3, + any.text ==2.0.1, + any.text-short ==0.1.6, + text-short -asserts, + any.tf-random ==0.5, + any.th-abstraction ==0.5.0.0, + any.th-compat ==0.1.6, + any.these ==1.2.1, + any.time ==1.12.2, + any.time-compat ==1.9.8, + any.time-manager ==0.2.2, + any.transformers ==0.5.6.2, + any.transformers-base ==0.4.6, + transformers-base +orphaninstances, + any.transformers-compat ==0.7.2, + transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, + any.typed-process ==0.2.12.0, + any.universe-base ==1.1.4, + any.unix ==2.7.3, + any.unix-compat ==0.7.3, + any.unix-time ==0.4.16, + any.unliftio-core ==0.2.1.0, + any.unordered-containers ==0.2.20, + unordered-containers -debug, + any.utf8-string ==1.0.2, + any.uuid-types ==1.0.6, + any.vault ==0.3.1.5, + vault +useghc, + any.vector ==0.13.2.0, + vector +boundschecks -internalchecks -unsafechecks -wall, + any.vector-algorithms ==0.9.1.0, + vector-algorithms +bench +boundschecks -internalchecks -llvm -unsafechecks, + any.vector-stream ==0.1.0.1, + any.void ==0.7.3, + void -safe, + any.wai ==3.2.4, + any.wai-app-static ==3.1.9, + wai-app-static +crypton -print, + any.wai-cors ==0.2.7, + any.wai-extra ==3.1.17, + wai-extra -build-example, + any.wai-logger ==2.5.0, + any.warp ==3.4.7, + warp +allow-sendfilefd -network-bytestring -warp-debug +x509, + any.witherable ==0.4.2, + any.word8 ==0.1.3, + any.world-peace ==1.0.2.0, + any.yaml ==0.11.11.2, + yaml +no-examples +no-exe, + any.zlib ==0.7.1.0, + zlib -bundled-c-zlib +non-blocking-ffi -pkg-config +index-state: HEAD diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index 927217e2..b6db9de5 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -105,7 +105,8 @@ allocAmtToBonds theOrder amt bndsWithDue = 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 (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 diff --git a/src/Deal/DealQuery.hs b/src/Deal/DealQuery.hs index 6acda91e..6829a172 100644 --- a/src/Deal/DealQuery.hs +++ b/src/Deal/DealQuery.hs @@ -995,4 +995,4 @@ preToStr t d p = ps = patchDateToStats d testPre2 :: P.Asset a => Date -> TestDeal a -> Pre -> (String, Either String Bool) -testPre2 d t p = (preToStr t d p, testPre d t p) +testPre2 d t p = (preToStr t d p, testPre d t p) \ No newline at end of file diff --git a/src/Errors.hs b/src/Errors.hs index 6b12b7b9..8e5c41ab 100644 --- a/src/Errors.hs +++ b/src/Errors.hs @@ -1,22 +1,13 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE ScopedTypeVariables #-} -module Errors(EngineError(..),ErrorMonad) +module Errors(EngineError(..)) where -import Control.Exception -data EngineError = DivideZero +data EngineError = DivideZero | NoComponentFound | NotValidAction - deriving (Show,Eq,Ord,Read) - -instance Exception EngineError -type ErrorMonad = Either EngineError + deriving (Show,Eq,Ord,Read) \ No newline at end of file diff --git a/src/GenInterface.hs b/src/GenInterface.hs new file mode 100644 index 00000000..e182718e --- /dev/null +++ b/src/GenInterface.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DeriveGeneric #-} +module GenInterface() + +where + +import GHC.Generics + +import Proto3.Wire +import qualified Proto3.Wire.Encode as Encode +import qualified Proto3.Wire.Decode as Decode + +import Types + + +-- encodeDateType :: DateType -> Encode.MessageBuilder +-- encodeDateType (DateType a) = Encode.int32 a \ No newline at end of file diff --git a/src/Liability.hs b/src/Liability.hs index 684ab2c9..88b942ae 100644 --- a/src/Liability.hs +++ b/src/Liability.hs @@ -100,7 +100,7 @@ data InterestOverInterestType = OverCurrRateBy Rational -- ^ inflat ioi rate by --------------------------- start Rate, index, spread, reset dates, daycount, floor, cap data InterestInfo = Floater IRate Index Spread RateReset DayCount (Maybe Floor) (Maybe Cap) | Fix IRate DayCount -- ^ fixed rate - | RefBal DealStats InterestInfo + | RefBal DealStats InterestInfo -- ^ accure interest based on balance(described by a formula) | RefRate IRate DealStats Float RateReset -- ^ interest rate depends to a formula | CapRate InterestInfo IRate -- ^ cap rate | FloorRate InterestInfo IRate -- ^ floor rate diff --git a/src/Util.hs b/src/Util.hs index 49d85a2a..26b48c4c 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -449,12 +449,6 @@ lookupTuple7 :: (Ord k) => (k, k, k, k, k, k, k) -> Map.Map k v -> (Maybe v, May lookupTuple7 (k1, k2, k3, k4, k5, k6, k7) m = ( Map.lookup k1 m , Map.lookup k2 m , Map.lookup k3 m , Map.lookup k4 m , Map.lookup k5 m , Map.lookup k6 m, Map.lookup k7 m) --- flowCombination :: [Date] -> [Amount] -> [(Date,Amount)] --- flowCombination ds vs = --- let --- --- in --- zip ds vs ----- DEBUG/PRINT debugOnDate :: Date -> Date -> Date -> String diff --git a/src/WebUI.hs b/src/WebUI.hs deleted file mode 100644 index 6a1c78e9..00000000 --- a/src/WebUI.hs +++ /dev/null @@ -1,89 +0,0 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE ImportQualifiedPost #-} -{-# LANGUAGE TypeOperators #-} - - module WebUI where --- --- import Web.Hyperbole --- import Data.Text (Text) --- --- import qualified Accounts as A --- import Types --- --- import Web.Hyperbole --- import Data.Text (Text) --- import GHC.Generics (Generic) --- --- -- Define your ADT --- data Shape = --- Circle Double --- | Rectangle Double Double --- | Triangle Double Double Double --- deriving (Show, Generic, HyperView) --- --- instance HyperView Shape where --- data Action Shape = --- SetShape Text --- | SetCircleRadius Double --- | SetRectangleWidth Double --- | SetRectangleHeight Double --- | SetTriangleA Double --- | SetTriangleB Double --- | SetTriangleC Double --- deriving (Show, Read, ViewAction) --- --- view _ s = do --- col id $ do --- -- Dropdown for shape selection --- select "shape" (viewShapeName s) SetShape [("Circle", "Circle"), ("Rectangle", "Rectangle"), ("Triangle", "Triangle")] --- case s of --- Circle r -> do --- field "radius" r SetCircleRadius --- Rectangle w h -> do --- field "width" w SetRectangleWidth --- field "height" h SetRectangleHeight --- Triangle a b c -> do --- field "side a" a SetTriangleA --- field "side b" b SetTriangleB --- field "side c" c SetTriangleC --- --- update (SetShape "Circle") _ = Circle 0 --- update (SetShape "Rectangle") _ = Rectangle 0 0 --- update (SetShape "Triangle") _ = Triangle 0 0 0 --- update (SetCircleRadius r) _ = Circle r --- update (SetRectangleWidth w) (Rectangle _ h) = Rectangle w h --- update (SetRectangleHeight h) (Rectangle w _) = Rectangle w h --- update (SetTriangleA a) (Triangle _ b c) = Triangle a b c --- update (SetTriangleB b) (Triangle a _ c) = Triangle a b c --- update (SetTriangleC c) (Triangle a b _) = Triangle a b c --- update _ s = s -- Default case, no change --- --- -- Helper function to convert Shape to text for the select dropdown --- viewShapeName :: Shape -> Text --- viewShapeName (Circle _) = "Circle" --- viewShapeName (Rectangle _ _) = "Rectangle" --- viewShapeName (Triangle _ _ _) = "Triangle" --- --- -- Define a simple page --- page :: (Hyperbole :> es) => Eff es (Page '[Shape]) --- page = do --- pure $ col id $ do --- hyper ShapeForm $ view ShapeForm (Circle 0) --- --- --- --- main :: IO () --- main = do --- run 3001 $ do --- liveApp (basicDocument "Example") (runPage page) --- -- --- -- page :: Eff es (Page '[]) --- -- page = do --- -- pure $ do --- -- col (pad 10) $ do --- -- hyper MonthEnd dpView "A" \ No newline at end of file From e23fae1335a9a05b5f48e032474f037389f7c755 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 29 Mar 2025 21:58:58 +0800 Subject: [PATCH 11/53] rm pj freeze --- cabal.project.freeze | 283 ------------------------------------------- 1 file changed, 283 deletions(-) delete mode 100644 cabal.project.freeze diff --git a/cabal.project.freeze b/cabal.project.freeze deleted file mode 100644 index 57c7cc73..00000000 --- a/cabal.project.freeze +++ /dev/null @@ -1,283 +0,0 @@ -active-repositories: mirrors.ustc.edu.cn:merge -constraints: any.Cabal ==3.8.1.0, - any.Cabal-syntax ==3.8.1.0, - any.Decimal ==0.5.2, - any.HUnit ==1.6.2.0, - any.OneTuple ==0.4.2, - any.QuickCheck ==2.14.3, - QuickCheck -old-random +templatehaskell, - any.StateVar ==1.2.2, - any.adjunctions ==4.4.3, - any.aeson ==2.1.2.1, - aeson -cffi +ordered-keymap, - any.aeson-pretty ==0.8.10, - aeson-pretty -lib-only, - any.ansi-terminal ==1.1.2, - ansi-terminal -example, - any.ansi-terminal-types ==1.1, - any.appar ==0.1.8, - any.array ==0.5.4.0, - any.asn1-encoding ==0.9.6, - any.asn1-parse ==0.9.5, - any.asn1-types ==0.3.4, - any.assoc ==1.1.1, - assoc -tagged, - any.async ==2.2.5, - async -bench, - any.attoparsec ==0.14.4, - attoparsec -developer, - any.attoparsec-aeson ==2.1.0.0, - any.attoparsec-iso8601 ==1.1.0.0, - any.auto-update ==0.2.6, - any.base ==4.17.0.0, - any.base-compat ==0.13.1, - any.base-compat-batteries ==0.13.1, - any.base-orphans ==0.9.3, - any.base-unicode-symbols ==0.2.4.2, - base-unicode-symbols +base-4-8 -old-base, - any.base64-bytestring ==1.2.1.0, - any.basement ==0.0.16, - any.bifunctors ==5.6.2, - bifunctors +tagged, - any.binary ==0.8.9.1, - any.bitvec ==1.1.5.0, - bitvec +simd, - any.blaze-builder ==0.4.2.3, - any.blaze-html ==0.9.2.0, - any.blaze-markup ==0.8.3.0, - any.boring ==0.2.2, - boring +tagged, - any.bsb-http-chunked ==0.0.0.4, - any.byteorder ==1.0.4, - any.bytestring ==0.11.3.1, - any.cabal-doctest ==1.0.11, - any.call-stack ==0.4.0, - any.case-insensitive ==1.2.1.0, - any.cmdargs ==0.10.22, - cmdargs +quotation -testprog, - any.colour ==2.3.6, - any.comonad ==5.0.9, - comonad +containers +distributive +indexed-traversable, - any.conduit ==1.3.6.1, - any.constraints ==0.14.2, - any.containers ==0.6.6, - any.contravariant ==1.5.5, - contravariant +semigroups +statevar +tagged, - any.cookie ==0.4.6, - any.crypton ==1.0.2, - crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, - any.crypton-x509 ==1.7.7, - any.csv ==0.1.2, - any.data-default ==0.8.0.1, - any.data-default-class ==0.2.0.0, - any.data-fix ==0.3.4, - any.dec ==0.0.6, - any.deepseq ==1.4.8.0, - any.directory ==1.3.7.1, - any.distributive ==0.6.2.1, - distributive +semigroups +tagged, - any.dlist ==1.0, - dlist -werror, - any.easy-file ==0.2.5, - any.exceptions ==0.10.5, - any.fast-logger ==3.2.5, - any.file-embed ==0.0.16.0, - any.filepath ==1.4.2.2, - any.foldable1-classes-compat ==0.1.1, - foldable1-classes-compat +tagged, - any.free ==5.2, - any.generic-lens ==2.2.2.0, - any.generic-lens-core ==2.2.1.0, - any.generically ==0.1.1, - any.generics-sop ==0.5.1.3, - any.ghc-bignum ==1.3, - any.ghc-boot-th ==9.4.4, - any.ghc-prim ==0.9.0, - any.hashable ==1.4.4.0, - hashable +integer-gmp -random-initial-seed, - any.haskell-lexer ==1.2.1, - any.hourglass ==0.2.12, - any.hsc2hs ==0.68.10, - hsc2hs -in-ghc-tree, - any.hspec ==2.11.12, - any.hspec-api ==2.11.12, - any.hspec-core ==2.11.12, - any.hspec-discover ==2.11.12, - any.hspec-expectations ==0.8.4, - any.html ==1.0.1.2, - any.http-api-data ==0.5.1, - http-api-data -use-text-show, - any.http-client ==0.7.19, - http-client +network-uri, - any.http-date ==0.0.11, - any.http-media ==0.8.1.1, - any.http-semantics ==0.3.0, - any.http-types ==0.12.4, - any.http2 ==5.3.9, - http2 -devel -h2spec, - any.ieee754 ==0.8.0, - any.indexed-profunctors ==0.1.1.1, - any.indexed-traversable ==0.1.4, - any.indexed-traversable-instances ==0.1.2, - any.insert-ordered-containers ==0.2.5.3, - any.integer-gmp ==1.1, - any.integer-logarithms ==1.0.4, - integer-logarithms -check-bounds +integer-gmp, - any.invariant ==0.6.4, - any.iproute ==1.7.15, - any.kan-extensions ==5.2.6, - any.lens ==5.2.3, - lens -benchmark-uniplate -dump-splices +inlining -j +test-hunit +test-properties +test-templates +trustworthy, - any.libyaml ==0.1.4, - libyaml -no-unicode -system-libyaml, - any.libyaml-clib ==0.2.5, - any.logict ==0.8.2.0, - any.lucid ==2.11.20250303, - any.math-functions ==0.3.4.4, - math-functions +system-erf +system-expm1, - any.memory ==0.18.0, - memory +support_bytestring +support_deepseq, - any.mime-types ==0.1.2.0, - any.mmorph ==1.2.0, - any.monad-control ==1.0.3.1, - any.monad-loops ==0.4.3, - monad-loops +base4, - any.mono-traversable ==1.0.21.0, - any.mtl ==2.2.2, - any.network ==3.2.7.0, - network -devel, - any.network-byte-order ==0.1.7, - any.network-control ==0.1.4, - any.network-uri ==2.6.4.2, - any.numeric-limits ==0.1.0.0, - any.old-locale ==1.0.0.7, - any.old-time ==1.1.0.4, - any.openapi3 ==3.2.4, - any.optics-core ==0.4.1.1, - optics-core -explicit-generic-labels, - any.optics-extra ==0.4.2.1, - any.optics-th ==0.4.1, - any.optparse-applicative ==0.18.1.0, - optparse-applicative +process, - any.os-string ==2.0.7, - any.parallel ==3.2.2.0, - any.parsec ==3.1.15.0, - any.pem ==0.2.4, - any.pretty ==1.1.3.6, - any.prettyprinter ==1.7.1, - prettyprinter -buildreadme +text, - any.prettyprinter-ansi-terminal ==1.1.3, - any.primitive ==0.8.0.0, - any.process ==1.6.16.0, - any.profunctors ==5.6.2, - any.psqueues ==0.2.8.1, - any.quickcheck-io ==0.2.0, - any.random ==1.2.1.3, - any.recv ==0.1.0, - any.reflection ==2.1.9, - reflection -slow +template-haskell, - any.regex-base ==0.94.0.3, - any.regex-pcre-builtin ==0.95.2.3.8.44, - any.regex-tdfa ==1.3.2.3, - regex-tdfa +doctest -force-o2, - any.resourcet ==1.3.0, - any.rts ==1.0.2, - any.safe ==0.3.21, - any.scientific ==0.3.7.0, - scientific -bytestring-builder -integer-simple, - any.semialign ==1.3.1, - semialign +semigroupoids, - any.semigroupoids ==6.0.1, - semigroupoids +comonad +containers +contravariant +distributive +tagged +unordered-containers, - any.semigroups ==0.20, - semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers, - any.servant ==0.20.2, - any.servant-checked-exceptions ==2.2.0.1, - servant-checked-exceptions -buildexample, - any.servant-checked-exceptions-core ==2.2.0.1, - servant-checked-exceptions-core -buildexample, - any.servant-client ==0.20.2, - any.servant-client-core ==0.20.2, - any.servant-docs ==0.13.1, - any.servant-openapi3 ==2.0.1.6, - any.servant-server ==0.20.2, - any.simple-sendfile ==0.2.32, - simple-sendfile +allow-bsd -fallback, - any.singleton-bool ==0.1.8, - any.smallcheck ==1.2.1.1, - any.some ==1.0.6, - some +newtype-unsafe, - any.sop-core ==0.5.0.2, - any.split ==0.2.5, - any.splitmix ==0.1.1, - splitmix -optimised-mixer, - any.stm ==2.5.1.0, - any.streaming-commons ==0.2.3.0, - streaming-commons -use-bytestring-builder, - any.strict ==0.5, - any.string-conversions ==0.4.0.1, - any.swagger2 ==2.8.9, - any.tabular ==0.2.2.8, - any.tagged ==0.8.9, - tagged +deepseq +transformers, - any.tasty ==1.5.3, - tasty +unix, - any.tasty-golden ==2.3.5, - tasty-golden -build-example, - any.tasty-hspec ==1.2.0.4, - any.tasty-hunit ==0.10.2, - any.tasty-quickcheck ==0.11.1, - any.tasty-smallcheck ==0.8.2, - any.template-haskell ==2.19.0.0, - any.temporary ==1.3, - any.text ==2.0.1, - any.text-short ==0.1.6, - text-short -asserts, - any.tf-random ==0.5, - any.th-abstraction ==0.5.0.0, - any.th-compat ==0.1.6, - any.these ==1.2.1, - any.time ==1.12.2, - any.time-compat ==1.9.8, - any.time-manager ==0.2.2, - any.transformers ==0.5.6.2, - any.transformers-base ==0.4.6, - transformers-base +orphaninstances, - any.transformers-compat ==0.7.2, - transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, - any.typed-process ==0.2.12.0, - any.universe-base ==1.1.4, - any.unix ==2.7.3, - any.unix-compat ==0.7.3, - any.unix-time ==0.4.16, - any.unliftio-core ==0.2.1.0, - any.unordered-containers ==0.2.20, - unordered-containers -debug, - any.utf8-string ==1.0.2, - any.uuid-types ==1.0.6, - any.vault ==0.3.1.5, - vault +useghc, - any.vector ==0.13.2.0, - vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-algorithms ==0.9.1.0, - vector-algorithms +bench +boundschecks -internalchecks -llvm -unsafechecks, - any.vector-stream ==0.1.0.1, - any.void ==0.7.3, - void -safe, - any.wai ==3.2.4, - any.wai-app-static ==3.1.9, - wai-app-static +crypton -print, - any.wai-cors ==0.2.7, - any.wai-extra ==3.1.17, - wai-extra -build-example, - any.wai-logger ==2.5.0, - any.warp ==3.4.7, - warp +allow-sendfilefd -network-bytestring -warp-debug +x509, - any.witherable ==0.4.2, - any.word8 ==0.1.3, - any.world-peace ==1.0.2.0, - any.yaml ==0.11.11.2, - yaml +no-examples +no-exe, - any.zlib ==0.7.1.0, - zlib -bundled-c-zlib +non-blocking-ffi -pkg-config -index-state: HEAD From 8e8531e9d8e806134ec6520336e91e7ebc013556 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 29 Mar 2025 23:59:35 +0800 Subject: [PATCH 12/53] remove Amount, convert to Balance --- src/AssetClass/AssetBase.hs | 8 ++++++-- src/Cashflow.hs | 2 +- src/CreditEnhancement.hs | 1 + src/InterestRate.hs | 1 + src/Lib.hs | 6 +++--- src/Types.hs | 2 +- src/Util.hs | 8 ++++---- 7 files changed, 17 insertions(+), 11 deletions(-) diff --git a/src/AssetClass/AssetBase.hs b/src/AssetClass/AssetBase.hs index 5eb7cb70..a746fc3a 100644 --- a/src/AssetClass/AssetBase.hs +++ b/src/AssetClass/AssetBase.hs @@ -26,6 +26,7 @@ import Data.OpenApi hiding (Server,contentType) import Types hiding (Current,startDate,originTerm) import Data.Ratio import Data.Proxy +import Data.Decimal import Util import qualified Data.Map as Map import qualified InterestRate as IR @@ -72,8 +73,8 @@ calcPmt bal rate periods | rate == 0.0 = divideBI bal periods r1 = num / den in mulBR (realToFrac bal) (toRational (rate' * r1)) -type InterestAmount = Amount -type PrincipalAmount = Amount +type InterestAmount = Balance +type PrincipalAmount = Balance calcAssetPrinInt :: AmortPlan -> Balance -> IRate -> Int -> Int -> (Balance,Int) -> (InterestAmount, PrincipalAmount) calcAssetPrinInt pt bal rate ot rt (amortBal, amortTerm) = @@ -326,6 +327,9 @@ instance ToSchema AmortRule instance ToSchema (Ratio Integer) where declareNamedSchema _ = NamedSchema Nothing <$> declareSchema (Proxy :: Proxy Double) +instance ToSchema (Decimal) where + declareNamedSchema _ = NamedSchema Nothing <$> declareSchema (Proxy :: Proxy Double) + instance ToSchema PrepayPenaltyType instance ToSchema (TsPoint Int) instance ToSchema Ts diff --git a/src/Cashflow.hs b/src/Cashflow.hs index ff2310d9..4e513605 100644 --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -58,7 +58,7 @@ import Control.Lens.TH debug = flip trace -type Delinquent = Centi +type Delinquent = Balance type Amounts = [Float] type Principals = [Principal] type Interests = [Interest] diff --git a/src/CreditEnhancement.hs b/src/CreditEnhancement.hs index 22dbb9b3..9a7dc9fc 100644 --- a/src/CreditEnhancement.hs +++ b/src/CreditEnhancement.hs @@ -31,6 +31,7 @@ import qualified Stmt as S import Debug.Trace import Lib (paySeqLiabilities) +import Data.Decimal debug = flip trace type LiquidityProviderName = String diff --git a/src/InterestRate.hs b/src/InterestRate.hs index 20df5606..47418a30 100644 --- a/src/InterestRate.hs +++ b/src/InterestRate.hs @@ -16,6 +16,7 @@ import Data.Maybe import Data.Fixed import GHC.Generics import DateUtil +import Data.Decimal import Types import Util diff --git a/src/Lib.hs b/src/Lib.hs index 48f4edf6..07c90b44 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -62,7 +62,7 @@ getIntervalFactors :: [Date] -> [Rate] getIntervalFactors ds = (\x -> toRational x / 365) <$> getIntervalDays ds -- `debug` ("Interval Days"++show(ds)) -- | -prorataFactors :: [Centi] -> Centi -> [Centi] +prorataFactors :: [Balance] -> Balance -> [Balance] prorataFactors bals amt = case s of 0.0 -> replicate (length bals) 0.0 @@ -82,7 +82,7 @@ prorataFactors bals amt = -- -paySeqLiabilities :: Amount -> [Balance] -> [(Amount,Balance)] +paySeqLiabilities :: Balance -> [Balance] -> [(Balance,Balance)] paySeqLiabilities startAmt liabilities = tail $ reverse $ foldl pay [(startAmt, 0)] liabilities where pay accum@((amt, _):xs) target = @@ -93,7 +93,7 @@ paySeqLiabilities startAmt liabilities = -- Input: 1000, [100,200,300] -> [100,200,300] -- Input: 100, [50,80] ->[50,50] -paySeqLiabilitiesAmt :: Amount -> [Balance] -> [Amount] +paySeqLiabilitiesAmt :: Balance -> [Balance] -> [Balance] paySeqLiabilitiesAmt startAmt funds = zipWith (-) funds remainBals -- map (\(a,b) -> (a-b)) $ zip funds remainBals diff --git a/src/Types.hs b/src/Types.hs index 854cd487..9fcb2ec0 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -118,7 +118,7 @@ type CumRecovery = Balance type AccruedInterest = Balance type PerFace = Micro -type WAL = Centi +type WAL = Balance type Duration = Micro type Convexity = Micro type Yield = Micro diff --git a/src/Util.hs b/src/Util.hs index 26b48c4c..cc4f1f97 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -40,10 +40,10 @@ import Data.Time (addDays) import Debug.Trace debug = flip trace -mulBR :: Balance -> Rate -> Centi +mulBR :: Balance -> Rate -> Balance mulBR b r = fromRational $ toRational b * r -mulBIR :: Balance -> IRate -> Centi +mulBIR :: Balance -> IRate -> Balance mulBIR b r = fromRational $ toRational b * toRational r mulIR :: Int -> Rational -> Rational @@ -389,7 +389,7 @@ payProRata d amt getDueAmt payFn tobePaidList in (paidList, remainAmt) -payInMap :: Date -> Amount -> (a->Balance) -> (Amount->a->a)-> [String] +payInMap :: Date -> Balance -> (a->Balance) -> (Balance->a->a)-> [String] -> HowToPay -> Map.Map String a -> Map.Map String a payInMap d amt getDueFn payFn objNames how inputMap = let @@ -435,7 +435,7 @@ lookupInMap = lookupAndUpdate id selectInMap :: (Show k, Ord k) => String -> [k] -> Map.Map k a -> Either String (Map.Map k a) selectInMap errMsg keys m - | S.isSubsetOf inputKs mapKs = Right $ (Map.filterWithKey (\k _ -> S.member k inputKs) m) + | S.isSubsetOf inputKs mapKs = Right $ Map.filterWithKey (\k _ -> S.member k inputKs) m | otherwise = Left $ errMsg++":Missing keys, valid range "++ show mapKs ++ "But got:" ++ show inputKs where inputKs = S.fromList keys From b56adf2404b595f21f7ed9eb59a88d06caa3ec63 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sun, 30 Mar 2025 12:49:49 +0800 Subject: [PATCH 13/53] License to 2025 --- LICENSE | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/LICENSE b/LICENSE index 53751237..093db61f 100644 --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Xiaoyu Zhang (always.zhang A_T gmail ) (c) 2022-2024 +Copyright Xiaoyu Zhang (always.zhang A_T gmail ) (c) 2022-2025 All rights reserved. From 2e77b8858a7045923af25279db9d364fafdea244 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sun, 30 Mar 2025 22:27:12 +0800 Subject: [PATCH 14/53] Using DL --- Hastructure.cabal | 4 ++ src/Deal.hs | 139 ++++++++++++++++++----------------------- src/Deal/DealAction.hs | 7 ++- src/Liability.hs | 4 +- src/Lib.hs | 4 +- src/Reports.hs | 9 +-- src/Waterfall.hs | 12 ---- test/UT/DealTest.hs | 3 +- 8 files changed, 80 insertions(+), 102 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 57bc3bdc..97bd2f99 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -106,6 +106,8 @@ library , wai , yaml , vector + , MissingH + , dlist -- , proto3-wire default-language: Haskell2010 @@ -232,4 +234,6 @@ test-suite Hastructure-test , wai , yaml , vector + , MissingH + , dlist default-language: Haskell2010 diff --git a/src/Deal.hs b/src/Deal.hs index 2a892514..94260f09 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -50,11 +50,12 @@ import Types import Revolving import Triggers -import qualified Data.Map as Map +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 @@ -78,6 +79,7 @@ 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)) @@ -322,8 +324,8 @@ queryTrigger t@TestDeal{ triggers = trgs } wt -- ^ 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], [ResultComponent]) -> Date -> TriggerEffect - -> Either String (TestDeal a, RunContext a, [ActionOnDate], [ResultComponent]) +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 @@ -339,10 +341,10 @@ runEffects (t@TestDeal{accounts = accMap, fees = feeMap ,status=st, bonds = bond TriggerEffects efs -> foldM (`runEffects` d) (t, rc, actions, logs) efs RunActions wActions -> do - (newT, newRc, newLogs) <- foldM (performActionWrap d) (t, rc, []) wActions - return (newT, newRc, actions, logs++newLogs) + (newT, newRc, newLogs) <- foldM (performActionWrap d) (t, rc, DL.empty) wActions + return (newT, newRc, actions, DL.append logs newLogs) - DoNothing -> Right (t, rc, actions, []) + 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 @@ -356,14 +358,14 @@ runTriggers (t@TestDeal{status=oldStatus, triggers = Just trgM},rc, actions) d d 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,[]) triggeredEffects + (newDeal, newRc, newActions, logsFromTrigger) <- foldM (`runEffects` d) (t,rc,actions, DL.empty) triggeredEffects let newStatus = status newDeal let newLogs = [DealStatusChangeTo d oldStatus newStatus "By trigger"| newStatus /= oldStatus] -- `debug` (">>"++show d++"trigger : new st"++ show newStatus++"old st"++show oldStatus) let newTriggers = Map.union triggeredTrgs trgsMap return (newDeal {triggers = Just (Map.insert dcycle newTriggers trgM)} , newRc , newActions - , newLogs++logsFromTrigger) -- `debug` ("New logs from trigger"++ show d ++">>>"++show newLogs) + , newLogs++ DL.toList logsFromTrigger) -- `debug` ("New logs from trigger"++ show d ++">>>"++show newLogs) changeDealStatus:: Ast.Asset a => (Date,String)-> DealStatus -> TestDeal a -> (Maybe ResultComponent, TestDeal a) @@ -371,30 +373,14 @@ changeDealStatus:: Ast.Asset a => (Date,String)-> DealStatus -> TestDeal a -> (M changeDealStatus _ _ t@TestDeal{status=Ended} = (Nothing, t) changeDealStatus (d,why) newSt t@TestDeal{status=oldSt} = (Just (DealStatusChangeTo d oldSt newSt why), t {status=newSt}) --- runWaterfall :: Ast.Asset a => (TestDeal a ,Date, Runcontext a ,[ResultComponent]) -> String -> Either String (TestDeal a, RunContext a,[ResultComponent]) --- runWaterfall (t,d, runContext,logs) waterfallKey = --- let --- -- attach waterfall log --- --- -- accure interest for all bonds --- -- accure fees --- -- accure any hedge & liq support --- --- -- run waterfall --- (newDeal, newRc, newLogs) = foldl' (performActionWrap d) (t,runContext,[]) (Map.findWithDefault [] W.DefaultDistribution (waterfall t)) --- in --- Right (newDeal, newRc, logs++newLogs) - --- let eopActionsLog = [ RunningWaterfall d W.EndOfPoolCollection | Map.member W.EndOfPoolCollection waterfallM ] -- `debug` ("new logs from trigger 1"++ show newLogs0) --- let waterfallToExe = Map.findWithDefault [] W.EndOfPoolCollection (waterfall t) -- `debug` ("new logs from trigger 1"++ show newLogs0) run :: Ast.Asset a => TestDeal a -> Map.Map PoolId CF.CashFlowFrame -> Maybe [ActionOnDate] -> Maybe [RateAssumption] -> Maybe ([Pre],[Pre]) - -> Maybe (Map.Map String (RevolvingPool,AP.ApplyAssumptionType))-> [ResultComponent] -> Either String (TestDeal a,[ResultComponent]) -run t@TestDeal{status=Ended} pCfM ads _ _ _ log = Right (prepareDeal t,log++[EndRun Nothing "By Status:Ended"]) -run t pCfM (Just []) _ _ _ log = Right (prepareDeal t,log++[EndRun Nothing "No Actions"]) -run t pCfM (Just [HitStatedMaturity d]) _ _ _ log = Right (prepareDeal t,log++[EndRun (Just d) "Stop: Stated Maturity"]) -run t pCfM (Just (StopRunFlag d:_)) _ _ _ log = Right (prepareDeal t,log++[EndRun (Just d) "Stop Run Flag"]) + -> Maybe (Map.Map String (RevolvingPool,AP.ApplyAssumptionType))-> DL.DList ResultComponent -> Either String (TestDeal a,DL.DList ResultComponent) +run t@TestDeal{status=Ended} pCfM ads _ _ _ log = Right (prepareDeal t,(DL.snoc log (EndRun Nothing "By Status:Ended"))) +run t pCfM (Just []) _ _ _ log = Right (prepareDeal t,(DL.snoc log (EndRun Nothing "No Actions"))) +run t pCfM (Just [HitStatedMaturity d]) _ _ _ log = Right (prepareDeal t, (DL.snoc log (EndRun (Just d) "Stop: Stated Maturity"))) +run t pCfM (Just (StopRunFlag d:_)) _ _ _ log = Right (prepareDeal t, (DL.snoc log (EndRun (Just d) "Stop Run Flag"))) run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status=dStatus ,waterfall=waterfallM,name=dealName,pool=pt,stats=_stat} poolFlowMap (Just (ad:ads)) rates calls rAssump log @@ -402,7 +388,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= = do let runContext = RunContext poolFlowMap rAssump rates (finalDeal,_,newLogs) <- foldM (performActionWrap (getDate ad)) (t,runContext,log) cleanUpActions - return (prepareDeal finalDeal,newLogs++[EndRun (Just (getDate ad)) "No Pool Cashflow/All Account is zero/Not revolving"]) -- `debug` ("End of pool collection with logs with length "++ show (length log)) + return (prepareDeal finalDeal, (DL.snoc newLogs (EndRun (Just (getDate ad)) "No Pool Cashflow/All Account is zero/Not revolving"))) -- `debug` ("End of pool collection with logs with length "++ show (length log)) | otherwise = case ad of @@ -423,8 +409,8 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= (Map.map (\mflow -> over CF.cashflowTxn (cutBy Exc Future d) <$> mflow)) dAfterDeposit let runContext = RunContext outstandingFlow rAssump rates -- `debug` ("PoolCollection: before rc >>"++ show d++">>>"++ show (pool dAfterDeposit)) - (dRunWithTrigger0, rc1,ads2, newLogs0) <- runTriggers (dealAfterUpdateScheduleFlow,runContext,ads) d EndCollection -- `debug` ("PoolCollection: after update schedule flow >>"++ show d++">>"++show (pool dealAfterUpdateScheduleFlow)) - let eopActionsLog = [ RunningWaterfall d W.EndOfPoolCollection | Map.member W.EndOfPoolCollection waterfallM ] -- `debug` ("new logs from trigger 1"++ show newLogs0) + (dRunWithTrigger0, rc1, ads2, newLogs0) <- runTriggers (dealAfterUpdateScheduleFlow,runContext,ads) d EndCollection -- `debug` ("PoolCollection: after update schedule flow >>"++ show d++">>"++show (pool dealAfterUpdateScheduleFlow)) + 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) @@ -434,11 +420,10 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= rates calls rAssump - (newLogs0++newLogs++ eopActionsLog ++newLogs1) -- `debug` ("PoolCollection: Pt 05>> "++ show d++">> context flow>> "++show (runPoolFlow rc3)) + (consolLogsFn [DL.fromList newLogs0,newLogs,eopActionsLog,DL.fromList newLogs1]) -- `debug` ("PoolCollection: Pt 05>> "++ show d++">> context flow>> "++show (runPoolFlow rc3)) else run t poolFlowMap (Just ads) rates calls rAssump log -- `debug` ("PoolCollection: hit zero pool length"++ show d++"pool"++ (show poolFlowMap)++"collected cf"++ show pt) - -- Default waterfall execution action from payFreq from deal dates RunWaterfall d "" -> let runContext = RunContext poolFlowMap rAssump rates @@ -463,7 +448,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= [DealStatusChangeTo d dStatus Called "Call by triggers before waterfall distribution", RunningWaterfall d W.CleanUp] (dealAfterCleanUp, rc_, newLogWaterfall_ ) <- foldM (performActionWrap d) (dRunWithTrigger0, rc1,log) cleanUpActions endingLogs <- Rpt.patchFinancialReports dealAfterCleanUp d newLogWaterfall_ - return (prepareDeal dealAfterCleanUp, endingLogs ++ logsBeforeDist ++newStLogs++[EndRun (Just d) "Clean Up"]) -- `debug` ("Called ! "++ show d) + return (prepareDeal dealAfterCleanUp, DL.append endingLogs (DL.fromList (logsBeforeDist ++newStLogs++[EndRun (Just d) "Clean Up"]))) -- `debug` ("Called ! "++ show d) else do (dAfterWaterfall, rc2, newLogsWaterfall) <- foldM (performActionWrap d) (dRunWithTrigger0,rc1,log) waterfallToExe -- `debug` ("In RunWaterfall Date"++show d++">>> status "++show (status dRunWithTrigger0)++"before run waterfall collected >>"++ show (pool dRunWithTrigger0)) @@ -474,23 +459,23 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= rates calls rAssump - (newLogsWaterfall++newLogs2++logsBeforeDist++[RunningWaterfall d waterfallKey]) -- `debug` ("In RunWaterfall Date"++show d++"after run waterfall 3>>"++ show (pool dRunWithTrigger1)++" status>>"++ show (status dRunWithTrigger1)) + (consolLogsFn [newLogsWaterfall,DL.fromList (newLogs2 ++ logsBeforeDist++[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 - waterfallToExe = Map.findWithDefault [] waterfallKey waterfallM in - do - -- (dRunWithTrigger0, rc1, ads1, newLogs0) <- runTriggers (t, runContext, ads) d BeginDistributionWF -- `debug` ("In RunWaterfall Date"++show d++"before run trigger>> collected"++ show (pool t)) + 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) - -- (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 dAfterWaterfall (runPoolFlow rc2) (Just ads) rates calls rAssump (newLogsWaterfall++logsBeforeDist++[RunningWaterfall d waterfallKey]) -- `debug` ("size of logs"++ show (length newLogsWaterfall)++ ">>"++ show d++ show (length logsBeforeDist)) - + run dAfterWaterfall (runPoolFlow rc2) (Just ads) rates calls rAssump + (consolLogsFn [newLogsWaterfall,DL.fromList (logsBeforeDist ++ [RunningWaterfall d waterfallKey])]) -- `debug` ("size of logs"++ show (length newLogsWaterfall)++ ">>"++ show d++ show (length logsBeforeDist)) EarnAccInt d accName -> let @@ -499,13 +484,13 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= run (t {accounts = newAcc}) poolFlowMap (Just ads) rates calls rAssump log AccrueFee d feeName -> - let - fToAcc = feeMap Map.! feeName - in - do - newF <- calcDueFee t d fToAcc - let newFeeMap = (Map.fromList [(feeName,newF)]) <> feeMap - run (t{fees=newFeeMap}) poolFlowMap (Just ads) rates calls rAssump log + 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 @@ -529,14 +514,15 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= let w = Map.findWithDefault [] W.OnClosingDay (waterfall t) rc = RunContext poolFlowMap rAssump rates - logForClosed = [RunningWaterfall d W.OnClosingDay| not (null w)] + 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 (newLog++[DealStatusChangeTo d (PreClosing newSt) newSt "By Deal Close"]++logForClosed) -- `debug` ("new st at closing"++ show newSt) + run newDeal{status=newSt} (runPoolFlow newRc) (Just ads) rates calls rAssump + (consolLogsFn [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 @@ -569,7 +555,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= newRsMap = Just $ Map.adjust (HE.payoutIRS d accBal) sn rSwap in run (t{accounts = newAcc, rateSwap = newRsMap}) poolFlowMap (Just ads) rates calls rAssump - $ log ++ [WarningMsg $ "Settle Rate Swap Error: "++ show d ++" Insufficient balance to settle "++ sn] + $ 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 @@ -598,7 +584,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= InspectDS d dss -> do newlog <- inspectListVars t d dss - run t poolFlowMap (Just ads) rates calls rAssump $ log++newlog -- `debug` ("Add log"++show newlog) + run t poolFlowMap (Just ads) rates calls rAssump $ DL.append log (DL.fromList newlog) -- `debug` ("Add log"++show newlog) ResetBondRate d bn -> let @@ -634,34 +620,31 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= cashReport = Rpt.buildCashReport t sd ed in do - bsReport <- Rpt.buildBalanceSheet t ed -- `debug` ("bs report"++ show ed) + bsReport <- Rpt.buildBalanceSheet t ed let newlog = FinancialReport sd ed bsReport cashReport - run t poolFlowMap (Just ads) rates calls rAssump $ log++[newlog] -- `debug` ("new log"++ show ed++ show newlog) + 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 = case mTrgMap of - Nothing -> Nothing - Just tm -> case Map.lookup cyc tm of - Nothing -> Nothing - Just cycM -> case Map.lookup n cycM of - Nothing -> Nothing - Just trg -> Just $ trgEffects trg + 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, []) -- `debug` "Nothing found on effects" - Just efs -> runEffects (t, runContext, ads, []) d efs + 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 = [DealStatusChangeTo d oldStatus newStatus "by Manual fireTrigger" | oldStatus /= newStatus] - let newLog = WarningMsg $ "Trigger Overrided to True "++ show(d,cyc,n) - run newT {triggers = Just triggerFired} newPool (Just ads) rates calls rAssump $ log++[newLog]++stChangeLogs++newLogsFromTrigger + let stChangeLogs = DL.fromList [DealStatusChangeTo d oldStatus newStatus "by Manual fireTrigger" | oldStatus /= newStatus] + run newT {triggers = Just triggerFired} newPool (Just ads) rates calls rAssump $ consolLogsFn [log,stChangeLogs,newLogsFromTrigger] MakeWhole d spd walTbl -> let @@ -693,7 +676,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= L.payYield d intToPay bnd1) (bonds t) bondPricingResult - run t {bonds = depositBondFlow, status = Ended } poolFlowMap (Just []) rates calls rAssump $ log++[EndRun (Just d) "MakeWhole call"] + run t {bonds = depositBondFlow, status = Ended } poolFlowMap (Just []) rates calls rAssump $ DL.snoc log (EndRun (Just d) "MakeWhole call") FundBond d Nothing bName accName fundAmt -> let @@ -711,7 +694,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= do flag <- testPre d t p case flag of - False -> run t poolFlowMap (Just ads) rates calls rAssump (log ++ [WarningMsg ("Failed to fund bond"++ bName++ ":" ++show p)]) + 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 @@ -726,7 +709,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= do flag <- testPre d t p case flag of - False -> run t poolFlowMap (Just ads) rates calls rAssump (log ++ [WarningMsg ("Failed to issue to bond group"++ bGroupName++ ":" ++show p)]) + 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 @@ -783,7 +766,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= let newAds = sortBy sortActionOnDate $ filteredAds ++ bResetActions run t{bonds = newBndMap, accounts = newAccMap} poolFlowMap (Just newAds) rates calls rAssump log - RefiBond d accName bnd -> undefined + RefiBond d accName bnd -> Left "Undefined action: RefiBond" TestCall d -> let @@ -796,19 +779,20 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= let runContext = RunContext poolFlowMap rAssump rates newStLogs = if null cleanUpActions then - [DealStatusChangeTo d dStatus Called "by Date-Based Call"] + DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call"] else - [DealStatusChangeTo d dStatus Called "by Date-Based Call", RunningWaterfall d W.CleanUp] + 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 (prepareDeal dealAfterCleanUp, endingLogs ++ newStLogs++[EndRun (Just d) "Clean Up"]) -- `debug` ("Called ! "++ show d) + return (prepareDeal dealAfterCleanUp, DL.snoc (endingLogs `DL.append` newStLogs) (EndRun (Just d) "Clean Up")) -- `debug` ("Called ! "++ show d) _ -> run t poolFlowMap (Just ads) rates calls rAssump log _ -> Left $ "Failed to match action on Date"++ show ad where + consolLogsFn = foldl1 DL.append cleanUpActions = Map.findWithDefault [] W.CleanUp (waterfall t) -- `debug` ("Running AD"++show(ad)) remainCollectionNum = Map.elems $ Map.map CF.sizeCashFlowFrame poolFlowMap futureCashToCollect = Map.elems $ Map.map (\pcf -> sum (CF.tsTotalCash <$> view CF.cashflowTxn pcf)) poolFlowMap @@ -819,7 +803,7 @@ run t empty Nothing Nothing Nothing Nothing log (t, ads, pcf, unStressPcf) <- getInits 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 (prepareDeal t,log) -- `debug` ("End with pool CF is []") +run t empty _ _ _ _ log = Right (prepareDeal t, log) -- `debug` ("End with pool CF is []") @@ -921,7 +905,6 @@ priceBondIrr (AP.BuyBond dateToBuy bPricingMethod (AP.ByCash cash) Nothing) txns (bProjectedTxn',futureFlow') = splitByDate txns dateToBuy EqToLeft --- TODO : need to lift the result and make function Either String xxx 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) @@ -997,13 +980,13 @@ runDeal t _ perfAssumps nonPerfAssumps@AP.NonPerfAssumption{AP.callWhen = opts , mInterest (readCallOptions <$> opts) mRevolvingCtx - [] + DL.empty let poolFlowUsed = Map.map (fromMaybe (CF.CashFlowFrame (0,toDate "19000101",Nothing) [])) (getAllCollectedFrame finalDeal Nothing) let poolFlowUsedNoEmpty = Map.map (over CF.cashflowTxn CF.dropTailEmptyTxns) poolFlowUsed bndPricing <- case mPricing of (Just p) -> priceBonds finalDeal p Nothing -> Right Map.empty - return (finalDeal, Just poolFlowUsedNoEmpty, Just (getRunResult finalDeal ++ V.validateRun finalDeal ++logs), bndPricing) -- `debug` ("Run Deal end with") + return (finalDeal, Just poolFlowUsedNoEmpty, Just (getRunResult finalDeal ++ V.validateRun finalDeal ++ DL.toList logs), bndPricing) -- `debug` ("Run Deal end with") where (runFlag, valLogs) = V.validateReq t nonPerfAssumps -- getinits() will get (new deal snapshot, actions, pool cashflows, unstressed pool cashflow) diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index b6db9de5..06f0104d 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -49,6 +49,7 @@ 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 @@ -518,8 +519,8 @@ updateSupport :: Ast.Asset a => Date -> Maybe W.ExtraSupport -> Balance -> TestD 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, [ResultComponent]) - -> W.Action -> Either String (TestDeal a, RunContext a, [ResultComponent]) +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) @@ -661,7 +662,7 @@ performActionWrap d performActionWrap d (t, rc, logs) (W.WatchVal ms dss) - = (inspectListVars t d dss) >>= (\vs -> Right (t, rc, logs ++ [InspectWaterfall d ms dss (showInspection <$> vs)])) + = (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) diff --git a/src/Liability.hs b/src/Liability.hs index 88b942ae..5c205877 100644 --- a/src/Liability.hs +++ b/src/Liability.hs @@ -563,9 +563,9 @@ tryCalcZspread tradePrice originBalance priceDay futureCfs riskFreeCurve spread pvCurve = shiftTsByAmt riskFreeCurve (fromRational (toRational spread)) pvs = [ pv pvCurve priceDay _d _amt | (_d, _amt) <- futureCfs ] newPrice = 100 * sum pvs - faceVal = fromRational $ divideBB newPrice originBalance + faceVal = divideBB newPrice originBalance in - faceVal - fromRational tradePrice + fromRational (faceVal - tradePrice) calcZspread :: (Rational,Date) -> Bond -> Ts -> Either String Spread diff --git a/src/Lib.hs b/src/Lib.hs index 07c90b44..e04799c2 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -68,7 +68,7 @@ prorataFactors bals amt = 0.0 -> replicate (length bals) 0.0 _ -> let weights = map (\x -> toRational x / s) bals -- `debug` ("bals"++show bals++">>s>>"++show s++"amt to pay"++show amtToPay) - outPut = (\y -> fromRational (y * toRational amtToPay)) <$> weights -- `debug` ("Weights->>"++ show weights) + outPut = (\y -> fromRational (y * amtToPay)) <$> weights -- `debug` ("Weights->>"++ show weights) eps = amt - sum outPut in if eps == 0.00 then @@ -78,7 +78,7 @@ prorataFactors bals amt = where s = toRational $ sum bals - amtToPay = min s (toRational amt) + amtToPay = toRational $ min s (toRational amt) -- diff --git a/src/Reports.hs b/src/Reports.hs index 00949a5a..349c67f0 100644 --- a/src/Reports.hs +++ b/src/Reports.hs @@ -9,6 +9,7 @@ module Reports (patchFinancialReports,getItemBalance,buildBalanceSheet,buildCash ) where import Data.List ( find, sort ) +import qualified Data.DList as DL import qualified Asset as P import qualified Data.Map as Map import qualified Cashflow as CF @@ -36,10 +37,10 @@ import Stmt FlowDirection(Outflow, Inflow) ) -- ^ add financial report to the logs -patchFinancialReports :: P.Asset a => TestDeal a -> Date -> [ResultComponent] -> Either String [ResultComponent] -patchFinancialReports t d [] = Right [] +patchFinancialReports :: P.Asset a => TestDeal a -> Date -> DL.DList ResultComponent -> Either String (DL.DList ResultComponent) +-- patchFinancialReports t d DL.empty = return (DL.empty) patchFinancialReports t d logs - = case (find pickReportLog (reverse logs)) of + = case (find pickReportLog (reverse (DL.toList logs))) of Nothing -> Right logs Just (FinancialReport sd ed bs cash) -> let @@ -48,7 +49,7 @@ patchFinancialReports t d logs do bsReport <- buildBalanceSheet t d let newlog = FinancialReport ed d bsReport cashReport - return (logs++[newlog]) + return (DL.snoc logs newlog) where pickReportLog FinancialReport {} = True pickReportLog _ = False diff --git a/src/Waterfall.hs b/src/Waterfall.hs index 3d0f4b62..356a8302 100644 --- a/src/Waterfall.hs +++ b/src/Waterfall.hs @@ -56,17 +56,6 @@ type BookLedger = (BookDirection, LedgerName) type BookLedgers = (BookDirection, [LedgerName]) --- data ActionTag = Pay --- | TransferTo --- | Accrue --- | WriteOffTo --- | Receive --- | Settle --- | Buy --- | Sell - - - data Action = -- Accounts Transfer (Maybe Limit) AccountName AccountName (Maybe TxnComment) @@ -91,7 +80,6 @@ data Action = | PayIntResidual (Maybe Limit) AccountName BondName -- ^ pay interest to bond regardless interest due | PayIntByRateIndex (Maybe Limit) AccountName [BondName] Int (Maybe ExtraSupport) -- ^ pay interest to bond by index | PayIntByRateIndexBySeq (Maybe Limit) AccountName [BondName] Int (Maybe ExtraSupport) -- ^ pay interest to bond by index - -- | PayTillYield AccountName [BondName] -- Bond - Principal | CalcBondPrin (Maybe Limit) AccountName [BondName] (Maybe ExtraSupport) -- ^ calculate principal due amount in the bond names | CalcBondPrin2 (Maybe Limit) [BondName] -- ^ calculate principal due amount in the bond names diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index 4667e090..b357cdb0 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -23,6 +23,7 @@ import qualified Call as C import InterestRate import qualified CreditEnhancement as CE import qualified Triggers as Trg +import qualified Data.DList as DL import Lib import Types @@ -325,7 +326,7 @@ triggerTests = testGroup "Trigger Tests" ,RunWaterfall (toDate "20220625") "" ,PoolCollection (toDate "20220701")"" ,RunWaterfall (toDate "20220725") "" ] - (fdeal,_) = case run td2 poolflowM (Just ads) Nothing Nothing Nothing [] of + (fdeal,_) = case run td2 poolflowM (Just ads) Nothing Nothing Nothing DL.empty of Left _ -> error "" Right x -> x in From 1cc8b56a8b6247134bab23cf4a4f416cf3b05d03 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Mon, 31 Mar 2025 17:59:52 +0800 Subject: [PATCH 15/53] Opt with DList on Mortgage --- src/AssetClass/Mortgage.hs | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/src/AssetClass/Mortgage.hs b/src/AssetClass/Mortgage.hs index 696840ba..e3202f56 100644 --- a/src/AssetClass/Mortgage.hs +++ b/src/AssetClass/Mortgage.hs @@ -35,18 +35,20 @@ import GHC.Float.RealFracMethods (truncateFloatInteger) import Cashflow (extendTxns) import Control.Lens hiding (element) import Control.Lens.TH +import qualified Data.DList as DL + debug = flip trace -projectMortgageFlow :: (Balance, Balance, Date, Maybe BorrowerNum, AmortPlan, DayCount, IRate, Period, Int) -> (Dates, [DefaultRate],[PrepaymentRate],[IRate],[Int]) -> ([CF.TsRow], Balance) +projectMortgageFlow :: (Balance, Balance, Date, Maybe BorrowerNum, AmortPlan, DayCount, IRate, Period, Int) -> (Dates, [DefaultRate],[PrepaymentRate],[IRate],[Int]) -> (DL.DList CF.TsRow, Balance, Balance) projectMortgageFlow (originBal, startBal, lastPayDate, mbn, pt, dc, startRate, p, oTerms) (cfDates, defRates, ppyRates, rateVector, remainTerms) = let initRow = CF.MortgageFlow lastPayDate startBal 0.0 0.0 0.0 0.0 0.0 0.0 startRate Nothing Nothing Nothing in foldl - (\(acc,lastOriginBal) (pDate, defRate, ppyRate, intRate, rt) + (\(acc, begBal, lastOriginBal) (pDate, defRate, ppyRate, intRate, rt) -> let - begBal = view CF.tsRowBalance (last acc) - lastPaidDate = getDate (last acc) -- `debug` ("beg bal"++ show begBal) + -- begBal = view CF.tsRowBalance (last acc) + -- lastPaidDate = getDate (last acc) -- `debug` ("beg bal"++ show begBal) newDefault = mulBR begBal defRate -- `debug` ("new default"++ show defRate++ ">>"++ show begBal) newPrepay = mulBR (begBal - newDefault) ppyRate -- performing balance @@ -61,9 +63,9 @@ projectMortgageFlow (originBal, startBal, lastPayDate, mbn, pt, dc, startRate, p endBal = _balAfterPpy - newPrin newMbn = decreaseBorrowerNum begBal endBal mbn -- `debug` ("rt in mortgage proj"++ show rt) in - (acc <> [CF.MortgageFlow pDate endBal newPrin newInt newPrepay newDefault 0.0 0.0 intRate newMbn Nothing Nothing], amortBal) + (DL.snoc acc (CF.MortgageFlow pDate endBal newPrin newInt newPrepay newDefault 0.0 0.0 intRate newMbn Nothing Nothing), endBal ,amortBal) ) - ([initRow], originBal) + (DL.singleton initRow, startBal, originBal) (zip5 cfDates defRates ppyRates rateVector remainTerms) @@ -307,7 +309,9 @@ buildARMrates or@(IR.Floater _ idx sprd initRate dp _ _ mRoundBy ) instance Ast.Asset Mortgage where calcCashflow m@(Mortgage (MortgageOriginalInfo ob or ot p sd ptype _ _) _bal _rate _term _mbn _) d mRates - = fst <$> (projCashflow m d (MortgageAssump Nothing Nothing Nothing Nothing,A.DummyDelinqAssump,A.DummyDefaultAssump) mRates) + = fst <$> (projCashflow m d (MortgageAssump Nothing Nothing Nothing Nothing + ,A.DummyDelinqAssump + ,A.DummyDefaultAssump) mRates) calcCashflow s@(ScheduleMortgageFlow beg_date flows _) d _ = Right $ CF.CashFlowFrame ( ((view CF.tsRowBalance) . head) flows, beg_date, Nothing ) flows @@ -468,10 +472,10 @@ instance Ast.Asset Mortgage where rateVector <- A.projRates cr or mRates cfDates defRates <- Ast.buildDefaultRates m (lastPayDate:cfDates) amd ppyRates <- Ast.buildPrepayRates m (lastPayDate:cfDates) amp - let (txns,_) = projectMortgageFlow + let (txns',_,_) = projectMortgageFlow (ob, cb,lastPayDate,mbn,prinPayType,dc,cr,p,ot) (cfDates, defRates, ppyRates,rateVector,remainTerms) - + let txns = DL.toList txns' let lastProjTxn = last txns let extraTxns = [ CF.emptyTsRow d lastProjTxn | d <- recoveryDates ] @@ -546,8 +550,8 @@ instance Ast.Asset Mortgage where do (ppyRates,defRates,recoveryRate,recoveryLag) <- buildAssumptionPpyDefRecRate m (lastPayDate:cfDates) (A.MortgageAssump amd amp amr ams) let remainTerms = reverse $ replicate recoveryLag 0 ++ [0..rt] - let (txns,_) = projectMortgageFlow (scheduleBalToday, cb,lastPayDate,mbn,prinPayType,dc,cr,p,ot) (cfDates, defRates, ppyRates,rateVector,remainTerms) - let (futureTxns,historyM)= CF.cutoffTrs asOfDay (patchLossRecovery txns amr) + let (txns,_,_) = projectMortgageFlow (scheduleBalToday, cb,lastPayDate,mbn,prinPayType,dc,cr,p,ot) (cfDates, defRates, ppyRates,rateVector,remainTerms) + let (futureTxns,historyM)= CF.cutoffTrs asOfDay (patchLossRecovery (DL.toList txns) amr) let begBal = CF.buildBegBal futureTxns return $ (applyHaircut ams $ patchPrepayPenaltyFlow (ot,mpn) (CF.CashFlowFrame (begBal,asOfDay,Nothing) futureTxns) ,historyM) From 92d27c95cdc0d8437ee8d862663334e520c9ab89 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Mon, 31 Mar 2025 18:31:24 +0800 Subject: [PATCH 16/53] expose DL to Installment --- src/AssetClass/Installment.hs | 16 +++++++++------- 1 file changed, 9 insertions(+), 7 deletions(-) diff --git a/src/AssetClass/Installment.hs b/src/AssetClass/Installment.hs index 52ab6856..48bea4f6 100644 --- a/src/AssetClass/Installment.hs +++ b/src/AssetClass/Installment.hs @@ -13,6 +13,7 @@ import Data.Aeson hiding (json) import Language.Haskell.TH import Data.Maybe import Data.List +import qualified Data.DList as DL import Data.Aeson.TH import qualified Data.Map as Map import Data.Aeson.Types @@ -37,7 +38,7 @@ import Control.Lens.TH debug = flip trace -projectInstallmentFlow :: (Balance,Date,(Balance,Balance),IRate,Rational,AmortPlan,Int) -> (Dates, [DefaultRate], [PrepaymentRate], [Int]) -> ([CF.TsRow],Rational) +projectInstallmentFlow :: (Balance,Date,(Balance,Balance),IRate,Rational,AmortPlan,Int) -> (Dates, [DefaultRate], [PrepaymentRate], [Int]) -> (DL.DList CF.TsRow, Balance ,Rational) projectInstallmentFlow (startBal, lastPaidDate, (originRepay,originInt), startRate,begFactor,pt,ot) (cfDates, defRates, ppyRates, remainTerms) = let initRow = CF.LoanFlow lastPaidDate startBal 0.0 0.0 0.0 0.0 0.0 0.0 startRate Nothing @@ -47,9 +48,9 @@ projectInstallmentFlow (startBal, lastPaidDate, (originRepay,originInt), startRa _ -> mulBR _opmt _factor in foldl - (\(acc,factor) (pDate, ppyRate, defRate, rt) -> + (\(acc,begBal,factor) (pDate, ppyRate, defRate, rt) -> let - begBal = view CF.tsRowBalance (last acc) + -- begBal = view CF.tsRowBalance (last acc) newDefault = mulBR begBal defRate newPrepay = mulBR (begBal - newDefault) ppyRate intBal = begBal - newDefault - newPrepay @@ -66,9 +67,10 @@ projectInstallmentFlow (startBal, lastPaidDate, (originRepay,originInt), startRa newPrin = calcPrin rt intBal originRepay newFactor endBal = intBal - newPrin in - (acc ++ [CF.LoanFlow pDate endBal newPrin newInt newPrepay newDefault 0.0 0.0 startRate Nothing] + (DL.snoc acc (CF.LoanFlow pDate endBal newPrin newInt newPrepay newDefault 0.0 0.0 startRate Nothing) + ,endBal ,newFactor)) - ([initRow], begFactor) + (DL.singleton initRow, startBal, begFactor) (zip4 cfDates ppyRates defRates remainTerms) @@ -150,8 +152,8 @@ instance Asset Installment where do ppyRates <- Ast.buildPrepayRates inst (lastPayDate:cfDates) prepayAssump defRates <- Ast.buildDefaultRates inst (lastPayDate:cfDates) defaultAssump - let (txns,_) = projectInstallmentFlow (cb,lastPayDate,(opmt,ofee),orate,currentFactor,pt,ot) (cfDates,defRates,ppyRates,remainTerms) - let (futureTxns,historyM) = CF.cutoffTrs asOfDay (patchLossRecovery txns recoveryAssump) + let (txns,_,_) = projectInstallmentFlow (cb,lastPayDate,(opmt,ofee),orate,currentFactor,pt,ot) (cfDates,defRates,ppyRates,remainTerms) + let (futureTxns,historyM) = CF.cutoffTrs asOfDay (patchLossRecovery (DL.toList txns) recoveryAssump) let begBal = CF.buildBegBal futureTxns return $ (applyHaircut ams (CF.CashFlowFrame (begBal,asOfDay,Nothing) futureTxns), historyM) From 2db1ccd274cae69cfb56fde97689588f9373daef Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 02:21:37 +0800 Subject: [PATCH 17/53] DList to Stmt --- Hastructure.cabal | 1 + app/MainBase.hs | 13 ++++++++++++- src/Accounts.hs | 5 +++-- src/CreditEnhancement.hs | 25 +++++++++++++------------ src/Deal.hs | 2 +- src/Deal/DealBase.hs | 6 ++++-- src/Deal/DealQuery.hs | 15 ++++++++------- src/Expense.hs | 3 ++- src/Hedge.hs | 5 +++-- src/Ledger.hs | 3 ++- src/Liability.hs | 36 +++++++++++++++++++++--------------- src/Reports.hs | 2 +- src/Stmt.hs | 15 +++++++++------ src/Types.hs | 2 ++ 14 files changed, 82 insertions(+), 51 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 97bd2f99..46c25fa0 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -164,6 +164,7 @@ executable Hastructure-exe , wai-cors , warp , yaml + , dlist -- , proto3-suite default-language: Haskell2010 diff --git a/app/MainBase.hs b/app/MainBase.hs index b3fda139..05067658 100644 --- a/app/MainBase.hs +++ b/app/MainBase.hs @@ -35,6 +35,7 @@ import Data.Aeson.Encode.Pretty (encodePretty) import Data.Attoparsec.ByteString import Data.ByteString (ByteString) import Data.List +import qualified Data.DList as DL import Data.Map import Data.Proxy import qualified Data.Text as T @@ -247,8 +248,18 @@ instance ToSchema TRG.TriggerEffect instance ToSchema Types.BalanceSheetReport instance ToSchema Types.CashflowReport instance ToSchema Types.BookItem -instance ToSchema Stmt.Statement +-- instance ToSchema a => ToSchema (DL.DList a) instance ToSchema Types.Txn + +-- instance ToSchema (DL.DList Types.Txn) where +-- declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [Types.Txn]) + +-- instance ToSchema (Generic (DL.DList Types.Txn)) +-- instance ToSchema (DL.DList Types.Txn) +instance ToSchema a => ToSchema (DL.DList a) where + declareNamedSchema _ = declareNamedSchema (Proxy :: Proxy [a]) + +instance ToSchema Stmt.Statement instance ToSchema AB.AssociateExp instance ToSchema AB.AssociateIncome instance ToSchema RV.RevolvingPool diff --git a/src/Accounts.hs b/src/Accounts.hs index 18550f41..daa7e740 100644 --- a/src/Accounts.hs +++ b/src/Accounts.hs @@ -23,6 +23,7 @@ import GHC.Generics import Control.Lens.Tuple import Control.Lens hiding (Index) import qualified InterestRate as IR +import qualified Data.DList as DL -- import Web.Hyperbole @@ -69,7 +70,7 @@ accrueInt endDate a@(Account bal _ (Just interestType) _ stmt) Nothing -> mulBR (mulBI bal rateToUse) (yearCountFraction defaultDc lastDay endDate) -- `debug` (">>"++show lastCollectDate++">>"++show ed) Just (Statement txns) -> let - accrueTxns = sliceBy IE lastDay endDate txns + accrueTxns = sliceBy IE lastDay endDate (DL.toList txns) bals = map getTxnBegBalance accrueTxns ++ [bal] ds = [lastDay] ++ getDates accrueTxns ++ [endDate] avgBal = calcWeightBalanceByDates defaultDc bals ds @@ -129,7 +130,7 @@ tryDraw amt d tc acc@(Account bal _ _ _ maybeStmt) instance QueryByComment Account where queryStmt (Account _ _ _ _ Nothing) tc = [] - queryStmt (Account _ _ _ _ (Just (Statement txns))) tc = filter (\x -> getTxnComment x == tc) txns + queryStmt (Account _ _ _ _ (Just (Statement txns))) tc = filter (\x -> getTxnComment x == tc) (DL.toList txns) -- InvestmentAccount Types.Index Spread DatePattern DatePattern Date IRate diff --git a/src/CreditEnhancement.hs b/src/CreditEnhancement.hs index 9a7dc9fc..0aaab076 100644 --- a/src/CreditEnhancement.hs +++ b/src/CreditEnhancement.hs @@ -14,6 +14,7 @@ module CreditEnhancement import qualified Data.Text as T import qualified Data.Time as Time import qualified Data.Map as Map +import qualified Data.DList as DL import GHC.Generics import Language.Haskell.TH import Data.Aeson hiding (json) @@ -90,14 +91,14 @@ data LiqFacility = LiqFacility { consolStmt :: LiqFacility -> LiqFacility consolStmt liq@LiqFacility{liqStmt = Nothing} = liq -consolStmt liq@LiqFacility{liqStmt = Just (S.Statement [])} = liq -consolStmt liq@LiqFacility{liqStmt = Just (S.Statement (txn:txns))} - = - let - combinedBondTxns = foldl S.consolTxn [txn] txns - droppedTxns = dropWhile S.isEmptyTxn combinedBondTxns - in - liq {liqStmt = Just (S.Statement (reverse droppedTxns))} +consolStmt liq@LiqFacility{liqStmt = Just (S.Statement txn')} + | DL.empty == txn' = liq + | otherwise = let + (txn:txns) = DL.toList txn' + combinedBondTxns = foldl S.consolTxn [txn] txns + droppedTxns = dropWhile S.isEmptyTxn combinedBondTxns + in + liq {liqStmt = Just (S.Statement (DL.fromList (reverse droppedTxns)))} -- | update the reset events of liquidity provider @@ -177,7 +178,7 @@ accrueLiqProvider d liq@(LiqFacility _ _ curBal mCredit _ mRateType mPRateType r = accrueLiqProvider d $ liq{liqStmt = Just defaultStmt} where -- insert begining record - defaultStmt = Statement [SupportTxn sd mCredit curBal dueInt duePremium 0 Empty] + defaultStmt = Statement $ DL.singleton $ SupportTxn sd mCredit curBal dueInt duePremium 0 Empty accrueLiqProvider d liq@(LiqFacility _ _ curBal mCredit mCreditType mRateType mPRateType rate prate dueDate dueInt duePremium sd mEd mStmt@(Just (Statement txns))) = liq { liqStmt = newStmt @@ -192,14 +193,14 @@ accrueLiqProvider d liq@(LiqFacility _ _ curBal mCredit mCreditType mRateType mP Nothing -> 0 Just r -> let - bals = weightAvgBalanceByDates [lastAccDate,d] txns + bals = weightAvgBalanceByDates [lastAccDate,d] (DL.toList txns) in sum $ flip mulBIR r <$> bals -- `debug` ("Accure Using Rate"++show r++"avg bal"++ show bals ++"ds"++show [lastAccDate,d]) accureFee = case prate of Nothing -> 0 Just r -> let - (_,_unAccTxns) = splitByDate txns lastAccDate EqToLeftKeepOne + (_,_unAccTxns) = splitByDate (DL.toList txns) lastAccDate EqToLeftKeepOne accBals = getUnusedBal <$> _unAccTxns _ds = lastAccDate : tail (getDate <$> _unAccTxns) _avgBal = calcWeightBalanceByDates DC_ACT_365F accBals (_ds++[d]) @@ -222,7 +223,7 @@ accrueLiqProvider d liq@(LiqFacility _ _ curBal mCredit mCreditType mRateType mP instance QueryByComment LiqFacility where queryStmt liq@LiqFacility{liqStmt = Nothing} tc = [] queryStmt liq@LiqFacility{liqStmt = (Just (Statement txns))} tc - = filter (\x -> getTxnComment x == tc) txns + = filter (\x -> getTxnComment x == tc) (DL.toList txns) instance Liable LiqFacility where diff --git a/src/Deal.hs b/src/Deal.hs index 94260f09..124d714a 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -1274,7 +1274,7 @@ runPoolType (ResecDeal dm) mAssumps mNonPerfAssump in do (dealRunned, _, _, _) <- runDeal uDeal DealPoolFlowPricing poolAssump dealAssump - let bondFlow = cutBy Inc Future sd $ concat $ Map.elems $ Map.map Stmt.getTxns $ getBondStmtByName dealRunned (Just [bn]) -- `debug` ("Bondflow from underlying runned"++ show (getBondStmtByName dealRunned (Just [bn]))) + let bondFlow = cutBy Inc Future sd $ concat $ Map.elems $ Map.map (DL.toList . Stmt.getTxns) $ getBondStmtByName dealRunned (Just [bn]) -- `debug` ("Bondflow from underlying runned"++ show (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 -- `debug` ("Bondflow from underlying"++ show bondFlow) return (CF.CashFlowFrame (0,sd,Nothing) bondFlowRated, Map.empty)) assumpMap diff --git a/src/Deal/DealBase.hs b/src/Deal/DealBase.hs index 76edc295..6b0ab338 100644 --- a/src/Deal/DealBase.hs +++ b/src/Deal/DealBase.hs @@ -41,6 +41,7 @@ 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 @@ -357,9 +358,10 @@ instance SPV (TestDeal a) where Nothing -> 0 Just bnd -> case L.bndStmt bnd of - Just (Statement []) -> L.getCurBalance bnd -- `debug` ("Getting beg bal"++bn++"Last smt"++show (head stmts)) - Just (Statement stmts) -> getTxnBegBalance $ head stmts -- `debug` ("Getting beg bal"++bn++"Last smt"++show (head stmts)) 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) diff --git a/src/Deal/DealQuery.hs b/src/Deal/DealQuery.hs index 6829a172..25bfad62 100644 --- a/src/Deal/DealQuery.hs +++ b/src/Deal/DealQuery.hs @@ -24,6 +24,7 @@ import qualified Data.Set as S import qualified Liability as L import qualified Cashflow as CF import qualified Data.Time as T +import qualified Data.DList as DL import qualified Accounts as A import qualified Ledger as LD import qualified Expense as F @@ -538,7 +539,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f filter (\y -> case getTxnComment y of (PayInt _ ) -> True _ -> False) $ - filter (\x -> d == getDate x) txns + filter (\x -> d == getDate x) (DL.toList txns) in Right . toRational $ sum $ map ex stmts @@ -552,7 +553,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f filter (\y -> case getTxnComment y of (PayPrin _ ) -> True _ -> False) $ - filter (\x -> d == getDate x) txns + filter (\x -> d == getDate x) (DL.toList txns) in Right . toRational $ sum $ map ex stmts @@ -565,14 +566,14 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f Just cmt -> sum [ queryTxnAmtAsOf fee d cmt | fee <- fees ] Nothing -> let - _txn = concat [ getTxns (F.feeStmt fee) | fee <- fees ] + _txn = concat [ (DL.toList .getTxns)(F.feeStmt fee) | fee <- fees ] in sumTxn $ cutBy Inc Past d _txn FeePaidAmt fns -> let fees = (feeMap Map.!) <$> fns - feeTxns = concat [ getTxns (F.feeStmt fee) | fee <- fees ] + feeTxns = concat [ (DL.toList .getTxns) (F.feeStmt fee) | fee <- fees ] in Right . toRational $ sumTxn feeTxns @@ -585,7 +586,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f Just cmt -> sum [ queryTxnAmtAsOf bnd d cmt | bnd <- bnds ] Nothing -> let - _txn = concat [ getTxns (L.bndStmt bnd) | bnd <- bnds ] + _txn = concat [ (DL.toList . getTxns) (L.bndStmt bnd) | bnd <- bnds ] in sumTxn $ cutBy Inc Past d _txn @@ -598,7 +599,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f Just cmt -> sum [ queryTxnAmtAsOf acc d cmt | acc <- accs ] Nothing -> let - _txn = concat [ getTxns (A.accStmt acc) | acc <- accs ] + _txn = concat [ (DL.toList . getTxns) (A.accStmt acc) | acc <- accs ] in sumTxn $ cutBy Inc Past d _txn @@ -631,7 +632,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f stmts = map F.feeStmt $ Map.elems fSubMap ex s = case s of Nothing -> 0 - Just (Statement txns) -> sum $ getTxnAmt <$> filter (\x -> d == getDate x) txns + Just (Statement txns) -> sum $ getTxnAmt <$> filter (\x -> d == getDate x) (DL.toList txns) in Right . toRational $ sum $ map ex stmts diff --git a/src/Expense.hs b/src/Expense.hs index 75139118..24f707ee 100644 --- a/src/Expense.hs +++ b/src/Expense.hs @@ -18,6 +18,7 @@ import qualified Data.Text import Data.Aeson hiding (json) import Data.Aeson.TH import Data.Aeson.Types +import qualified Data.DList as DL import GHC.Generics import Data.Fixed @@ -97,7 +98,7 @@ buildFeeAccrueAction (fee:fees) ed r = instance S.QueryByComment Fee where queryStmt Fee{feeStmt = Nothing} tc = [] queryStmt Fee{feeStmt = Just (S.Statement txns)} tc - = filter (\x -> S.getTxnComment x == tc) txns + = filter (\x -> S.getTxnComment x == tc) (DL.toList txns) instance Liable Fee where isPaidOff f@Fee{feeDue=bal,feeArrears=fa} diff --git a/src/Hedge.hs b/src/Hedge.hs index d01c21cf..2bc84e86 100644 --- a/src/Hedge.hs +++ b/src/Hedge.hs @@ -21,6 +21,7 @@ import Data.Aeson.TH import Data.Aeson.Types import Data.Fixed import Data.Maybe +import qualified Data.DList as DL import Types import Util import Stmt @@ -107,7 +108,7 @@ payoutIRS d amt rs@RateSwap{rsNetCash = payoutAmt, rsStmt = stmt} instance QueryByComment RateSwap where queryStmt RateSwap{rsStmt = Nothing} tc = [] queryStmt RateSwap{rsStmt = Just (Statement txns)} tc - = filter (\x -> getTxnComment x == tc) txns + = filter (\x -> getTxnComment x == tc) (DL.toList txns) instance Liable RateSwap where isPaidOff rs@RateSwap{rsNetCash=bal} @@ -144,7 +145,7 @@ instance IR.UseRate RateCap where instance QueryByComment RateCap where queryStmt RateCap{rcStmt = Nothing} tc = [] queryStmt RateCap{rcStmt = Just (Statement txns)} tc - = filter (\x -> getTxnComment x == tc) txns + = filter (\x -> getTxnComment x == tc) (DL.toList txns) data CurrencySwap = CurrencySwap { diff --git a/src/Ledger.hs b/src/Ledger.hs index 34a7a96d..ad66ca04 100644 --- a/src/Ledger.hs +++ b/src/Ledger.hs @@ -14,6 +14,7 @@ import Data.Aeson hiding (json) import Language.Haskell.TH import Data.Aeson.TH import Data.Aeson.Types +import qualified Data.DList as DL import GHC.Generics import Control.Lens hiding (element) @@ -117,7 +118,7 @@ clearLedgersBySeq dr d amtToAlloc rs (ledger@Ledger{ledgBalance = bal}:ledgers) instance QueryByComment Ledger where queryStmt (Ledger _ _ Nothing) tc = [] queryStmt (Ledger _ _ (Just (Statement txns))) tc - = filter (\x -> getTxnComment x == tc) txns + = filter (\x -> getTxnComment x == tc) (DL.toList txns) queryTxnAmt a tc = sum $ map getTxnAmt $ queryStmt a tc diff --git a/src/Liability.hs b/src/Liability.hs index 5c205877..c8095bc8 100644 --- a/src/Liability.hs +++ b/src/Liability.hs @@ -37,6 +37,7 @@ import Data.Ratio import Data.Maybe import Data.List import qualified Data.Set as Set +import qualified Data.DList as DL import qualified Stmt as S import qualified Cashflow as CF import qualified InterestRate as IR @@ -246,13 +247,15 @@ curRatesTraversal f (BondGroup bMap x) = BondGroup <$> traverse (curRatesTraversal f) bMap <*> pure x -bndTxns :: Lens' Bond (Maybe S.Statement) -bndTxns = lens getter setter +bndmStmt :: Lens' Bond (Maybe S.Statement) +bndmStmt = lens getter setter where getter Bond{bndStmt = mStmt} = mStmt getter MultiIntBond{bndStmt = mStmt} = mStmt + -- getter BondGroup{bndStmt = mStmt} = mStmt setter Bond{bndStmt = _} mStmt = Bond{bndStmt = mStmt} setter MultiIntBond{bndStmt = _} mStmt = MultiIntBond{bndStmt = mStmt} + -- setter BondGroup{bndStmt = _} mStmt = BondGroup{bndStmt = mStmt} bondCashflow :: Bond -> ([Date], [Amount]) bondCashflow b = @@ -270,7 +273,7 @@ consolStmt b combinedBondTxns = foldl S.consolTxn [txn] txns droppedTxns = dropWhile S.isEmptyTxn combinedBondTxns in - b {bndStmt = Just (S.Statement (reverse droppedTxns))} + b {bndStmt = Just (S.Statement (DL.fromList (reverse droppedTxns)))} setBondOrigDate :: Date -> Bond -> Bond setBondOrigDate d b@Bond{bndOriginInfo = oi} = b {bndOriginInfo = oi{originDate = d}} @@ -286,9 +289,12 @@ patchBondFactor bnd | otherwise = let oBal = originBalance (bndOriginInfo bnd) toFactor (BondTxn d b i p r0 c e f Nothing t) = (BondTxn d b i p r0 c e f (Just (fromRational (divideBB b oBal))) t) - newStmt = S.Statement $ toFactor <$> (S.getAllTxns bnd) + -- newStmt = S.Statement $ toFactor <$> (S.getAllTxns bnd) + newBnd = case bndStmt bnd of + Nothing -> bnd + Just (S.Statement txns) -> bnd {bndStmt = Just (S.Statement (toFactor <$> txns)) } in - bnd {bndStmt = Just newStmt} + newBnd payInt :: Date -> Amount -> Bond -> Bond -- pay 0 interest, do nothing @@ -540,17 +546,17 @@ weightAverageBalance sd ed b@(Bond _ _ (OriginalInfo ob bd _ _ ) _ _ currentBal weightAverageBalance sd ed b@(MultiIntBond _ _ (OriginalInfo ob bd _ _ ) _ _ currentBalance _ _ _ _ _ _ _ Nothing) = mulBR currentBalance (yearCountFraction DC_ACT_365F (max bd sd) ed) -weightAverageBalance sd ed b@(Bond _ _ (OriginalInfo ob bd _ _ ) _ _ currentBalance _ _ _ _ _ _ _ (Just stmt)) +weightAverageBalance sd ed b@(Bond _ _ (OriginalInfo ob bd _ _ ) _ _ currentBalance _ _ _ _ _ _ _ (Just (S.Statement txns))) = S.weightAvgBalance' (max bd sd) ed - (view S.statementTxns stmt) + (DL.toList txns) -weightAverageBalance sd ed b@(MultiIntBond _ _ (OriginalInfo ob bd _ _ ) _ _ currentBalance _ _ _ _ _ _ _ (Just stmt)) +weightAverageBalance sd ed b@(MultiIntBond _ _ (OriginalInfo ob bd _ _ ) _ _ currentBalance _ _ _ _ _ _ _ (Just (S.Statement txns))) = S.weightAvgBalance' (max bd sd) ed - (view S.statementTxns stmt) + (DL.toList txns) weightAverageBalance sd ed bg@(BondGroup bMap _) @@ -643,9 +649,9 @@ instance S.QueryByComment Bond where queryStmt Bond{bndStmt = Nothing} tc = [] queryStmt MultiIntBond{bndStmt = Nothing} tc = [] queryStmt Bond{bndStmt = Just (S.Statement txns)} tc - = Data.List.filter (\x -> S.getTxnComment x == tc) txns + = Data.List.filter (\x -> S.getTxnComment x == tc) (DL.toList txns) queryStmt MultiIntBond{bndStmt = Just (S.Statement txns)} tc - = Data.List.filter (\x -> S.getTxnComment x == tc) txns + = Data.List.filter (\x -> S.getTxnComment x == tc) (DL.toList txns) instance Liable Bond where @@ -714,15 +720,15 @@ instance IR.UseRate Bond where instance S.HasStmt Bond where getAllTxns Bond{bndStmt = Nothing} = [] - getAllTxns Bond{bndStmt = Just (S.Statement txns)} = txns + getAllTxns Bond{bndStmt = Just (S.Statement txns)} = DL.toList txns getAllTxns MultiIntBond{bndStmt = Nothing} = [] - getAllTxns MultiIntBond{bndStmt = Just (S.Statement txns)} = txns + getAllTxns MultiIntBond{bndStmt = Just (S.Statement txns)} = DL.toList txns getAllTxns (BondGroup bMap _) = concat $ S.getAllTxns <$> Map.elems bMap hasEmptyTxn Bond{bndStmt = Nothing} = True - hasEmptyTxn Bond{bndStmt = Just (S.Statement [])} = True + hasEmptyTxn Bond{bndStmt = Just (S.Statement txn)} = txn == DL.empty hasEmptyTxn MultiIntBond{bndStmt = Nothing} = True - hasEmptyTxn MultiIntBond{bndStmt = Just (S.Statement [])} = True + hasEmptyTxn MultiIntBond{bndStmt = Just (S.Statement txn)} = txn == DL.empty hasEmptyTxn (BondGroup bMap _) = all S.hasEmptyTxn $ Map.elems bMap hasEmptyTxn _ = False diff --git a/src/Reports.hs b/src/Reports.hs index 349c67f0..f17695da 100644 --- a/src/Reports.hs +++ b/src/Reports.hs @@ -136,7 +136,7 @@ buildCashReport t@TestDeal{accounts = accs} sd ed , startDate = sd , endDate = ed } where - _txns = concat $ Map.elems $ Map.map getTxns $ Map.map A.accStmt accs + _txns = concat $ Map.elems $ Map.map (DL.toList . getTxns) $ Map.map A.accStmt accs txns = sliceBy EI sd ed _txns inflowTxn = sort $ filter (\x -> (getFlow . getTxnComment) x == Inflow) txns diff --git a/src/Stmt.hs b/src/Stmt.hs index eeb79109..d428a78a 100644 --- a/src/Stmt.hs +++ b/src/Stmt.hs @@ -28,6 +28,7 @@ import Text.Regex.Base import Text.Regex.PCRE import Data.Fixed import Data.List +import qualified Data.DList as DL import Data.Maybe import GHC.Generics import qualified Data.Set as Set @@ -167,15 +168,17 @@ weightAvgBalance' sd ed (_txn:_txns) in sum $ zipWith mulBR balances factors --`debug` ("In weight avg bal: Factors"++show factors++"Balances"++show balances ++ "interval "++ show (sd,ed)) -data Statement = Statement [Txn] +data Statement = Statement (DL.DList Txn) deriving (Show, Generic, Eq, Ord, Read) appendStmt :: Txn -> Maybe Statement -> Maybe Statement -appendStmt txn (Just stmt@(Statement txns)) = Just $ Statement (txns++[txn]) -appendStmt txn Nothing = Just $ Statement [txn] +appendStmt txn (Just stmt@(Statement txns)) = Just $ Statement (DL.snoc txns txn) +appendStmt txn Nothing = Just $ Statement DL.empty -statementTxns :: Lens' Statement [Txn] + + +statementTxns :: Lens' Statement (DL.DList Txn) statementTxns = lens getter setter where getter (Statement txns) = txns @@ -188,8 +191,8 @@ consolTxn (txn:txns) txn0 | getDate txn == getDate txn0 = combineTxn txn txn0:txns | otherwise = txn0:txn:txns -getTxns :: Maybe Statement -> [Txn] -getTxns Nothing = [] +getTxns :: Maybe Statement -> DL.DList Txn +getTxns Nothing = DL.empty getTxns (Just (Statement txn)) = txn combineTxn :: Txn -> Txn -> Txn diff --git a/src/Types.hs b/src/Types.hs index 9fcb2ec0..6463a2f0 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -912,6 +912,8 @@ $(deriveJSON defaultOptions ''PoolSource) $(deriveJSON defaultOptions ''RoundingBy) $(deriveJSON defaultOptions ''PoolId) + + instance ToJSONKey PoolId where toJSONKey :: ToJSONKeyFunction PoolId toJSONKey = toJSONKeyText (T.pack . show) From e0c9c412bac6491f2d1dc81ba6d4df5737ca5fd7 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 02:31:13 +0800 Subject: [PATCH 18/53] fix stmt --- src/Stmt.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Stmt.hs b/src/Stmt.hs index d428a78a..61094b87 100644 --- a/src/Stmt.hs +++ b/src/Stmt.hs @@ -173,7 +173,7 @@ data Statement = Statement (DL.DList Txn) appendStmt :: Txn -> Maybe Statement -> Maybe Statement appendStmt txn (Just stmt@(Statement txns)) = Just $ Statement (DL.snoc txns txn) -appendStmt txn Nothing = Just $ Statement DL.empty +appendStmt txn Nothing = Just $ Statement $ DL.singleton txn From 1acbb9b7a7437eb7cb8937b94bec478dcfe7b334 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 12:35:34 +0800 Subject: [PATCH 19/53] fix UT --- test/UT/AccountTest.hs | 10 ++++++---- test/UT/BondTest.hs | 35 ++++++++++++++++++----------------- test/UT/CeTest.hs | 17 +++++++++-------- test/UT/DealTest.hs | 12 ++++++------ test/UT/UtilTest.hs | 11 ++++++----- 5 files changed, 45 insertions(+), 40 deletions(-) diff --git a/test/UT/AccountTest.hs b/test/UT/AccountTest.hs index 94661491..ceb1fef3 100644 --- a/test/UT/AccountTest.hs +++ b/test/UT/AccountTest.hs @@ -19,7 +19,9 @@ import Control.Lens hiding (element,Empty) import Control.Lens.TH import Data.Map.Lens + import qualified Data.Time as T +import qualified Data.DList as DL import qualified Data.Map as Map import UT.DealTest (td2) @@ -30,8 +32,8 @@ intTests = let acc1 = Account 200 "A1" (Just (BankAccount 0.03 QuarterEnd (toDate "20221001"))) Nothing Nothing acc2 = Account 150 "A1" (Just (BankAccount 0.03 MonthEnd (toDate "20220301"))) Nothing - (Just (Statement [ AccTxn (toDate "20220715") 120 10 Empty - ,AccTxn (toDate "20220915") 150 30 Empty ])) + (Just (Statement (DL.fromList [ AccTxn (toDate "20220715") 120 10 Empty + ,AccTxn (toDate "20220915") 150 30 Empty ]))) in testGroup "Interest on Bank Account Test" [ @@ -58,8 +60,8 @@ investTests = rc = mkTs [(toDate "20211201",0.03),(toDate "20221201",0.03)] acc1 = Account 2000 "A1" (Just (InvestmentAccount SOFR1Y 0.015 QuarterEnd QuarterEnd (toDate "20221001") 0.04)) Nothing Nothing acc2 = Account 150 "A1" (Just (InvestmentAccount SOFR1Y 0.01 QuarterEnd QuarterEnd (toDate "20220301") 0.03)) Nothing - (Just (Statement [ AccTxn (toDate "20220715") 120 10 Empty - ,AccTxn (toDate "20220915") 150 30 Empty ])) + (Just (Statement (DL.fromList [ AccTxn (toDate "20220715") 120 10 Empty + ,AccTxn (toDate "20220915") 150 30 Empty ]))) in testGroup "Interest on Invest Account Test" [ diff --git a/test/UT/BondTest.hs b/test/UT/BondTest.hs index d504832b..e60fad4c 100644 --- a/test/UT/BondTest.hs +++ b/test/UT/BondTest.hs @@ -12,6 +12,7 @@ import qualified Stmt as S import qualified Asset as P import qualified Assumptions as A import qualified Cashflow as CF +import qualified Data.DList as DL import Util import Types import Data.Ratio @@ -19,7 +20,7 @@ import Data.Ratio import Debug.Trace debug = flip trace -b1Txn = [ BondTxn (L.toDate "20220501") 1500 10 500 0.08 510 0 0 Nothing S.Empty +b1Txn = DL.fromList [ BondTxn (L.toDate "20220501") 1500 10 500 0.08 510 0 0 Nothing S.Empty ,BondTxn (L.toDate "20220801") 0 10 1500 0.08 1510 0 0 Nothing S.Empty ] b1 = B.Bond{B.bndName="A" ,B.bndType=B.Sequential @@ -55,7 +56,7 @@ bfloat = B.Bond{B.bndName="A" ,B.bndDueIntOverInt=0.0 ,B.bndLastIntPay = Just (T.fromGregorian 2022 1 1) ,B.bndLastPrinPay = Just (T.fromGregorian 2022 1 1) - ,B.bndStmt=Just $ S.Statement [ BondTxn (L.toDate "20220501") 1500 10 500 0.08 510 0 0 Nothing S.Empty]} + ,B.bndStmt=Just $ S.Statement (DL.fromList [ BondTxn (L.toDate "20220501") 1500 10 500 0.08 510 0 0 Nothing S.Empty])} pricingTests = testGroup "Pricing Tests" @@ -87,11 +88,11 @@ pricingTests = testGroup "Pricing Tests" in testCase "flat rate discount " $ assertEqual "Test Pricing on case 01" - (PriceResult 1978.47 65.949000 1.18 1.1881448 0.4906438 52.60 b1Txn) + (PriceResult 1978.47 65.949000 1.18 1.1881448 0.4906438 52.60 (DL.toList b1Txn)) pr , let - b2Txn = [BondTxn (L.toDate "20220301") 3000 10 300 0.08 310 0 0 Nothing S.Empty + b2Txn = DL.fromList [BondTxn (L.toDate "20220301") 3000 10 300 0.08 310 0 0 Nothing S.Empty ,BondTxn (L.toDate "20220501") 2700 10 500 0.08 510 0 0 Nothing S.Empty ,BondTxn (L.toDate "20220701") 0 10 3200 0.08 3300 0 0 Nothing S.Empty] b2 = b1 { B.bndStmt = Just (S.Statement b2Txn)} @@ -105,7 +106,7 @@ pricingTests = testGroup "Pricing Tests" in testCase " discount curve with two rate points " $ assertEqual "Test Pricing on case 01" - (PriceResult 4049.10 134.97 0.44 0.364564 0.006030 286.42 b2Txn) + (PriceResult 4049.10 134.97 0.44 0.364564 0.006030 286.42 (DL.toList b2Txn)) pr --TODO need to confirm in UI , let @@ -123,7 +124,7 @@ pricingTests = testGroup "Pricing Tests" assertEqual "pay int" 2400 $ B.bndBalance (B.payPrin pday 600 b5) , let - newCfStmt = Just $ S.Statement [ BondTxn (L.toDate "20220501") 1500 300 2800 0.08 3100 0 0 Nothing S.Empty] + newCfStmt = Just $ S.Statement (DL.fromList [ BondTxn (L.toDate "20220501") 1500 300 2800 0.08 3100 0 0 Nothing S.Empty]) b6 = b1 {B.bndStmt = newCfStmt} pday = L.toDate "20220301" -- `debug` ("stmt>>>>>"++ show (B.bndStmt b6)) rateCurve = IRateCurve [TsPoint (L.toDate "20220201") 0.03 ,TsPoint (L.toDate "20220401") 0.04] @@ -167,49 +168,49 @@ bndConsolTest = testGroup "Bond consoliation & patchtesting" [ in testCase "test on patching bond factor" $ assertEqual "" - [ BondTxn (L.toDate "20220501") 1500 10 500 0.08 510 0 0 (Just 0.5) S.Empty + (DL.fromList [ BondTxn (L.toDate "20220501") 1500 10 500 0.08 510 0 0 (Just 0.5) S.Empty ,BondTxn (L.toDate "20220801") 0 10 1500 0.08 1510 0 0 (Just 0.0) S.Empty - ] + ]) b1f, let - txns = [ BondTxn (L.toDate "20220501") 1500 0 (-500) 0.08 0 0 0 (Just 0.5) S.Empty + txns = DL.fromList [BondTxn (L.toDate "20220501") 1500 0 (-500) 0.08 0 0 0 (Just 0.5) S.Empty ,BondTxn (L.toDate "20220501") 2000 0 (-500) 0.08 0 0 0 (Just 0.0) S.Empty] bTest = b1 {B.bndStmt = Just (S.Statement txns)} bTestConsol = B.bndStmt $ B.consolStmt bTest in testCase "merge txn with two drawdowns" $ assertEqual "" - (Just (S.Statement [ BondTxn (L.toDate "20220501") 2000 0 (-1000) 0.08 0 0 0 (Just 0.0) (S.TxnComments [S.Empty, S.Empty])])) + (Just (S.Statement (DL.fromList [ BondTxn (L.toDate "20220501") 2000 0 (-1000) 0.08 0 0 0 (Just 0.0) (S.TxnComments [S.Empty, S.Empty])]))) bTestConsol, let - txns = [ BondTxn (L.toDate "20220501") 1500 0 (-500) 0.08 0 0 0 (Just 0.5) S.Empty + txns = DL.fromList [ BondTxn (L.toDate "20220501") 1500 0 (-500) 0.08 0 0 0 (Just 0.5) S.Empty ,BondTxn (L.toDate "20220501") 1500 0 500 0.08 0 0 0 (Just 0.0) S.Empty] bTest = b1 {B.bndStmt = Just (S.Statement txns)} bTestConsol = B.bndStmt $ B.consolStmt bTest in testCase "merge txn with one drawdown at begin" $ assertEqual "" - (Just (S.Statement [ BondTxn (L.toDate "20220501") 1500 0 0 0.08 0 0 0 (Just 0.0) (S.TxnComments [S.Empty, S.Empty])])) + (Just (S.Statement (DL.fromList [ BondTxn (L.toDate "20220501") 1500 0 0 0.08 0 0 0 (Just 0.0) (S.TxnComments [S.Empty, S.Empty])]))) bTestConsol, let - txns = [BondTxn (L.toDate "20220501") 1500 0 500 0.08 0 0 0 (Just 0.0) S.Empty, + txns = DL.fromList [BondTxn (L.toDate "20220501") 1500 0 500 0.08 0 0 0 (Just 0.0) S.Empty, BondTxn (L.toDate "20220501") 2000 0 (-500) 0.08 0 0 0 (Just 0.5) S.Empty] bTest = b1 {B.bndStmt = Just (S.Statement txns)} bTestConsol = B.bndStmt $ B.consolStmt bTest in testCase "merge txn with one drawdown at end" $ assertEqual "" - (Just (S.Statement [ BondTxn (L.toDate "20220501") 2000 0 0 0.08 0 0 0 (Just 0.5) (S.TxnComments [S.Empty, S.Empty])])) + (Just (S.Statement (DL.fromList [ BondTxn (L.toDate "20220501") 2000 0 0 0.08 0 0 0 (Just 0.5) (S.TxnComments [S.Empty, S.Empty])]))) bTestConsol, let - txns = [BondTxn (L.toDate "20220501") 1500 0 500 0.08 0 0 0 (Just 0.0) S.Empty, + txns = DL.fromList [BondTxn (L.toDate "20220501") 1500 0 500 0.08 0 0 0 (Just 0.0) S.Empty, BondTxn (L.toDate "20220501") 1000 0 500 0.08 0 0 0 (Just 0.5) S.Empty] bTest = b1 {B.bndStmt = Just (S.Statement txns)} bTestConsol = B.bndStmt $ B.consolStmt bTest in testCase "merge txn with one drawdown at end" $ assertEqual "" - (Just (S.Statement [ BondTxn (L.toDate "20220501") 1000 0 1000 0.08 0 0 0 (Just 0.5) (S.TxnComments [S.Empty, S.Empty])])) + (Just (S.Statement (DL.fromList [ BondTxn (L.toDate "20220501") 1000 0 1000 0.08 0 0 0 (Just 0.5) (S.TxnComments [S.Empty, S.Empty])]))) bTestConsol ] @@ -224,7 +225,7 @@ writeOffTest = testGroup "write off on bond" [ testCase "write off on bond 1" $ assertEqual "only 1st bond is written off by 70" - (Right (bnd1 {B.bndBalance = 30,B.bndStmt = Just (S.Statement [S.BondTxn d1 30.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (S.WriteOff "A" 70.00)])})) + (Right (bnd1 {B.bndBalance = 30,B.bndStmt = Just (S.Statement (DL.fromList [S.BondTxn d1 30.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (S.WriteOff "A" 70.00)]))})) (B.writeOff d1 writeAmt1 bnd1), testCase "over write off on bond 1" $ assertEqual "over write off on bond 1" diff --git a/test/UT/CeTest.hs b/test/UT/CeTest.hs index 89b2961d..c2a68f46 100644 --- a/test/UT/CeTest.hs +++ b/test/UT/CeTest.hs @@ -9,6 +9,7 @@ import Lib import Util import Stmt import Data.Ratio +import qualified Data.DList as DL import Types import CreditEnhancement import qualified InterestRate as IR @@ -27,11 +28,11 @@ liqTest = testGroup "Pricing Tests" in testCase "First Accure" $ assertEqual "First Accure" - (Just (Statement [SupportTxn (toDate "20220101") (Just 500) 100 0 0 0 Empty - ,SupportTxn (toDate "20220201") (Just 500) 100 0.25 3.39 0 (LiquidationSupportInt 0.25 3.39)])) + (Just (Statement (DL.fromList [SupportTxn (toDate "20220101") (Just 500) 100 0 0 0 Empty + ,SupportTxn (toDate "20220201") (Just 500) 100 0.25 3.39 0 (LiquidationSupportInt 0.25 3.39)]))) (liqStmt (accrueLiqProvider (toDate "20220201") liq0 )) ,let - liqStmt1 = [ + liqStmt1 = DL.fromList [ SupportTxn (toDate "20220101") (Just 500) 100 0 0 0 Empty ,SupportTxn (toDate "20220201") (Just 800) 100 0.25 3.39 0 (LiquidationSupportInt 0.25 3.39) ] @@ -42,12 +43,12 @@ liqTest = testGroup "Pricing Tests" in testCase "Accure on unused balance" $ assertEqual "with one history txn" - (Just (Statement [SupportTxn (toDate "20220101") (Just 500) 100 0 0 0 Empty + (Just (Statement (DL.fromList [SupportTxn (toDate "20220101") (Just 500) 100 0 0 0 Empty ,SupportTxn (toDate "20220201") (Just 800) 100 0.25 3.39 0 (LiquidationSupportInt 0.25 3.39) - ,SupportTxn (toDate "20220301") (Just 800) 100 0.48 8.29 0 (LiquidationSupportInt 0.23 4.9)])) + ,SupportTxn (toDate "20220301") (Just 800) 100 0.48 8.29 0 (LiquidationSupportInt 0.23 4.9)]))) (liqStmt (accrueLiqProvider (toDate "20220301") liq1 )) ,let - liqStmt1 = [ + liqStmt1 = DL.fromList [ SupportTxn (toDate "20220101") (Just 500) 100 0 0 0 Empty ,SupportTxn (toDate "20220201") (Just 800) 100 0.25 3.39 0 (LiquidationSupportInt 0.25 3.39) ,SupportTxn (toDate "20220301") (Just 1000) 100 0.48 8.29 0 (LiquidationSupportInt 0.23 4.9) @@ -59,10 +60,10 @@ liqTest = testGroup "Pricing Tests" in testCase "Accure on unused balance " $ assertEqual "with multiple history txn" - (Just (Statement [SupportTxn (toDate "20220101") (Just 500) 100 0 0 0 Empty + (Just (Statement (DL.fromList [SupportTxn (toDate "20220101") (Just 500) 100 0 0 0 Empty ,SupportTxn (toDate "20220201") (Just 800) 100 0.25 3.39 0 (LiquidationSupportInt 0.25 3.39) ,SupportTxn (toDate "20220301") (Just 1000) 100 0.48 8.29 0 (LiquidationSupportInt 0.23 4.9) ,SupportTxn (toDate "20220401") (Just 1000) 100 0.99 18.49 0 (LiquidationSupportInt 0.74 15.10) - ])) + ]))) (liqStmt (accrueLiqProvider (toDate "20220401") liq1 )) ] \ No newline at end of file diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index b357cdb0..14627d60 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -23,7 +23,6 @@ import qualified Call as C import InterestRate import qualified CreditEnhancement as CE import qualified Triggers as Trg -import qualified Data.DList as DL import Lib import Types @@ -35,6 +34,7 @@ import Data.Either 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 Debug.Trace debug = flip Debug.Trace.trace @@ -166,8 +166,8 @@ td2 = D.TestDeal { 0 (toDate "20220201") Nothing - (Just (Stmt.Statement [SupportTxn (toDate "20220215") (Just 110) 10 40 0 0 Empty - ,SupportTxn (toDate "20220315") (Just 100) 10 50 0 0 Empty])))] + (Just (Stmt.Statement (DL.fromList [SupportTxn (toDate "20220215") (Just 110) 10 40 0 0 Empty + ,SupportTxn (toDate "20220315") (Just 100) 10 50 0 0 Empty]))))] ,D.triggers = Just $ Map.fromList $ [(BeginDistributionWF, @@ -289,7 +289,7 @@ poolFlowTest = ,testCase "last bond A payment date" $ assertEqual "pool bal should equal to total collect" (Just (BondTxn (toDate "20240201") 0.00 0.00 30.56 0.080000 30.56 0.00 0.00 (Just 0.0) (PayPrin ["A"]))) - $ (\s -> last (view Stmt.statementTxns s)) <$> (L.bndStmt $ (bndMap Map.! "A")) + $ (\s -> last (DL.toList (view Stmt.statementTxns s))) <$> (L.bndStmt $ (bndMap Map.! "A")) ] @@ -376,9 +376,9 @@ liqProviderTest = (toDate "20220301") Nothing (Just (Stmt.Statement - [SupportTxn (toDate "20220215") (Just 110) 40 40 0 0 Empty + (DL.fromList ([SupportTxn (toDate "20220215") (Just 110) 40 40 0 0 Empty ,SupportTxn (toDate "20220315") (Just 100) 50 90 0 0 Empty - ])) + ])))) in testGroup "Liq provider test" [testCase "Liq Provider Int test" $ diff --git a/test/UT/UtilTest.hs b/test/UT/UtilTest.hs index 716e98ae..e5dcce52 100644 --- a/test/UT/UtilTest.hs +++ b/test/UT/UtilTest.hs @@ -15,6 +15,7 @@ import Lib import Types import Stmt import Data.Fixed +import qualified Data.DList as DL import Data.Ratio ((%)) import Debug.Trace @@ -612,19 +613,19 @@ paySeqTest = testGroup "write off on bond" [ testCase "write off on bond 1" $ assertEqual "only 1st bond is written off by 70" - (Right ([bnd1 {L.bndBalance = 30,L.bndStmt = Just (Statement [BondTxn d1 30.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "A" 70.00)])} + (Right ([bnd1 {L.bndBalance = 30,L.bndStmt = Just (Statement (DL.fromList ([BondTxn d1 30.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "A" 70.00)])))} , bnd2],0)) (paySeqM d1 70 L.bndBalance (L.writeOff d1) (Right []) [bnd1,bnd2]) ,testCase "write off on bond 2" $ assertEqual "2st bond is written off by 70" - (Right ([bnd1 {L.bndBalance = 0,L.bndStmt = Just (Statement [BondTxn d1 0.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "A" 100.00)])} - , bnd2{L.bndBalance = 70,L.bndStmt = Just (Statement [BondTxn d1 70.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "B" 30.00)])} + (Right ([bnd1 {L.bndBalance = 0,L.bndStmt = Just (Statement (DL.fromList ([BondTxn d1 0.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "A" 100.00)])))} + , bnd2{L.bndBalance = 70,L.bndStmt = Just (Statement (DL.fromList ([BondTxn d1 70.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "B" 30.00)])))} ],0)) (paySeqM d1 130 L.bndBalance (L.writeOff d1) (Right []) [bnd1,bnd2]) ,testCase "write off on all bonds " $ assertEqual "over write off" - (Right ([bnd1 {L.bndBalance = 0,L.bndStmt = Just (Statement [BondTxn d1 0.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "A" 100.00)])} - , bnd2{L.bndBalance = 0,L.bndStmt = Just (Statement [BondTxn d1 0.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "B" 100.00)])} + (Right ([bnd1 {L.bndBalance = 0,L.bndStmt = Just (Statement (DL.fromList ([BondTxn d1 0.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "A" 100.00)])))} + , bnd2{L.bndBalance = 0,L.bndStmt = Just (Statement (DL.fromList ([BondTxn d1 0.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "B" 100.00)])))} ],30)) (paySeqM d1 230 L.bndBalance (L.writeOff d1) (Right []) [bnd1,bnd2]) ] \ No newline at end of file From 19d2c99709d05a445f630d1ffe54ba37e6afa05c Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 13:59:52 +0800 Subject: [PATCH 20/53] bump version to-> < 0.45.2 > --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 3e93d264..157d23cf 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -101,7 +101,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.45.1" +version1 = Version "0.45.2" wrapRun :: DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From 4d943a687ff0ca5d67a3f3e7745ebc5d176d588f Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 14:17:15 +0800 Subject: [PATCH 21/53] update workflow --- .github/workflows/docker-image-dev-by-tag.yml | 2 ++ .github/workflows/docker-image-dev.yml | 3 ++- .github/workflows/docker-image.yml | 2 +- .github/workflows/haskell.yml | 2 ++ CHANGELOG.md | 17 ++++++++++------- 5 files changed, 17 insertions(+), 9 deletions(-) diff --git a/.github/workflows/docker-image-dev-by-tag.yml b/.github/workflows/docker-image-dev-by-tag.yml index 7c1aa521..065a100e 100644 --- a/.github/workflows/docker-image-dev-by-tag.yml +++ b/.github/workflows/docker-image-dev-by-tag.yml @@ -53,3 +53,5 @@ jobs: tags: ${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:dev, ${{ steps.meta.outputs.tags }} cache-from: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache cache-to: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache,mode=max + + \ No newline at end of file diff --git a/.github/workflows/docker-image-dev.yml b/.github/workflows/docker-image-dev.yml index 9026d371..27f1522c 100644 --- a/.github/workflows/docker-image-dev.yml +++ b/.github/workflows/docker-image-dev.yml @@ -57,4 +57,5 @@ jobs: context: "{{defaultContext}}" push: true tags: ${{ steps.meta.outputs.tags }} - labels: ${{ steps.meta.outputs.labels }} \ No newline at end of file + labels: ${{ steps.meta.outputs.labels }} + diff --git a/.github/workflows/docker-image.yml b/.github/workflows/docker-image.yml index e43ae477..e6080c82 100644 --- a/.github/workflows/docker-image.yml +++ b/.github/workflows/docker-image.yml @@ -157,4 +157,4 @@ jobs: tags: ${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:latest, ${{ steps.meta.outputs.tags }} cache-from: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache cache-to: type=registry,ref=${{ secrets.DOCKER_HUB_USERNAME }}/hastructure:buildcache,mode=max - + \ No newline at end of file diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index e1a6c5c3..d67e65da 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -43,3 +43,5 @@ jobs: - name: Badge Action uses: emibcn/badge-action@v1.2.4 + + \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md index 493b4319..a3bd3253 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,24 +2,27 @@ -## 0.44.1 +## 0.45.2 +### 2025-04-01 +* ENHANCE: Performance optimaization by replace `List` with `DList`. +* ENHANCE: remove `stack` as build tool +* ENHANCE: In `inspection` ,expose `IsOustanding` `HasPassedMaturity` in `Pre` + + + +## 0.45.1 ### 2025-03-25 -* BREAK: * FIX: in `Pricing/IRR`, error when holding position is too small -* NEW: * ENHANCE: engine will auto patch `interest start date` for bonds if it is not modeled. In `PreClosing` status, engine will use `closing date` as bond interest begin date ; In `Non-PreClosing` status, it defaults to use last waterfall distribution date as bond interest begin date. -## 0.44.0 +## 0.45.0 ### 2025-03-21 * BREAK: remove unused `DealDates` : `FixInterval`, `CustomDates` and `PatternInterval`. Since all these can be replace by new `GenericDates` in type `DateDesp` * ENHANCE: now bond with `No last interest accure day` will begin accrue interest from `closing date` if the deal is in `PreClosing` mode, while the bond will use `last bond day` otherwise. * FIX: `IsPaidOff` now can be queried in inspection formula - - - ## 0.44.0 ### 2025-03-11 * BREAK: Add `PAC` `PAC Anchor` to `BondGroup`, now `BondGroup` is `Map String L.Bond (Maybe PrinType)` From d42f576e802abb0392f455c22d16fa7eeaf6c1be Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 14:41:45 +0800 Subject: [PATCH 22/53] stack to cabal in docker --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index bb98483f..bcfc0c36 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,7 +1,7 @@ FROM fpco/stack-build:lts-22.6 as build RUN mkdir /opt/build COPY . /opt/build -RUN cd /opt/build && stack build --copy-bins \ +RUN cd /opt/build && cabal build --copy-bins \ --local-bin-path /opt/build --resolver lts-22.6 # --system-ghc From 8bee0e7cf40ec8e4c4b114eaa9d275c0ef96db34 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 14:57:08 +0800 Subject: [PATCH 23/53] new docker --- Dockerfile | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index bcfc0c36..4638b280 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,8 +1,7 @@ -FROM fpco/stack-build:lts-22.6 as build +FROM haskell:slim-bullseye as build RUN mkdir /opt/build COPY . /opt/build -RUN cd /opt/build && cabal build --copy-bins \ - --local-bin-path /opt/build --resolver lts-22.6 # --system-ghc +RUN cd /opt/build && cabal build --copy-bins --local-bin-path /opt/build FROM --platform=linux/amd64 ubuntu:22.04 From 4c0d52155558545125e6704fb6b398088c55f663 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 15:21:24 +0800 Subject: [PATCH 24/53] fix docker --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index 4638b280..eba47d87 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,7 +1,7 @@ FROM haskell:slim-bullseye as build RUN mkdir /opt/build COPY . /opt/build -RUN cd /opt/build && cabal build --copy-bins --local-bin-path /opt/build +RUN cd /opt/build && cabal install --installdir=/opt/build --overwrite-policy=always FROM --platform=linux/amd64 ubuntu:22.04 From 70b890697e67ea79dfa810608d458e656ccf8e4e Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 15:32:26 +0800 Subject: [PATCH 25/53] udpate df --- Dockerfile | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/Dockerfile b/Dockerfile index eba47d87..e1ebe112 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,10 +1,10 @@ FROM haskell:slim-bullseye as build RUN mkdir /opt/build COPY . /opt/build -RUN cd /opt/build && cabal install --installdir=/opt/build --overwrite-policy=always +RUN cd /opt/build && cabal install -FROM --platform=linux/amd64 ubuntu:22.04 +FROM --platform=linux/amd64 ubuntu:25.04 RUN mkdir -p /opt/myapp ARG BINARY_PATH WORKDIR /opt/myapp @@ -14,7 +14,7 @@ RUN apt-get update && apt-get install -y \ # NOTICE THIS LINE -COPY --from=build /opt/build/Hastructure-exe . +COPY --from=build /opt/build/dist/Hastructure-exe . COPY --from=build /opt/build/config.yml . COPY --from=build /opt/build/swagger.json . #COPY config.yml /opt/myapp From 1c8817e0ff494ee237c21b52a270c353b7d7a6ac Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 15:37:03 +0800 Subject: [PATCH 26/53] fix df --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index e1ebe112..dfe853df 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,7 +1,7 @@ FROM haskell:slim-bullseye as build RUN mkdir /opt/build COPY . /opt/build -RUN cd /opt/build && cabal install +RUN cd /opt/build && cabal update && cabal install FROM --platform=linux/amd64 ubuntu:25.04 From b6270697d71498f65d41733b8ad6794f7edfe499 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 15:56:26 +0800 Subject: [PATCH 27/53] fix df --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index dfe853df..a02cb2ff 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,4 +1,4 @@ -FROM haskell:slim-bullseye as build +FROM haskell:9.8.4-slim-bullseye as build RUN mkdir /opt/build COPY . /opt/build RUN cd /opt/build && cabal update && cabal install From 1be016a86b7294595be61587ed3567915adcd8e8 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 1 Apr 2025 16:19:33 +0800 Subject: [PATCH 28/53] df --- Dockerfile | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Dockerfile b/Dockerfile index a02cb2ff..0461a30e 100644 --- a/Dockerfile +++ b/Dockerfile @@ -14,7 +14,7 @@ RUN apt-get update && apt-get install -y \ # NOTICE THIS LINE -COPY --from=build /opt/build/dist/Hastructure-exe . +COPY --from=build /root/.local/bin/Hastructure-exe . COPY --from=build /opt/build/config.yml . COPY --from=build /opt/build/swagger.json . #COPY config.yml /opt/myapp From 0aad9cf6b64f846484aebb35fae8c203a7ea3d16 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Wed, 2 Apr 2025 13:20:46 +0800 Subject: [PATCH 29/53] refactor Z-bond due prin --- Hastructure.cabal | 3 --- app/Main.hs | 1 - app/MainBase.hs | 1 - src/Deal/DealQuery.hs | 4 +++- 4 files changed, 3 insertions(+), 6 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 46c25fa0..61c2ae9b 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -83,7 +83,6 @@ library , hashable , ieee754 , lens - , lucid , math-functions , monad-loops , mtl @@ -137,7 +136,6 @@ executable Hastructure-exe , http-types , ieee754 , lens - , lucid , math-functions , monad-loops , mtl @@ -208,7 +206,6 @@ test-suite Hastructure-test , hashable , ieee754 , lens - , lucid , math-functions , monad-loops , mtl diff --git a/app/Main.hs b/app/Main.hs index 157d23cf..4e502fce 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -44,7 +44,6 @@ import GHC.Generics import GHC.Real import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Char8 as BS -import Lucid hiding (type_) import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Middleware.Cors diff --git a/app/MainBase.hs b/app/MainBase.hs index 05067658..1e526e37 100644 --- a/app/MainBase.hs +++ b/app/MainBase.hs @@ -49,7 +49,6 @@ import GHC.Generics import GHC.Real import qualified Data.ByteString.Lazy.Char8 as BL8 import qualified Data.ByteString.Char8 as BS -import Lucid hiding (type_) import Network.Wai import Network.Wai.Handler.Warp import Network.Wai.Middleware.Cors diff --git a/src/Deal/DealQuery.hs b/src/Deal/DealQuery.hs index 25bfad62..4f56de0e 100644 --- a/src/Deal/DealQuery.hs +++ b/src/Deal/DealQuery.hs @@ -94,7 +94,9 @@ calcBondTargetBalance t d b = L.Sequential -> Right 0 L.Lockout ld | d >= ld -> Right 0 | otherwise -> Right $ L.bndBalance b - L.Z -> Right 0 + L.Z + | all (==True) (isPaidOff <$> (Map.elems (Map.delete (L.bndName b) (bonds t)))) -> Right 0 + | otherwise -> Right $ L.bndBalance b L.IO -> Right 0 L.Equity -> Right 0 L.PAC _target -> Right $ getValOnByDate _target d From 72cfcefb369d4c6ab1f4f5edc81b7f7047e61a5e Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Thu, 3 Apr 2025 02:26:58 +0800 Subject: [PATCH 30/53] clean up --- src/CreditEnhancement.hs | 30 +++++++++++++----------------- src/Lib.hs | 6 +----- src/Types.hs | 10 +--------- src/Waterfall.hs | 13 +++---------- swagger.json | 2 +- 5 files changed, 19 insertions(+), 42 deletions(-) diff --git a/src/CreditEnhancement.hs b/src/CreditEnhancement.hs index 0aaab076..e71863ab 100644 --- a/src/CreditEnhancement.hs +++ b/src/CreditEnhancement.hs @@ -7,7 +7,7 @@ module CreditEnhancement (LiqFacility(..),LiqSupportType(..),buildLiqResetAction,buildLiqRateResetAction ,LiquidityProviderName,draw,repay,accrueLiqProvider ,LiqDrawType(..),LiqRepayType(..),LiqCreditCalc(..) - ,consolStmt,CreditDefaultSwap(..),CDSType(..) + ,consolStmt,CreditDefaultSwap(..), ) where @@ -256,30 +256,22 @@ instance IR.UseRate LiqFacility where getIndex liq = head <$> IR.getIndexes liq - -data CDSType = CoverageAttachDetach Balance Balance - | CoverageAttach Balance - | CoverageDetach Balance - | AllCoverage - deriving (Show, Generic, Eq, Ord) - data CreditDefaultSwap = CDS { cdsName :: String - ,cdsType :: CDSType + ,cdsAccrue :: Maybe DatePattern - ,cdsInsure :: DealStats -- ^ the coverage - ,cdsCollectDue :: Balance -- ^ the amount to collect from CDS + ,cdsCoverage :: DealStats -- ^ the coverage + ,cdsDue :: Balance -- ^ the amount to collect from CDS,paid to SPV as cure to loss incurred by SPV + ,cdsLast :: Maybe Date -- ^ last date of Due calc ,cdsPremiumRefBalance :: DealStats -- ^ how notional balance is calculated - ,cdsPremiumNotional :: Balance -- ^ the balance to calculate premium - ,cdsPremiumRate :: IRate -- ^ the rate to calculate premium - ,cdsRateType :: Maybe IR.RateType -- ^ interest rate type + ,cdsRateType :: IR.RateType -- ^ interest rate type ,cdsPremiumDue :: Balance -- ^ the due premium to payout from SPV + ,cdsLastCalcDate :: Maybe Date -- ^ last calculate date on net cash - ,cdsLastCalcDate :: Maybe Date -- ^ last calculate date on net cash - + ,cdsSettle :: Maybe DatePattern ,cdsSettleDate :: Maybe Date -- ^ last setttle date on net cash ,cdsNetCash :: Balance -- ^ the net cash to settle ,negative means SPV pay to CDS, positive means CDS pay to SPV @@ -288,7 +280,11 @@ data CreditDefaultSwap = CDS { ,cdsStmt :: Maybe Statement } deriving (Show, Generic, Eq, Ord) - +instance IR.UseRate CreditDefaultSwap where + getIndexes cds@CDS{cdsRateType = rt} + = case rt of + (IR.Floater _ idx _ _ _ _ _ _) -> Just [idx] + (IR.Fix _ _) -> Nothing $(deriveJSON defaultOptions ''LiqRepayType) diff --git a/src/Lib.hs b/src/Lib.hs index e04799c2..e535c5b4 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -34,14 +34,10 @@ import Types import Control.Lens import Data.List.Lens import Control.Lens.TH --- import Deal.DealType - - import Debug.Trace debug = flip trace - periodRateFromAnnualRate :: Period -> IRate -> IRate periodRateFromAnnualRate Annually annual_rate = annual_rate periodRateFromAnnualRate Monthly annual_rate = annual_rate / 12 @@ -55,7 +51,6 @@ addD d calendarMonth = T.addGregorianDurationClip T.calendarMonth d getIntervalDays :: [Date] -> [Int] getIntervalDays ds = zipWith daysBetweenI (init ds) (tail ds) - -- = map (\(x,y)-> (fromIntegral (T.diffDays y x))) $ zip (init ds) (tail ds) -- get fractional years from a set of dates getIntervalFactors :: [Date] -> [Rate] @@ -135,6 +130,7 @@ mkTs ps = FloatCurve [ TsPoint d v | (d,v) <- ps] mkRateTs :: [(Date,IRate)] -> Ts mkRateTs ps = IRateCurve [ TsPoint d v | (d,v) <- ps] + getValOnByDate :: Ts -> Date -> Balance getValOnByDate (BalanceCurve dps) d = case find (\(TsPoint _d _) -> ( d >= _d )) (reverse dps) of diff --git a/src/Types.hs b/src/Types.hs index 6463a2f0..9d073bd0 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -31,7 +31,7 @@ module Types ,PricingMethod(..),CustomDataType(..),ResultComponent(..),DealStatType(..) ,ActionWhen(..),DealStatFields(..) ,getDealStatType,getPriceValue,preHasTrigger - ,MyRatio,HowToPay(..),ApplyRange(..),BondPricingMethod(..) + ,MyRatio,HowToPay(..),BondPricingMethod(..) ,_BondTxn ,_InspectBal ) @@ -240,8 +240,6 @@ data Period = Daily type DateVector = (Date, DatePattern) - - data RoundingBy a = RoundCeil a | RoundFloor a deriving (Show, Generic, Eq, Ord, Read) @@ -299,7 +297,6 @@ data PerCurve a = CurrentVal [PerPoint a] getValFromPerCurve :: PerCurve a -> DateDirection -> CutoffType -> Int -> Maybe a getValFromPerCurve (WithTrailVal []) _ _ _ = Nothing getValFromPerCurve (CurrentVal []) _ _ _ = Nothing - getValFromPerCurve (CurrentVal (v:vs)) Future p i = let cmp = case p of @@ -361,11 +358,6 @@ data DateDirection = Future | Past deriving (Show,Read,Generic) -data ApplyRange = ByAll - | ByIndexes [Int] - | ByKeys [String] - deriving (Show,Read,Generic) - class TimeSeries ts where cmp :: ts -> ts -> Ordering diff --git a/src/Waterfall.hs b/src/Waterfall.hs index 356a8302..5d3eeeb8 100644 --- a/src/Waterfall.hs +++ b/src/Waterfall.hs @@ -18,8 +18,6 @@ import Data.Hashable import Data.Fixed import GHC.Generics -import Accounts (Account) -import Expense import Types import Revolving import Stmt (TxnComment(..)) @@ -27,9 +25,7 @@ import qualified Lib as L import qualified Call as C import qualified CreditEnhancement as CE import qualified Hedge as HE -import CreditEnhancement (LiquidityProviderName) -import Ledger (Ledger,LedgerName) - +import Ledger (LedgerName) data BookType = PDL BookDirection DealStats [(LedgerName,DealStats)] -- Reverse PDL Debit reference, [(name,cap reference)] @@ -38,7 +34,7 @@ data BookType = PDL BookDirection DealStats [(LedgerName,DealStats)] -- Reverse deriving (Show,Generic,Eq,Ord) data ExtraSupport = SupportAccount AccountName (Maybe BookLedger) -- ^ if there is deficit, draw another account to pay the shortfall - | SupportLiqFacility LiquidityProviderName -- ^ if there is deficit, draw facility's available credit to pay the shortfall + | SupportLiqFacility CE.LiquidityProviderName -- ^ if there is deficit, draw facility's available credit to pay the shortfall | MultiSupport [ExtraSupport] -- ^ if there is deficit, draw multiple supports (by sequence in the list) to pay the shortfall | WithCondition Pre ExtraSupport -- ^ support only available if Pre is true deriving (Show,Generic,Eq,Ord) @@ -55,7 +51,6 @@ data PayOrderBy = ByName type BookLedger = (BookDirection, LedgerName) type BookLedgers = (BookDirection, [LedgerName]) - data Action = -- Accounts Transfer (Maybe Limit) AccountName AccountName (Maybe TxnComment) @@ -140,6 +135,4 @@ $(deriveJSON defaultOptions ''BookType) $(deriveJSON defaultOptions ''ExtraSupport) $(deriveJSON defaultOptions ''PayOrderBy) $(deriveJSON defaultOptions ''Action) -$(deriveJSON defaultOptions ''CollectionRule) - - +$(deriveJSON defaultOptions ''CollectionRule) \ No newline at end of file diff --git a/swagger.json b/swagger.json index 8f4498b0..7de859d9 100644 --- a/swagger.json +++ b/swagger.json @@ -20633,7 +20633,7 @@ "name": "BSD 3" }, "title": "Hastructure API", - "version": "0.45.1" + "version": "0.45.2" }, "openapi": "3.0.0", "paths": { From 6232a66ad6d4955127398841acfbc2f66cadc7d2 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 5 Apr 2025 01:00:56 +0800 Subject: [PATCH 31/53] enable maxSpread --- Hastructure.cabal | 2 ++ app/Main.hs | 11 ++++++----- 2 files changed, 8 insertions(+), 5 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 61c2ae9b..48455140 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -24,6 +24,8 @@ source-repository head type: git location: https://github.com/yellowbean/Hastructure +with-compiler: ghc-9.8.2 + library exposed-modules: Accounts diff --git a/app/Main.hs b/app/Main.hs index 4e502fce..42a40a70 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -309,13 +309,14 @@ testBySpread (dt,mPAssump,runAssump) (bn,bnds) f Right (d, mPoolCfMap, mResult, pResult) -> let v = getPriceValue $ pResult Map.! bn - bond = dtToBonds d Map.! bn + bondBal = L.getOriginBalance $ dtToBonds d Map.! bn in + (fromRational . toRational) $ bondBal - v -- if L.getCurBalance bond > 0 then - if True then - 1.0 - else - (fromRational . toRational) (v - L.getOriginBalance bond) + -- if True then + -- 1.0 + -- else + -- (fromRational . toRational) (v - bondBal) Left errorMsg -> error $ "Error in test fun for spread testing" ++ show errorMsg runRootFinderBy :: RootFindReq -> Handler (Either String RootFindResp) From 3fcbdc4e9ec84cba02e490ef9915a6221bef5dba Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 5 Apr 2025 01:02:17 +0800 Subject: [PATCH 32/53] bump version to-> < 0.45.3 > --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 42a40a70..95ea22fb 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.45.2" +version1 = Version "0.45.3" wrapRun :: DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From a27a869043cfadf3cb8592e62f3cb91e5f36a70d Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sun, 6 Apr 2025 21:49:04 +0800 Subject: [PATCH 33/53] [root finder] finalise new spread finder --- app/Main.hs | 19 +++++++------------ app/MainBase.hs | 2 +- swagger.json | 17 ++--------------- 3 files changed, 10 insertions(+), 28 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 95ea22fb..8916a17f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -300,10 +300,10 @@ testByDefault dt assumps nonPerfAssump@AP.NonPerfAssumption{AP.revolving = mRevo -- add spread to bonds till PV of bond (discounted by pricing assumption) equals to face value -- with constraint that all liabilities are paid off -testBySpread :: DealRunInput -> (BondName,[BondName]) -> Double -> Double -testBySpread (dt,mPAssump,runAssump) (bn,bnds) f +testBySpread :: DealRunInput -> BondName -> Double -> Double +testBySpread (dt,mPAssump,runAssump) bn f = let - runResult = wrapRun (modifyDealType (DM.AddSpreadToBonds bnds) f dt) mPAssump runAssump + runResult = wrapRun (modifyDealType (DM.AddSpreadToBonds [bn]) f dt) mPAssump runAssump in case runResult of Right (d, mPoolCfMap, mResult, pResult) -> @@ -311,12 +311,7 @@ testBySpread (dt,mPAssump,runAssump) (bn,bnds) f v = getPriceValue $ pResult Map.! bn bondBal = L.getOriginBalance $ dtToBonds d Map.! bn in - (fromRational . toRational) $ bondBal - v - -- if L.getCurBalance bond > 0 then - -- if True then - -- 1.0 - -- else - -- (fromRational . toRational) (v - bondBal) + (fromRational . toRational) $ bondBal - v -- `debug` ("rate"++ show f ++ "bondBal:"++ show bondBal++"v:"++ show v) Left errorMsg -> error $ "Error in test fun for spread testing" ++ show errorMsg runRootFinderBy :: RootFindReq -> Handler (Either String RootFindResp) @@ -335,15 +330,15 @@ runRootFinderBy (FirstLossReq (dt,Just assumps,nonPerfAssump@AP.NonPerfAssumptio NotBracketed -> Left "Not able to bracket the root" SearchFailed -> Left "Not able to find the root" -runRootFinderBy (MaxSpreadToFaceReq (dt,pAssump,dAssump) (bn,bnds)) +runRootFinderBy (MaxSpreadToFaceReq (dt,pAssump,dAssump) bn) = return $ let itertimes = 500 def = RiddersParam { riddersMaxIter = itertimes, riddersTol = RelTol 0.0001} in - case ridders def (0.00,200.0) (testBySpread (dt,pAssump,dAssump) (bn,bnds)) of + case ridders def (0.00,200.0) (testBySpread (dt,pAssump,dAssump) bn) of Root r -> let - dt' = modifyDealType (DM.AddSpreadToBonds bnds) r dt + dt' = modifyDealType (DM.AddSpreadToBonds [bn]) r dt in Right $ BestSpreadResult r (dtToBonds dt') dt' NotBracketed -> Left "Not able to bracket the root" diff --git a/app/MainBase.hs b/app/MainBase.hs index 1e526e37..5b0e91c8 100644 --- a/app/MainBase.hs +++ b/app/MainBase.hs @@ -166,7 +166,7 @@ type TargetBonds = [BondName] --- 1. make sure all bonds are paid off --- 2. make sure WAC cap is met data RootFindReq = FirstLossReq DealRunInput BondName - | MaxSpreadToFaceReq DealRunInput (BondName,TargetBonds) + | MaxSpreadToFaceReq DealRunInput BondName deriving(Show, Generic) instance ToSchema RootFindReq diff --git a/swagger.json b/swagger.json index 7de859d9..f5c9ee33 100644 --- a/swagger.json +++ b/swagger.json @@ -16341,20 +16341,7 @@ "type": "array" }, { - "items": [ - { - "type": "string" - }, - { - "items": { - "type": "string" - }, - "type": "array" - } - ], - "maxItems": 2, - "minItems": 2, - "type": "array" + "type": "string" } ], "maxItems": 2, @@ -20633,7 +20620,7 @@ "name": "BSD 3" }, "title": "Hastructure API", - "version": "0.45.2" + "version": "0.45.3" }, "openapi": "3.0.0", "paths": { From d2bb0ffb1d9d9219c34f54ab1348828be44913c4 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 8 Apr 2025 11:51:23 +0800 Subject: [PATCH 34/53] minor clean --- src/Deal.hs | 11 +++++------ src/Types.hs | 6 +++++- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/Deal.hs b/src/Deal.hs index 124d714a..c2843478 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -420,7 +420,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= rates calls rAssump - (consolLogsFn [DL.fromList newLogs0,newLogs,eopActionsLog,DL.fromList newLogs1]) -- `debug` ("PoolCollection: Pt 05>> "++ show d++">> context flow>> "++show (runPoolFlow rc3)) + (DL.concat [DL.fromList newLogs0,newLogs,eopActionsLog,DL.fromList newLogs1]) -- `debug` ("PoolCollection: Pt 05>> "++ show d++">> context flow>> "++show (runPoolFlow rc3)) else run t poolFlowMap (Just ads) rates calls rAssump log -- `debug` ("PoolCollection: hit zero pool length"++ show d++"pool"++ (show poolFlowMap)++"collected cf"++ show pt) @@ -459,7 +459,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= rates calls rAssump - (consolLogsFn [newLogsWaterfall,DL.fromList (newLogs2 ++ logsBeforeDist++[RunningWaterfall d waterfallKey])]) -- `debug` ("In RunWaterfall Date"++show d++"after run waterfall 3>>"++ show (pool dRunWithTrigger1)++" status>>"++ show (status dRunWithTrigger1)) + (DL.concat [newLogsWaterfall,DL.fromList (newLogs2 ++ logsBeforeDist++[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 -> @@ -475,7 +475,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= | 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 - (consolLogsFn [newLogsWaterfall,DL.fromList (logsBeforeDist ++ [RunningWaterfall d waterfallKey])]) -- `debug` ("size of logs"++ show (length newLogsWaterfall)++ ">>"++ show d++ show (length logsBeforeDist)) + (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 @@ -522,7 +522,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= _ -> 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 - (consolLogsFn [newLog, DL.fromList ([DealStatusChangeTo d (PreClosing newSt) newSt "By Deal Close"]++logForClosed)]) -- `debug` ("new st at closing"++ show newSt) + (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 @@ -644,7 +644,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= 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 $ consolLogsFn [log,stChangeLogs,newLogsFromTrigger] + run newT {triggers = Just triggerFired} newPool (Just ads) rates calls rAssump $ DL.concat [log,stChangeLogs,newLogsFromTrigger] MakeWhole d spd walTbl -> let @@ -792,7 +792,6 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= _ -> Left $ "Failed to match action on Date"++ show ad where - consolLogsFn = foldl1 DL.append cleanUpActions = Map.findWithDefault [] W.CleanUp (waterfall t) -- `debug` ("Running AD"++show(ad)) remainCollectionNum = Map.elems $ Map.map CF.sizeCashFlowFrame poolFlowMap futureCashToCollect = Map.elems $ Map.map (\pcf -> sum (CF.tsTotalCash <$> view CF.cashflowTxn pcf)) poolFlowMap diff --git a/src/Types.hs b/src/Types.hs index 9d073bd0..0a45bdb7 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -31,7 +31,7 @@ module Types ,PricingMethod(..),CustomDataType(..),ResultComponent(..),DealStatType(..) ,ActionWhen(..),DealStatFields(..) ,getDealStatType,getPriceValue,preHasTrigger - ,MyRatio,HowToPay(..),BondPricingMethod(..) + ,MyRatio,HowToPay(..),BondPricingMethod(..),InvestorAction(..) ,_BondTxn ,_InspectBal ) @@ -358,6 +358,10 @@ data DateDirection = Future | Past deriving (Show,Read,Generic) +data InvestorAction = Buy + | Sell + deriving (Show,Ord,Read,Generic,Eq) + class TimeSeries ts where cmp :: ts -> ts -> Ordering From 473f07c43bd416188d7f32f6fdd9d119501d5e67 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 8 Apr 2025 17:53:52 +0800 Subject: [PATCH 35/53] trigger logs use DList --- src/Deal.hs | 18 +++++++++--------- 1 file changed, 9 insertions(+), 9 deletions(-) diff --git a/src/Deal.hs b/src/Deal.hs index c2843478..e33dc5be 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -348,8 +348,8 @@ runEffects (t@TestDeal{accounts = accMap, fees = feeMap ,status=st, bonds = bond _ -> Left $ "Date:"++ show d++" Failed to match trigger effects: "++show te -- ^ test triggers in the deal and add a log if deal status changed -runTriggers :: Ast.Asset a => (TestDeal a, RunContext a, [ActionOnDate]) -> Date -> DealCycle -> Either String (TestDeal a, RunContext a, [ActionOnDate], [ResultComponent]) -runTriggers (t@TestDeal{status=oldStatus, triggers = Nothing},rc, actions) d dcycle = Right (t, rc, actions, []) +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 @@ -360,12 +360,12 @@ runTriggers (t@TestDeal{status=oldStatus, triggers = Just trgM},rc, actions) d d let triggeredEffects = [ trgEffects _trg | _trg <- Map.elems triggeredTrgs, (trgStatus _trg) ] (newDeal, newRc, newActions, logsFromTrigger) <- foldM (`runEffects` d) (t,rc,actions, DL.empty) triggeredEffects let newStatus = status newDeal - let newLogs = [DealStatusChangeTo d oldStatus newStatus "By trigger"| newStatus /= oldStatus] -- `debug` (">>"++show d++"trigger : new st"++ show newStatus++"old st"++show oldStatus) + 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 - , newLogs++ DL.toList logsFromTrigger) -- `debug` ("New logs from trigger"++ show d ++">>>"++show newLogs) + , 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) @@ -420,7 +420,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= rates calls rAssump - (DL.concat [DL.fromList newLogs0,newLogs,eopActionsLog,DL.fromList newLogs1]) -- `debug` ("PoolCollection: Pt 05>> "++ show d++">> context flow>> "++show (runPoolFlow rc3)) + (DL.concat [newLogs0,newLogs,eopActionsLog,newLogs1]) -- `debug` ("PoolCollection: Pt 05>> "++ show d++">> context flow>> "++show (runPoolFlow rc3)) else run t poolFlowMap (Just ads) rates calls rAssump log -- `debug` ("PoolCollection: hit zero pool length"++ show d++"pool"++ (show poolFlowMap)++"collected cf"++ show pt) @@ -437,8 +437,8 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= in do (dRunWithTrigger0, rc1, ads1, newLogs0) <- runTriggers (t, runContext, ads) d BeginDistributionWF -- `debug` ("In RunWaterfall Date"++show d++"before run trigger>> collected"++ show (pool t)) - let logsBeforeDist = newLogs0++[ WarningMsg (" No waterfall distribution found on date "++show d++" with waterfall key "++show waterfallKey) - | Map.notMember waterfallKey waterfallM ] + 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 @@ -448,7 +448,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= [DealStatusChangeTo d dStatus Called "Call by triggers before waterfall distribution", RunningWaterfall d W.CleanUp] (dealAfterCleanUp, rc_, newLogWaterfall_ ) <- foldM (performActionWrap d) (dRunWithTrigger0, rc1,log) cleanUpActions endingLogs <- Rpt.patchFinancialReports dealAfterCleanUp d newLogWaterfall_ - return (prepareDeal dealAfterCleanUp, DL.append endingLogs (DL.fromList (logsBeforeDist ++newStLogs++[EndRun (Just d) "Clean Up"]))) -- `debug` ("Called ! "++ show d) + return (prepareDeal dealAfterCleanUp, DL.concat [logsBeforeDist,DL.fromList (newStLogs++[EndRun (Just d) "Clean Up"]),endingLogs]) -- `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)) @@ -459,7 +459,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= rates calls rAssump - (DL.concat [newLogsWaterfall,DL.fromList (newLogs2 ++ logsBeforeDist++[RunningWaterfall d waterfallKey])]) -- `debug` ("In RunWaterfall Date"++show d++"after run waterfall 3>>"++ show (pool dRunWithTrigger1)++" status>>"++ show (status dRunWithTrigger1)) + (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 -> From cf264bde628cb1a482f04a43c414f4e1c86ef3a4 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Thu, 10 Apr 2025 14:00:39 +0800 Subject: [PATCH 36/53] Expose bal in FixedAsset; Expose extend periods in FixedAsset --- src/AssetClass/AssetBase.hs | 2 +- src/AssetClass/FixedAsset.hs | 70 ++++++++++++++++++++---------------- src/Assumptions.hs | 4 ++- src/Util.hs | 4 ++- swagger.json | 17 ++++++--- 5 files changed, 59 insertions(+), 38 deletions(-) diff --git a/src/AssetClass/AssetBase.hs b/src/AssetClass/AssetBase.hs index a746fc3a..fd56591d 100644 --- a/src/AssetClass/AssetBase.hs +++ b/src/AssetClass/AssetBase.hs @@ -247,7 +247,7 @@ data AssociateIncome = IncomePerPeriod Balance | IncomePerUnit Balance deriving (Show,Generic,Ord,Eq) -data FixedAsset = FixedAsset OriginalInfo RemainTerms +data FixedAsset = FixedAsset OriginalInfo Balance RemainTerms | Dummy5 deriving (Show,Generic,Eq,Ord) diff --git a/src/AssetClass/FixedAsset.hs b/src/AssetClass/FixedAsset.hs index 7136b4f9..360dc16e 100644 --- a/src/AssetClass/FixedAsset.hs +++ b/src/AssetClass/FixedAsset.hs @@ -36,67 +36,75 @@ import Asset (Asset(projCashflow)) import Assumptions (AssetDelinqPerfAssumption(DummyDelinqAssump)) debug = flip trace -calcAmortAmt ::FixedAsset -> [Balance] + +-- life time schedule amortization amount list +calcAmortAmt ::FixedAsset -> Either String [Balance] calcAmortAmt fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, originTerm=ot - ,residualBalance=rb ,capacity=cap} rt) + ,residualBalance=rb ,capacity=cap} b rt) = case ar of - StraightLine -> replicate ot $ divideBI (ob-rb) ot + StraightLine -> Right $ replicate ot $ divideBI (ob-rb) ot DecliningBalance -> let - r = 1 - (realToFrac (divideBB rb ob)) ** ((1.0/(fromIntegral ot))::Double) - remainBals = scanl (\remainBal x -> remainBal - mulBR remainBal x) ob $ replicate ot (toRational r) + amortizeRate = realToFrac $ 2 % ot + futureBals = scanl (\acc r -> acc * (1 - r)) ob (replicate ot amortizeRate) + amortizeAmounts = paySeqLiabilitiesAmt (ob - rb) $ diffNum futureBals in - [ x-y | (x,y) <- zip (init remainBals) (tail remainBals) ] `debug` ("remain bals"++ show remainBals) - _ -> error ("Not implemented for depreciation rule"++show ar) + Right amortizeAmounts + + _ -> Left ("Not implemented for depreciation rule"++show ar) -calcAmortBals ::FixedAsset -> [Balance] +calcAmortBals ::FixedAsset -> Either String [Balance] calcAmortBals fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, originTerm=ot - ,residualBalance=rb ,capacity=cap} rt) - = scanl (-) ob $ calcAmortAmt fa + ,residualBalance=rb ,capacity=cap} b rt) + = do + bals <- calcAmortAmt fa + return $ scanl (-) ob bals instance Ast.Asset FixedAsset where calcCashflow fa@(FixedAsset {}) asOfDay _ = - fst <$> projCashflow fa asOfDay (A.FixedAssetAssump (mkTs []) (mkTs []), A.DummyDelinqAssump, A.DummyDefaultAssump) Nothing + fst <$> projCashflow fa asOfDay (A.FixedAssetAssump (mkTs []) (mkTs []) Nothing, A.DummyDelinqAssump, A.DummyDefaultAssump) Nothing getCurrentBal fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, originTerm=ot - ,residualBalance=rb ,capacity=cap} rt) - = calcAmortBals fa!!(ot-rt) + ,residualBalance=rb ,capacity=cap} curBal rt) + = curBal resetToOrig fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, originTerm=ot - ,residualBalance=rb ,capacity=cap} rt) - = FixedAsset fai ot + ,residualBalance=rb ,capacity=cap} b rt) + = FixedAsset fai b ot getPaymentDates - (FixedAsset fo@FixedAssetInfo{startDate=sd ,period=p,originTerm=ot} rt) + (FixedAsset fo@FixedAssetInfo{startDate=sd ,period=p,originTerm=ot} _ rt) extra = genDates sd p (ot+extra) projCashflow fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, originTerm=ot - ,residualBalance=rb ,capacity=cap} rt) + ,residualBalance=rb ,capacity=cap} curBalance rt) asOfDay - (A.FixedAssetAssump uCurve pCurve,_,_) + (A.FixedAssetAssump uCurve pCurve mExtPeriods,_,_) _ = let - pdates = lastN rt $ Ast.getPaymentDates fa 0 - cfLength = length pdates - amortizedBals = lastN rt $ calcAmortAmt fa - scheduleBals = lastN rt $ calcAmortBals fa + extPeriods = fromMaybe 0 mExtPeriods + cfLength = rt + extPeriods + pdates = lastN cfLength $ Ast.getPaymentDates fa extPeriods capacityCaps = case cap of - FixedCapacity b -> replicate rt b - CapacityByTerm tbl -> lastN rt $ concat [ replicate i b | (i,b) <- tbl ] + FixedCapacity b -> replicate cfLength b + CapacityByTerm tbl -> lastN cfLength $ concat [ replicate i b | (i,b) <- tbl ] ++ (replicate extPeriods (snd (last tbl))) - cumuDep = sum $ take (ot-rt) (calcAmortAmt fa) utilsVec = getValByDates uCurve Inc pdates units = [ mulBR c u | (u,c) <- zip utilsVec capacityCaps] prices = getValByDates pCurve Inc pdates cash = [ mulBR u p | (p,u) <- zip prices units] - cumuDepreciation = tail $ scanl (+) cumuDep amortizedBals - - txns = zipWith6 CF.FixedFlow pdates scheduleBals amortizedBals cumuDepreciation units cash - futureTxns = cutBy Inc Future asOfDay txns - begBal = CF.buildBegBal futureTxns in - Right $ (CF.CashFlowFrame (begBal,asOfDay,Nothing) $ futureTxns, Map.empty) + do + scheduleAmt <- calcAmortAmt fa + let amortizedBals = lastN cfLength $ scheduleAmt ++ replicate extPeriods 0 + let scheduleBals = tail $ scanl (-) curBalance (amortizedBals ++ [0]) + let cumuDep = sum $ take (ot-rt) scheduleAmt + let cumuDepreciation = tail $ scanl (+) cumuDep amortizedBals + let txns = zipWith6 CF.FixedFlow pdates scheduleBals amortizedBals cumuDepreciation units cash + let futureTxns = cutBy Inc Future asOfDay txns + let begBal = CF.buildBegBal futureTxns + return $ (CF.CashFlowFrame (begBal,asOfDay,Nothing) $ futureTxns, Map.empty) diff --git a/src/Assumptions.hs b/src/Assumptions.hs index 2ac9702b..3424d97b 100644 --- a/src/Assumptions.hs +++ b/src/Assumptions.hs @@ -216,13 +216,15 @@ data AssetDefaultedPerfAssumption = DefaultedRecovery Rate Int [Rate] data AssetDelinqPerfAssumption = DummyDelinqAssump deriving (Show,Generic,Read) + + data AssetPerfAssumption = MortgageAssump (Maybe AssetDefaultAssumption) (Maybe AssetPrepayAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) | MortgageDeqAssump (Maybe AssetDelinquencyAssumption) (Maybe AssetPrepayAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) | LeaseAssump (Maybe AssetDefaultAssumption) LeaseAssetGapAssump LeaseAssetRentAssump LeaseEndType | LoanAssump (Maybe AssetDefaultAssumption) (Maybe AssetPrepayAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) | InstallmentAssump (Maybe AssetDefaultAssumption) (Maybe AssetPrepayAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) | ReceivableAssump (Maybe AssetDefaultAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) - | FixedAssetAssump Ts Ts -- util rate, price + | FixedAssetAssump Ts Ts (Maybe Int) -- util rate, price, (Maybe extend periods) deriving (Show,Generic,Read) diff --git a/src/Util.hs b/src/Util.hs index cc4f1f97..4167300f 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -14,7 +14,7 @@ module Util ,safeDivide,lstToMapByFn,paySequentially,payProRata,mapWithinMap ,payInMap,adjustM,lookupAndApply,lookupAndUpdate,lookupAndApplies ,lookupInMap,selectInMap - ,lookupTuple6 ,lookupTuple7 + ,lookupTuple6 ,lookupTuple7,diffNum -- for debug ,debugOnDate,paySeqM ) @@ -238,6 +238,8 @@ capWith cap xs = [ min cap x | x <- xs ] floorWith :: Ord a => a -> [a] -> [a] floorWith floor xs = [ max x floor | x <- xs] +diffNum :: Num a => [a] -> [a] +diffNum xs = zipWith (-) (init xs) (tail xs) debugLine :: Show a => [a] -> String debugLine xs = "" diff --git a/swagger.json b/swagger.json index f5c9ee33..53511f0c 100644 --- a/swagger.json +++ b/swagger.json @@ -3181,10 +3181,15 @@ }, { "$ref": "#/components/schemas/Ts" + }, + { + "maximum": 9223372036854775807, + "minimum": -9223372036854775808, + "type": "integer" } ], - "maxItems": 2, - "minItems": 2, + "maxItems": 3, + "minItems": 3, "type": "array" }, "tag": { @@ -9975,14 +9980,18 @@ { "$ref": "#/components/schemas/OriginalInfo" }, + { + "multipleOf": 1.0e-2, + "type": "number" + }, { "maximum": 9223372036854775807, "minimum": -9223372036854775808, "type": "integer" } ], - "maxItems": 2, - "minItems": 2, + "maxItems": 3, + "minItems": 3, "type": "array" }, "tag": { From 97a03cf48033176015ca0164cdbaec7900388018 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Fri, 11 Apr 2025 15:52:20 +0800 Subject: [PATCH 37/53] WIP --- src/AssetClass/FixedAsset.hs | 12 +++--- src/Util.hs | 11 +++++- test/MainTest.hs | 2 + test/UT/AssetTest.hs | 76 +++++++++++++++++++++++++++++++++++- test/UT/UtilTest.hs | 20 +++++++++- 5 files changed, 112 insertions(+), 9 deletions(-) diff --git a/src/AssetClass/FixedAsset.hs b/src/AssetClass/FixedAsset.hs index 360dc16e..46bc01b3 100644 --- a/src/AssetClass/FixedAsset.hs +++ b/src/AssetClass/FixedAsset.hs @@ -42,12 +42,14 @@ calcAmortAmt ::FixedAsset -> Either String [Balance] calcAmortAmt fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, originTerm=ot ,residualBalance=rb ,capacity=cap} b rt) = case ar of - StraightLine -> Right $ replicate ot $ divideBI (ob-rb) ot + StraightLine -> Right $ replicate ot $ divideBI (b-rb) rt DecliningBalance -> let amortizeRate = realToFrac $ 2 % ot - futureBals = scanl (\acc r -> acc * (1 - r)) ob (replicate ot amortizeRate) - amortizeAmounts = paySeqLiabilitiesAmt (ob - rb) $ diffNum futureBals + -- schedule amortized balance (base on original balance) + futureBals' = lastN (succ rt) $ scanl (\acc r -> acc * (1 - r)) ob (replicate ot amortizeRate) + futureBals = scaleByFstElement b futureBals' + amortizeAmounts = paySeqLiabilitiesAmt (ob - rb) $ diffNum futureBals -- `debug` ("Size of amoztized balance"++ show (length futureBals') ++">>"++ show futureBals') in Right amortizeAmounts @@ -99,9 +101,9 @@ instance Ast.Asset FixedAsset where in do scheduleAmt <- calcAmortAmt fa - let amortizedBals = lastN cfLength $ scheduleAmt ++ replicate extPeriods 0 + let amortizedBals = lastN cfLength $ scheduleAmt ++ replicate extPeriods 0 `debug` (" size of amortize"++ show (length scheduleAmt)) let scheduleBals = tail $ scanl (-) curBalance (amortizedBals ++ [0]) - let cumuDep = sum $ take (ot-rt) scheduleAmt + let cumuDep = ob - curBalance let cumuDepreciation = tail $ scanl (+) cumuDep amortizedBals let txns = zipWith6 CF.FixedFlow pdates scheduleBals amortizedBals cumuDepreciation units cash let futureTxns = cutBy Inc Future asOfDay txns diff --git a/src/Util.hs b/src/Util.hs index 4167300f..8281cdab 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -13,7 +13,7 @@ module Util ,lastOf,findBox,safeDivide', safeDiv ,safeDivide,lstToMapByFn,paySequentially,payProRata,mapWithinMap ,payInMap,adjustM,lookupAndApply,lookupAndUpdate,lookupAndApplies - ,lookupInMap,selectInMap + ,lookupInMap,selectInMap,scaleByFstElement ,lookupTuple6 ,lookupTuple7,diffNum -- for debug ,debugOnDate,paySeqM @@ -241,6 +241,15 @@ floorWith floor xs = [ max x floor | x <- xs] diffNum :: Num a => [a] -> [a] diffNum xs = zipWith (-) (init xs) (tail xs) +scaleByFstElement :: forall a. Fractional a => a -> [a] -> [a] +scaleByFstElement x [] = [] +scaleByFstElement y (b:xs) = + let + s = y/b + in + y:[ x * s | x <- xs ] + + debugLine :: Show a => [a] -> String debugLine xs = "" diff --git a/test/MainTest.hs b/test/MainTest.hs index 9b8669eb..38143a03 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -48,6 +48,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,AT.delinqMortgageTest ,AT.nonPayMortgageTest ,AT.receivableTest + ,AT.fixedAssetTest ,CFT.cfTests ,CFT.tsSplitTests ,CFT.testMergePoolCf @@ -92,6 +93,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,UtilT.tableTest ,UtilT.lastOftest ,UtilT.paySeqTest + ,UtilT.scaleListTest ,AccT.intTests ,AccT.investTests ,AccT.reserveAccTest diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index 630de243..0031045d 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -1,5 +1,5 @@ module UT.AssetTest(mortgageTests,mortgageCalcTests,loanTests,leaseTests,installmentTest,armTest,ppyTest - ,delinqScheduleCFTest,delinqMortgageTest,btlMortgageTest,nonPayMortgageTest,receivableTest) + ,delinqScheduleCFTest,delinqMortgageTest,btlMortgageTest,nonPayMortgageTest,receivableTest,fixedAssetTest) where import Test.Tasty @@ -834,3 +834,77 @@ receivableTest = ((`CF.cfAt` 0) <$> (fst <$> Ast.projCashflow invoice0 (L.toDate "20240501") invoiceAssump Nothing)) ] +fixedAssetTest = + let + assetInfo = AB.FixedAssetInfo (L.toDate "20250101") 11000 1000 10 Monthly AB.StraightLine (AB.FixedCapacity 100) + assetInfo2 = AB.FixedAssetInfo (L.toDate "20250101") 10000 1000 10 Monthly AB.DecliningBalance (AB.FixedCapacity 100) + asset = AB.FixedAsset assetInfo 11000 10 + priceCurve = L.mkTs [(L.toDate "20250101",50), (L.toDate "20251231", 150)] + utilCurve = L.mkTs [(L.toDate "20250101",1.0), (L.toDate "20251231", 1.0)] + in + testGroup "fixed Asset Test" [ + testCase "StraightLine:init Asset: size" $ + assertEqual "StraightLine:init Asset: size" + (Right 10) + (let + asset1 = asset + in + (CF.sizeCashFlowFrame <$> (fst <$> (Ast.projCashflow asset1 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ,testCase "StraightLine:init Asset with ext " $ + assertEqual "StraightLine:init Asset" + (Right (Just (CF.FixedFlow (L.toDate "20260201") 1000 0 10000 100.0 15000.0))) + (let + asset1 = asset + in + ((`CF.cfAt` 12) <$> (fst <$> (Ast.projCashflow asset1 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve (Just 3)) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ,testCase "StraightLine:init Asset with diff cur balance " $ + assertEqual "StraightLine:init Asset" + (Right (Just (CF.FixedFlow (L.toDate "20250701") 3400 600.0 7600 100.0 5000.0))) + (let + asset2 = AB.FixedAsset assetInfo 4000 5 + in + ((`CF.cfAt` 0) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ,testCase "StraightLine:init Asset with diff cur balance " $ + assertEqual "StraightLine:init Asset" + (Right (Just (CF.FixedFlow (L.toDate "20260201") 1000 0 10000 100.0 15000.0))) + (let + asset2 = AB.FixedAsset assetInfo 4000 5 + in + ((`CF.cfAt` 7) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve (Just 3)) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ,testCase "StraightLine:init Asset with diff cur balance " $ + assertEqual "StraightLine:init Asset" + (Right (Just (CF.FixedFlow (L.toDate "20251101") 1000 3000 10000 100.0 5000.0))) + (let + asset2 = AB.FixedAsset assetInfo 4000 1 + in + ((`CF.cfAt` 0) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve (Just 3)) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ,testCase "Double Decline" $ + assertEqual "Double Decline:size " + (Right 10) + (let + asset2 = AB.FixedAsset assetInfo2 10000 10 + in + (CF.sizeCashFlowFrame <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ,testCase "Double Decline" $ + assertEqual "Double Decline:init Asset" + (Right (Just (CF.FixedFlow (L.toDate "20250201") 8000 2000 2000 100.0 5000.0))) + (let + asset2 = AB.FixedAsset assetInfo2 10000 10 + in + ((`CF.cfAt` 0) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve (Just 3)) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ,testCase "Double Decline" $ + assertEqual "Double Decline:init Asset :last " + (Right (Just (CF.FixedFlow (L.toDate "20251101") 1073.73 268.44 8926.27 100.0 5000.0))) + (let + asset2 = AB.FixedAsset assetInfo2 10000 10 + in + ((`CF.cfAt` 9) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ] \ No newline at end of file diff --git a/test/UT/UtilTest.hs b/test/UT/UtilTest.hs index e5dcce52..7da0f0d9 100644 --- a/test/UT/UtilTest.hs +++ b/test/UT/UtilTest.hs @@ -1,6 +1,7 @@ module UT.UtilTest(daycountTests1,daycountTests2,daycountTests3,daycountTests4 ,tsTest,ts2Test,ts3Test,dateVectorPatternTest,paddingTest,dateSliceTest - ,capTest,roundingTest,sliceTest,splitTsTest,tableTest,lastOftest,paySeqTest)--,daycountTests3,daycountTests4) + ,capTest,roundingTest,sliceTest,splitTsTest,tableTest,lastOftest,paySeqTest + ,scaleListTest)--,daycountTests3,daycountTests4) where import Test.Tasty @@ -628,4 +629,19 @@ paySeqTest = , bnd2{L.bndBalance = 0,L.bndStmt = Just (Statement (DL.fromList ([BondTxn d1 0.00 0.00 0.00 0.000000 0.00 0.00 0.00 Nothing (WriteOff "B" 100.00)])))} ],30)) (paySeqM d1 230 L.bndBalance (L.writeOff d1) (Right []) [bnd1,bnd2]) - ] \ No newline at end of file + ] + +scaleListTest = + let + a = 1 + in + testGroup "scale list test" + [ testCase "" $ + assertEqual "scale list" + [50.0, 37.5, 25.0] + $ scaleByFstElement 50 [200.0,150.0,100] + , testCase "" $ + assertEqual "scale list" + [] + $ scaleByFstElement 50 [] + ] \ No newline at end of file From 706e4b159c6bafd3f83e698b13cfab4c22103a77 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 12 Apr 2025 21:47:22 +0800 Subject: [PATCH 38/53] Finalized DDB in Fixed Asset --- src/AssetClass/FixedAsset.hs | 19 +++++++++++-------- test/UT/AssetTest.hs | 27 ++++++++++++++++++++++----- 2 files changed, 33 insertions(+), 13 deletions(-) diff --git a/src/AssetClass/FixedAsset.hs b/src/AssetClass/FixedAsset.hs index 46bc01b3..6b7360ab 100644 --- a/src/AssetClass/FixedAsset.hs +++ b/src/AssetClass/FixedAsset.hs @@ -46,12 +46,16 @@ calcAmortAmt fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, ori DecliningBalance -> let amortizeRate = realToFrac $ 2 % ot - -- schedule amortized balance (base on original balance) - futureBals' = lastN (succ rt) $ scanl (\acc r -> acc * (1 - r)) ob (replicate ot amortizeRate) - futureBals = scaleByFstElement b futureBals' - amortizeAmounts = paySeqLiabilitiesAmt (ob - rb) $ diffNum futureBals -- `debug` ("Size of amoztized balance"++ show (length futureBals') ++">>"++ show futureBals') + futureBals' = scaleByFstElement b $ lastN (succ rt) $ scanl (\acc r -> acc * (1 - r)) ob (replicate ot amortizeRate) + -- straigh lines + futureBals'' = scanl + (\acc (bal',amt',rt') -> + (acc - (max amt' (divideBI (acc - rb) (rt - rt')))) + ) + (head futureBals') + (zip3 futureBals' (diffNum futureBals') [0..succ rt]) in - Right amortizeAmounts + Right (diffNum futureBals'') _ -> Left ("Not implemented for depreciation rule"++show ar) @@ -101,12 +105,11 @@ instance Ast.Asset FixedAsset where in do scheduleAmt <- calcAmortAmt fa - let amortizedBals = lastN cfLength $ scheduleAmt ++ replicate extPeriods 0 `debug` (" size of amortize"++ show (length scheduleAmt)) + let amortizedBals = lastN cfLength $ scheduleAmt ++ replicate extPeriods 0 let scheduleBals = tail $ scanl (-) curBalance (amortizedBals ++ [0]) let cumuDep = ob - curBalance let cumuDepreciation = tail $ scanl (+) cumuDep amortizedBals let txns = zipWith6 CF.FixedFlow pdates scheduleBals amortizedBals cumuDepreciation units cash let futureTxns = cutBy Inc Future asOfDay txns let begBal = CF.buildBegBal futureTxns - return $ (CF.CashFlowFrame (begBal,asOfDay,Nothing) $ futureTxns, Map.empty) - + return $ (CF.CashFlowFrame (begBal,asOfDay,Nothing) $ futureTxns, Map.empty) \ No newline at end of file diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index 0031045d..aa49ef26 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -883,7 +883,7 @@ fixedAssetTest = in ((`CF.cfAt` 0) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") ((A.FixedAssetAssump utilCurve priceCurve (Just 3)) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) - ,testCase "Double Decline" $ + ,testCase "Double Decline:size" $ assertEqual "Double Decline:size " (Right 10) (let @@ -891,7 +891,7 @@ fixedAssetTest = in (CF.sizeCashFlowFrame <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) - ,testCase "Double Decline" $ + ,testCase "Double Decline:first row with full cur bal" $ assertEqual "Double Decline:init Asset" (Right (Just (CF.FixedFlow (L.toDate "20250201") 8000 2000 2000 100.0 5000.0))) (let @@ -899,12 +899,29 @@ fixedAssetTest = in ((`CF.cfAt` 0) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") ((A.FixedAssetAssump utilCurve priceCurve (Just 3)) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) - ,testCase "Double Decline" $ - assertEqual "Double Decline:init Asset :last " - (Right (Just (CF.FixedFlow (L.toDate "20251101") 1073.73 268.44 8926.27 100.0 5000.0))) + ,testCase "Double Decline:init Asset :last" $ + assertEqual "Double Decline:init Asset :last" + (Right (Just (CF.FixedFlow (L.toDate "20251101") 1000.0 338.86 9000.0 100.0 5000.0))) (let asset2 = AB.FixedAsset assetInfo2 10000 10 in ((`CF.cfAt` 9) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + ,testCase "Double Decline:init Asset: with ext periods" $ + assertEqual "Double Decline:init Asset: with ext periods" + (Right (Just (CF.FixedFlow (L.toDate "20260201") 1000.00 0.0 9000 100.0 15000.0))) + (let + asset2 = AB.FixedAsset assetInfo2 10000 10 + in + ((`CF.cfAt` 12) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") + ((A.FixedAssetAssump utilCurve priceCurve (Just 3)) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + + -- ,testCase "Double Decline" $ + -- assertEqual "Double Decline:init Asset : current with less balance " + -- (Right (Just (CF.FixedFlow (L.toDate "20251101") 1073.73 268.44 8926.27 100.0 5000.0))) + -- (let + -- asset2 = AB.FixedAsset assetInfo2 5000 5 + -- in + -- ((`CF.cfAt` 9) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") + -- ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) ] \ No newline at end of file From 063726d82aee267046dc4e2ea0740d0544b1a678 Mon Sep 17 00:00:00 2001 From: Shawn Zhang Date: Tue, 15 Apr 2025 14:49:11 +0800 Subject: [PATCH 39/53] Update CHANGELOG.md Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- CHANGELOG.md | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index a3bd3253..717505cc 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,8 +4,7 @@ ## 0.45.2 ### 2025-04-01 -* ENHANCE: Performance optimaization by replace `List` with `DList`. -* ENHANCE: remove `stack` as build tool +* ENHANCE: Performance optimization by replace `List` with `DList`. * ENHANCE: In `inspection` ,expose `IsOustanding` `HasPassedMaturity` in `Pre` From 8e650546e981bad6daabe1848bf36467ada46efb Mon Sep 17 00:00:00 2001 From: Shawn Zhang Date: Tue, 15 Apr 2025 14:49:18 +0800 Subject: [PATCH 40/53] Update CHANGELOG.md Co-authored-by: Copilot <175728472+Copilot@users.noreply.github.com> --- CHANGELOG.md | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 717505cc..8bc85de2 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,10 +5,7 @@ ## 0.45.2 ### 2025-04-01 * ENHANCE: Performance optimization by replace `List` with `DList`. -* ENHANCE: In `inspection` ,expose `IsOustanding` `HasPassedMaturity` in `Pre` - - - +* ENHANCE: In `inspection` ,expose `IsOutstanding` `HasPassedMaturity` in `Pre` ## 0.45.1 ### 2025-03-25 * FIX: in `Pricing/IRR`, error when holding position is too small From 15a836686ed2339419a85373a4148c4355600666 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Fri, 25 Apr 2025 17:08:35 +0800 Subject: [PATCH 41/53] UT-pass --- app/Main.hs | 26 ++++-- app/MainBase.hs | 2 +- src/AssetClass/AssetBase.hs | 17 ++-- src/AssetClass/Lease.hs | 163 ++++++++++++++++++++++-------------- src/Deal/DealMod.hs | 6 +- src/Types.hs | 1 - test/UT/AssetTest.hs | 69 +++++++++------ 7 files changed, 172 insertions(+), 112 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 8916a17f..8057bb41 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -300,18 +300,28 @@ testByDefault dt assumps nonPerfAssump@AP.NonPerfAssumption{AP.revolving = mRevo -- add spread to bonds till PV of bond (discounted by pricing assumption) equals to face value -- with constraint that all liabilities are paid off -testBySpread :: DealRunInput -> BondName -> Double -> Double -testBySpread (dt,mPAssump,runAssump) bn f +testBySpread :: DealRunInput -> (BondName,Bool,Bool) -> Double -> Double +testBySpread (dt,mPAssump,runAssump) (bn,otherBondFlag,otherFeeFlag) f = let - runResult = wrapRun (modifyDealType (DM.AddSpreadToBonds [bn]) f dt) mPAssump runAssump + runResult = wrapRun (modifyDealType (DM.AddSpreadToBonds bn) f dt) mPAssump runAssump in case runResult of - Right (d, mPoolCfMap, mResult, pResult) -> + Right (d@DB.TestDeal{DB.fees = feeMap,DB.bonds = bndMap}, mPoolCfMap, mResult, pResult) -> let + -- bnds + otherBondsName = [] + -- check fees/other bonds + otherBondOustanding False = 0.0 + otherBondOustanding True = sum $ L.getOutstandingAmount <$> Map.elems bndMap + feeOutstanding True = sum $ L.getOutstandingAmount <$> Map.elems feeMap + feeOutstanding False = 0.0 v = getPriceValue $ pResult Map.! bn bondBal = L.getOriginBalance $ dtToBonds d Map.! bn in - (fromRational . toRational) $ bondBal - v -- `debug` ("rate"++ show f ++ "bondBal:"++ show bondBal++"v:"++ show v) + if (otherBondOustanding otherBondFlag+feeOutstanding otherFeeFlag) > 0 then + -1 + else + (fromRational . toRational) $ bondBal - v -- `debug` ("rate"++ show f ++ "bondBal:"++ show bondBal++"v:"++ show v) Left errorMsg -> error $ "Error in test fun for spread testing" ++ show errorMsg runRootFinderBy :: RootFindReq -> Handler (Either String RootFindResp) @@ -330,15 +340,15 @@ runRootFinderBy (FirstLossReq (dt,Just assumps,nonPerfAssump@AP.NonPerfAssumptio NotBracketed -> Left "Not able to bracket the root" SearchFailed -> Left "Not able to find the root" -runRootFinderBy (MaxSpreadToFaceReq (dt,pAssump,dAssump) bn) +runRootFinderBy (MaxSpreadToFaceReq (dt,pAssump,dAssump) bns chkOtherBnds chkOtherFees) = return $ let itertimes = 500 def = RiddersParam { riddersMaxIter = itertimes, riddersTol = RelTol 0.0001} in - case ridders def (0.00,200.0) (testBySpread (dt,pAssump,dAssump) bn) of + case ridders def (0.00,200.0) (testBySpread (dt,pAssump,dAssump) (bns,chkOtherBnds,chkOtherFees)) of Root r -> let - dt' = modifyDealType (DM.AddSpreadToBonds [bn]) r dt + dt' = modifyDealType (DM.AddSpreadToBonds bns) r dt in Right $ BestSpreadResult r (dtToBonds dt') dt' NotBracketed -> Left "Not able to bracket the root" diff --git a/app/MainBase.hs b/app/MainBase.hs index 5b0e91c8..a6c02b03 100644 --- a/app/MainBase.hs +++ b/app/MainBase.hs @@ -166,7 +166,7 @@ type TargetBonds = [BondName] --- 1. make sure all bonds are paid off --- 2. make sure WAC cap is met data RootFindReq = FirstLossReq DealRunInput BondName - | MaxSpreadToFaceReq DealRunInput BondName + | MaxSpreadToFaceReq DealRunInput BondName Bool Bool deriving(Show, Generic) instance ToSchema RootFindReq diff --git a/src/AssetClass/AssetBase.hs b/src/AssetClass/AssetBase.hs index fd56591d..81fe6b27 100644 --- a/src/AssetClass/AssetBase.hs +++ b/src/AssetClass/AssetBase.hs @@ -10,7 +10,7 @@ module AssetClass.AssetBase ,LeaseStepUp(..),AccrualPeriod(..),PrepayPenaltyType(..) ,AmortPlan(..),Loan(..),Mortgage(..),AssetUnion(..),MixedAsset(..),FixedAsset(..) ,AmortRule(..),Capacity(..),AssociateExp(..),AssociateIncome(..),ReceivableFeeType(..),Receivable(..) - ,ProjectedCashflow(..),Obligor(..) + ,ProjectedCashflow(..),Obligor(..),LeaseRateCalc(..) ,calcAssetPrinInt, calcPmt ) where @@ -125,11 +125,7 @@ data PrepayPenaltyType = ByTerm Int Rate Rate -- ^ using penalty rate deriving (Show,Generic,Eq,Ord) data AmortRule = DecliningBalance -- ^ DecliningBalance Method - | DoubleDecliningBalance -- ^ Not implemented | StraightLine -- ^ Straight Line Method - -- | UnitBased Int - -- | MACRS - | SumYearsDigit -- ^ Not implemented deriving (Show,Generic,Eq,Ord) data ReceivableFeeType = FixedFee Balance -- ^ a flat fee amount @@ -145,6 +141,11 @@ data Obligor = Obligor {obligorId :: String , obligorFields :: Map.Map String (Either String Double) } deriving (Show,Generic,Eq,Ord) +data LeaseRateCalc = ByDayRate DailyRate DatePattern + | ByPeriodRental Balance Period + deriving (Show,Generic,Eq,Ord) + + data OriginalInfo = MortgageOriginalInfo { originBalance :: Balance ,originRate :: IR.RateType ,originTerm :: Int @@ -162,8 +163,7 @@ data OriginalInfo = MortgageOriginalInfo { originBalance :: Balance ,obligor :: Maybe Obligor } | LeaseInfo { startDate :: Date -- ^ lease start date ,originTerm :: Int -- ^ total terms - ,paymentDates :: DatePattern -- ^ payment dates pattern - ,originRental :: Amount -- ^ rental by day + ,originRental :: LeaseRateCalc -- ^ rental by day ,obligor :: Maybe Obligor } | FixedAssetInfo { startDate :: Date ,originBalance :: Balance @@ -306,7 +306,7 @@ instance IR.UseRate ProjectedCashflow where $(concat <$> traverse (deriveJSON defaultOptions) [''Obligor, ''OriginalInfo, ''FixedAsset, ''AmortPlan, ''PrepayPenaltyType - , ''Capacity, ''AmortRule, ''ReceivableFeeType]) + , ''Capacity, ''AmortRule, ''ReceivableFeeType, ''LeaseRateCalc]) makePrisms ''OriginalInfo @@ -351,5 +351,6 @@ instance ToSchema Period instance ToSchema IR.ARM instance ToSchema Status instance ToSchema ReceivableFeeType +instance ToSchema LeaseRateCalc instance ToSchema OriginalInfo instance ToSchema Mortgage diff --git a/src/AssetClass/Lease.hs b/src/AssetClass/Lease.hs index 93875612..f127728d 100644 --- a/src/AssetClass/Lease.hs +++ b/src/AssetClass/Lease.hs @@ -12,7 +12,7 @@ import qualified Data.Time as T import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) import qualified Assumptions as AP import Asset -import Types +import Types hiding (getOriginDate) import Lib import Util import DateUtil @@ -46,35 +46,58 @@ calcChangeRateOnRental :: AP.LeaseAssetRentAssump -> Date -> Date -> Rate calcChangeRateOnRental (AP.BaseAnnualRate r) sd ed = 1 + yearCountFraction DC_ACT_365F sd ed * r calcChangeRateOnRental (AP.BaseCurve rc) sd ed = 1 + yearCountFraction DC_ACT_365F sd ed * getValByDate rc Exc ed +getNewRental :: AP.LeaseAssetRentAssump -> Date -> Date -> LeaseRateCalc -> LeaseRateCalc +getNewRental (AP.BaseAnnualRate r) sd ed (ByDayRate dr dp) + = ByDayRate (mulBR dr (1 + yearCountFraction DC_ACT_365F sd ed * fromRational r)) dp +getNewRental (AP.BaseCurve rc) sd ed (ByDayRate dr dp) + = ByDayRate (mulBR dr (1 + yearCountFraction DC_ACT_365F sd ed * getValByDate rc Exc ed)) dp + +getNewRental (AP.BaseAnnualRate r) sd ed (ByPeriodRental rental per) + = ByPeriodRental (mulBR rental (1 + yearCountFraction DC_ACT_365F sd ed * fromRational r)) per +getNewRental (AP.BaseCurve rc) sd ed (ByPeriodRental rental per) + = ByPeriodRental (mulBR rental (1 + yearCountFraction DC_ACT_365F sd ed * (fromRational (getValByDate rc Exc ed)))) per + +calcEndDate :: Date -> Int -> LeaseRateCalc -> Date +calcEndDate sd periods (ByDayRate _ dp) = last $ genSerialDates dp Exc sd periods +calcEndDate sd periods (ByPeriodRental _ per) = last $ genDates sd per periods + +-- ByDayRate _ dp -> genSerialDates dp Exc (getOriginDate l) (ot + getTotalTerms l) +-- ByPeriodRental _ per -> genDates (getOriginDate l) per (ot + getTotalTerms l) + + + calcGapDays :: AP.LeaseAssetGapAssump -> Date -> Int calcGapDays (AP.GapDays days) _ = days -calcGapDays (AP.GapDaysByAmount tbl defaultDays) _ = defaultDays calcGapDays (AP.GapDaysByCurve ts) d = round $ fromRational $ getValByDate ts Exc d + -- ^ Generate next lease with new rental / term changes/ day gap nextLease :: Lease -> (AP.LeaseAssetRentAssump, TermChangeRate, DayGap) -> (Lease, Date) -nextLease l@(RegularLease (LeaseInfo sd ot dp dr ob) bal rt _) (rAssump,tc,gd) +nextLease l@(RegularLease (LeaseInfo sd ot rental ob) bal rt _) (rAssump,tc,gd) = let - leaseEndDate = last $ projectCfDates dp sd ot + leaseEndDate = last $ getPaymentDates l 0 nextStartDate = T.addDays (succ (toInteger gd)) leaseEndDate -- `debug` ("Gap Day ->"++ show gd) + nextOriginTerm = round $ mulIR ot (1+tc) - nextEndDate = last $ genSerialDates dp Inc nextStartDate (fromIntegral nextOriginTerm) - nextDailyRate = mulBR dr $ calcChangeRateOnRental rAssump sd nextStartDate - newBal = fromRational $ mulBInteger nextDailyRate $ daysBetween nextStartDate nextEndDate + nextEndDate = calcEndDate nextStartDate ot rental + nextRental = getNewRental rAssump sd nextStartDate rental + newBal = -1 in - (RegularLease (LeaseInfo nextStartDate nextOriginTerm dp nextDailyRate ob) newBal rt Current,nextEndDate) -- `debug` ("1+tc"++show (1+tc) ++">>"++ show (mulIR ot (1+tc))) + (RegularLease (LeaseInfo nextStartDate nextOriginTerm nextRental ob) + newBal nextOriginTerm Current,nextEndDate) -- `debug` ("1+tc"++show (1+tc) ++">>"++ show (mulIR ot (1+tc))) -nextLease l@(StepUpLease (LeaseInfo sd ot dp dr ob) lsteupInfo bal rt _) (rAssump,tc,gd) +nextLease l@(StepUpLease (LeaseInfo sd ot rental ob) lsteupInfo bal rt _) (rAssump,tc,gd) = let - leaseEndDate = last $ projectCfDates dp sd ot + leaseEndDate = last $ getPaymentDates l 0 nextStartDate = T.addDays (succ (toInteger gd)) leaseEndDate -- `debug` ("Gap Day ->"++ show gd) nextOriginTerm = round $ mulIR ot (1+tc) - nextEndDate = last $ genSerialDates dp Inc nextStartDate (fromIntegral nextOriginTerm) - nextDailyRate = mulBR dr $ calcChangeRateOnRental rAssump sd nextStartDate + nextEndDate = calcEndDate sd ot rental + nextRental = getNewRental rAssump sd nextStartDate rental newBal = -1 in - (StepUpLease (LeaseInfo nextStartDate nextOriginTerm dp nextDailyRate ob) lsteupInfo newBal rt Current,nextEndDate) -- `debug` ("leaseEndDate>>"++show leaseEndDate++">>>"++show (succ (toInteger gd))) + (StepUpLease (LeaseInfo nextStartDate nextOriginTerm nextRental ob) + lsteupInfo newBal nextOriginTerm Current,nextEndDate) -- `debug` ("leaseEndDate>>"++show leaseEndDate++">>>"++show (succ (toInteger gd))) -- | create a new lease base on the lease in 1st argument, with new rental/term, a gap days, till the end date nextLeaseTill :: Lease -> (AP.LeaseAssetRentAssump, TermChangeRate, DayGap) -> Date -> AP.LeaseEndType -> [Lease] -> [Lease] @@ -91,25 +114,16 @@ nextLeaseTill l (rsc,tc,mg) lastDate (AP.StopByExtTimes n) accum (new_lease,new_lastDate) = nextLease l (rsc,tc,mg) -getGapDaysByBalance :: Lease -> ([(Amount,Int)],Int) -> Int -getGapDaysByBalance l tbl@(rows,defaultVal) - = let - tbl = ThresholdTable rows - pmt = case l of - (RegularLease (LeaseInfo _ _ _ dr _) _ _ _) -> dr - (StepUpLease (LeaseInfo _ _ _ dr _) _ _ _ _) -> dr - in - fromMaybe defaultVal $ lookupTable tbl Down (>= pmt) +-- getGapDaysByBalance :: Lease -> ([(Amount,Int)],Int) -> Int +-- getGapDaysByBalance l tbl@(rows,defaultVal) +-- = let +-- tbl = ThresholdTable rows +-- pmt = case l of +-- (RegularLease (LeaseInfo _ _ _ dr _) _ _ _) -> dr +-- (StepUpLease (LeaseInfo _ _ _ dr _) _ _ _ _) -> dr +-- in +-- fromMaybe defaultVal $ lookupTable tbl Down (>= pmt) -projectCfDates :: DatePattern -> Date -> Int -> [Date] -projectCfDates dp sd ot - = let - cf_dates_proj = genSerialDates dp Inc sd ot - in - if head cf_dates_proj == sd then - genSerialDates dp Inc sd (succ ot) - else - sd:cf_dates_proj -- ^ calculate the daily rate for a step up lease -- TODO: factor rates to model the defaulted factors @@ -124,17 +138,30 @@ calcPmts (ByAmountCurve amts) fs amt | otherwise = Right $ scanl (+) amt amts + -- ^ return a lease contract with opening balance and a payment cashflow on each payment date patchBalance :: Lease -> Either String (Lease,[Amount]) -patchBalance (RegularLease (LeaseInfo sd ot dp dr ob) bal rt st) +patchBalance l@(RegularLease (LeaseInfo sd ot (ByDayRate dr dp) ob) bal rt st) = let - cf_dates = lastN (succ rt) $ projectCfDates dp sd ot + cf_dates = sd:getPaymentDates l 0 pmts = [ fromRational (mulBInt dr ds) | ds <- getIntervalDays cf_dates ] new_bal = sum pmts -- `debug` ("cf_date" ++ show cf_dates) in - Right (RegularLease (LeaseInfo sd ot dp dr ob) new_bal rt st, pmts) + Right (RegularLease (LeaseInfo sd ot (ByDayRate dr dp) ob) new_bal rt st, pmts) -patchBalance l@(StepUpLease (LeaseInfo sd ot dp dr ob) lsu bal rt st) +patchBalance l@(RegularLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) bal rt st) + = let + cf_dates = lastN (succ rt) $ getPaymentDates l 0 + intervals = daysInterval cf_dates + factors = replicate (pred ot) 1.0 + pmts = replicate rt rental + new_bal = sum pmts + in + do + return (RegularLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) new_bal rt st,pmts) -- `debug` ("daily payments" ++ show pmts) + + +patchBalance l@(StepUpLease (LeaseInfo sd ot (ByDayRate dr p) ob) lsu bal rt st) = let cfDates = sd:getPaymentDates l 0 intervals = daysInterval cfDates @@ -144,43 +171,48 @@ patchBalance l@(StepUpLease (LeaseInfo sd ot dp dr ob) lsu bal rt st) dailyRentals <- calcPmts lsu factors dr let pmts = [ fromRational (mulBInteger r d) | (d,r) <- zip intervals dailyRentals ] let new_bal = sum pmts - return (StepUpLease (LeaseInfo sd ot dp dr ob) lsu new_bal rt st,pmts) -- `debug` ("daily payments" ++ show pmts) + return (StepUpLease (LeaseInfo sd ot (ByDayRate dr p) ob) lsu new_bal rt st,pmts) -- `debug` ("daily payments" ++ show pmts) instance Asset Lease where - calcCashflow l@(RegularLease (LeaseInfo sd ot dp dr ob) _ rt st) d _ = + calcCashflow l@(RegularLease (LeaseInfo sd ot or ob) _ rt st) d _ = do (l',pmts) <- patchBalance l - let bal = getCurrentBal l' - let pDates = lastN rt $ getPaymentDates l 0 - let bals = tail $ scanl (-) bal pmts + let bal = getCurrentBal l' -- `debug` ("payments"++ show pmts) + let pDates = lastN rt $ getPaymentDates l 0 + let bals = tail $ scanl (-) bal pmts -- `debug` ("pDates "++ show pDates) return $ CF.CashFlowFrame (0,d,Nothing) $ cutBy Inc Future d (zipWith3 CF.LeaseFlow pDates bals pmts) - calcCashflow l@(StepUpLease (LeaseInfo sd ot dp dr ob) lsu bal rt st) d _ = + calcCashflow l@(StepUpLease (LeaseInfo sd ot or ob) lsu bal rt st) d _ = do (l' ,pmts) <- patchBalance l let bal = getCurrentBal l' - -- let p_dates = projectCfDates dp sd ot let pDates = (lastN rt) $ getPaymentDates l 0 - let bals = (lastN rt) $ tail $ scanl (-) bal pmts + let bals = tail $ scanl (-) bal pmts return $ CF.CashFlowFrame (0,d,Nothing) $ cutBy Inc Future d (zipWith3 CF.LeaseFlow pDates bals ((lastN rt) pmts)) - getPaymentDates l@(RegularLease (LeaseInfo sd ot dp _ _) _ rt _) _ - = genSerialDates dp Inc sd ot - getPaymentDates l@(StepUpLease (LeaseInfo sd ot dp _ _) _ _ rt _) _ - = genSerialDates dp Inc sd ot + getOriginInfo (StepUpLease lInfo lsteupInfo bal rt st) = lInfo + getOriginInfo (RegularLease lInfo bal rt st) = lInfo + + getOriginDate (StepUpLease (LeaseInfo sd _ _ _) _ _ _ _) = sd + getOriginDate (RegularLease (LeaseInfo sd _ _ _) _ _ _) = sd - getOriginDate (StepUpLease (LeaseInfo sd ot dp _ _) _ _ rt _) = sd - getOriginDate (RegularLease (LeaseInfo sd ot dp _ _) _ rt _) = sd + getPaymentDates l ot + = case originRental (getOriginInfo l) of + ByDayRate _ dp -> genSerialDates dp Exc (getOriginDate l) (ot + getTotalTerms l) + ByPeriodRental _ per -> genDates (getOriginDate l) per (ot + getTotalTerms l) - getRemainTerms (StepUpLease (LeaseInfo sd ot dp _ _) _ _ rt _) = rt - getRemainTerms (RegularLease (LeaseInfo sd ot dp _ _) _ rt _) = rt + getRemainTerms (StepUpLease _ _ _ rt _) = rt + getRemainTerms (RegularLease _ _ rt _) = rt + + getTotalTerms (RegularLease (LeaseInfo _ ot _ _) _ _ _) = ot + getTotalTerms (StepUpLease (LeaseInfo _ ot _ _) _ _ _ _) = ot - updateOriginDate (StepUpLease (LeaseInfo sd ot dp dr ob) lsu bal rt st) nd - = StepUpLease (LeaseInfo nd ot dp dr ob) lsu bal rt st - updateOriginDate (RegularLease (LeaseInfo sd ot dp dr ob) bal rt st) nd - = RegularLease (LeaseInfo nd ot dp dr ob) bal rt st + updateOriginDate (StepUpLease (LeaseInfo sd ot rental ob) lsu bal rt st) nd + = StepUpLease (LeaseInfo nd ot rental ob) lsu bal rt st + updateOriginDate (RegularLease (LeaseInfo sd ot rental ob) bal rt st) nd + = RegularLease (LeaseInfo nd ot rental ob) bal rt st -- resetToOrig (StepUpLease (LeaseInfo sd ot dp dr ob) lsu bal rt st) -- = fst . patchBalance $ StepUpLease (LeaseInfo sd ot dp dr ob) lsu bal ot st @@ -191,10 +223,10 @@ instance Asset Lease where = let -- (rc,rcCurve,mgTbl,gapDays,ed) = extractAssump (A.LeaseAssump gapAssump rentAssump) -- (0.0,mkTs [],([(0.0,0)],0),0,epocDate)-- `debug` ("7") pdates = getPaymentDates l 0 -- `debug` ("8")-- `debug` ("RCURVE"++show rcCurve) - -- get the gap days between leases pickGapDays (AP.GapDays days) = days - pickGapDays (AP.GapDaysByAmount tbl defaultDays) = getGapDaysByBalance l (tbl,defaultDays) + -- TODO + pickGapDays (AP.GapDaysByAmount tbl defaultDays) = 0 newLeases = nextLeaseTill l @@ -217,8 +249,9 @@ instance Asset Lease where StepUpLease _ _ bal _ _ -> bal RegularLease _ bal _ _-> bal - getOriginRate (StepUpLease (LeaseInfo _ _ _ dr _) _ _ _ _) = fromRational $ toRational dr - getOriginRate (RegularLease (LeaseInfo _ _ _ dr _) _ _ _) = fromRational $ toRational dr + -- getOriginRate (StepUpLease (LeaseInfo _ _ _ dr _) _ _ _ _) = fromRational $ toRational dr + -- getOriginRate (RegularLease (LeaseInfo _ _ _ dr _) _ _ _) = fromRational $ toRational dr + getOriginRate _ = 0.0 isDefaulted (StepUpLease _ _ _ rt Current) = False isDefaulted (StepUpLease _ _ _ rt _) = True @@ -228,15 +261,15 @@ instance Asset Lease where getOriginBal l = let _sd = case l of - RegularLease (LeaseInfo sd ot dp dr _) bal _ _ -> sd - StepUpLease (LeaseInfo sd ot dp dr _) _ bal _ _ -> sd + RegularLease (LeaseInfo sd _ _ _) bal _ _ -> sd + StepUpLease (LeaseInfo sd _ _ _) _ bal _ _ -> sd in case calcCashflow l _sd Nothing of Right (CF.CashFlowFrame _ txns) -> CF.mflowBegBalance $ head txns Left _ -> 0 - splitWith (RegularLease (LeaseInfo sd ot dp dr ob) bal rt st ) rs - = [ RegularLease (LeaseInfo sd ot dp dr ob) (mulBR bal ratio) rt st | ratio <- rs ] - splitWith (StepUpLease (LeaseInfo sd ot dp dr ob) stup bal rt st ) rs - = [ StepUpLease (LeaseInfo sd ot dp dr ob) stup (mulBR bal ratio) rt st | ratio <- rs] + splitWith (RegularLease (LeaseInfo sd ot dr ob) bal rt st ) rs + = [ RegularLease (LeaseInfo sd ot dr ob) (mulBR bal ratio) rt st | ratio <- rs ] + splitWith (StepUpLease (LeaseInfo sd ot dr ob) stup bal rt st ) rs + = [ StepUpLease (LeaseInfo sd ot dr ob) stup (mulBR bal ratio) rt st | ratio <- rs] diff --git a/src/Deal/DealMod.hs b/src/Deal/DealMod.hs index aa56159c..93ab679f 100644 --- a/src/Deal/DealMod.hs +++ b/src/Deal/DealMod.hs @@ -70,20 +70,20 @@ data AdjStrategy = ScaleBySpread | ScaleByFactor deriving (Show,Generic) -data ModifyType = AddSpreadToBonds [BondName] +data ModifyType = AddSpreadToBonds BondName | ScaleBondBalByRate deriving (Show,Generic) -- ^ Modify a deal by various type of recipes modDeal :: Ast.Asset a => ModifyType -> Double -> DB.TestDeal a -> DB.TestDeal a -modDeal (AddSpreadToBonds bnds) sprd d +modDeal (AddSpreadToBonds bnd) sprd d = let sprd' = (fromRational . toRational) sprd bndMap = DB.bonds d bndMap' = U.mapWithinMap (\b -> b & L.interestInfoTraversal %~ L.adjInterestInfoBySpread sprd' & L.curRatesTraversal %~ (+ sprd')) - bnds + [bnd] bndMap in d {DB.bonds = bndMap'} diff --git a/src/Types.hs b/src/Types.hs index 0a45bdb7..2381dfcc 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -34,7 +34,6 @@ module Types ,MyRatio,HowToPay(..),BondPricingMethod(..),InvestorAction(..) ,_BondTxn ,_InspectBal ) - where import qualified Data.Text as Text diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index aa49ef26..78132882 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -246,7 +246,7 @@ loanTests = leaseTests = let lease1 = AB.RegularLease - (AB.LeaseInfo (L.toDate "20230101") 12 MonthEnd 1 Nothing) + (AB.LeaseInfo (L.toDate "20230101") 12 (AB.ByDayRate 1 MonthEnd) Nothing) 100 12 AB.Current @@ -256,7 +256,7 @@ leaseTests = Right x -> x lease2 = AB.StepUpLease - (AB.LeaseInfo (L.toDate "20230601") 12 MonthEnd 1 Nothing) + (AB.LeaseInfo (L.toDate "20230601") 12 (AB.ByDayRate 1 MonthEnd) Nothing) (AB.FlatRate 1.02) 100 12 @@ -266,7 +266,7 @@ leaseTests = Right x -> x lease3 = AB.StepUpLease - (AB.LeaseInfo (L.toDate "20230401") 4 MonthEnd 1 Nothing) + (AB.LeaseInfo (L.toDate "20230401") 4 (AB.ByDayRate 1 MonthEnd) Nothing) (AB.ByRateCurve [1.04,1.05,1.06]) 100 4 @@ -287,22 +287,39 @@ leaseTests = Nothing of Left _ -> undefined Right x -> x - (cf5,_) = case Ast.projCashflow lease1 asofDate - (A.LeaseAssump Nothing - (A.GapDaysByAmount [(0.5,12),(1,22),(2,62),(3,82)] 92) - (A.BaseAnnualRate 0.0) - (A.CutByDate (L.toDate "20240601")) - - ,A.DummyDelinqAssump,A.DummyDefaultAssump) - Nothing of - Left _ -> undefined - Right x -> x + -- (cf5,_) = case Ast.projCashflow lease1 asofDate + -- (A.LeaseAssump Nothing + -- (A.GapDaysByAmount [(0.5,12),(1,22),(2,62),(3,82)] 92) + -- (A.BaseAnnualRate 0.0) + -- (A.CutByDate (L.toDate "20240601")) + -- + -- ,A.DummyDelinqAssump,A.DummyDefaultAssump) + -- Nothing of + -- Left _ -> undefined + -- Right x -> x in testGroup "Lease CF Test" [ - testCase "1 year Regular Lease sum of rentals" $ + testCase "1 year Regular Lease sum of rentals/dates" $ + assertEqual "Dates" + (L.toDates ["20230131","20230228","20230331","20230430","20230531","20230630" + ,"20230731","20230831","20230930","20231031","20231130","20231231"]) + (Ast.getPaymentDates lease1 0) + ,testCase "1 year Regular Lease sum of rentals/dates" $ + assertEqual "cf dates" + (L.toDates ["20230630","20230731","20230831","20230930","20231031","20231130","20231231"]) + (CF.getDate <$> (cf1 ^. CF.cashflowTxn)) + ,testCase "1 year Regular Lease sum of rentals/first" $ + assertEqual "First flow" + (CF.LeaseFlow (L.toDate "20230630") 184.00 30.0) + (head (cf1 ^. CF.cashflowTxn)) + ,testCase "1 year Regular Lease sum of rentals/last" $ + assertEqual "Last flow" + (CF.LeaseFlow (L.toDate "20231231") 0.00 31.0) + (last (cf1 ^. CF.cashflowTxn)) + ,testCase "1 year Regular Lease sum of rentals" $ assertEqual "total rental" 214 - (sum $ map CF.tsTotalCash (cf1 ^. CF.cashflowTxn)) -- `debug` ("regular test"++show cf1) + (sum $ map CF.tsTotalCash (cf1 ^. CF.cashflowTxn)) ,testCase "1 year Regular Lease first pay date" $ assertEqual "first date of regular lease" (L.toDate "20230630") @@ -310,7 +327,7 @@ leaseTests = ,testCase "1 year Stepup lease first pay" $ assertEqual "first pay" (CF.LeaseFlow (L.toDate "20230630") 376.24 29) - (head (cf2 ^. CF.cashflowTxn)) --`debug` ("CF2 >>" ++ show cf2) + (head (cf2 ^. CF.cashflowTxn)) ,testCase "1 year Stepup lease" $ assertEqual "total rental" 405.24 @@ -333,16 +350,16 @@ leaseTests = ((cf3 ^. CF.cashflowTxn)!!1) ,testCase "Lease with Assumptions" $ assertEqual "Month Gap=45 days" - (CF.LeaseFlow (L.toDate "20250131") 0 31) - (last (cf4 ^. CF.cashflowTxn) ) -- `debug` ("CF4"++show cf4) - ,testCase "Lease with Assumptions" $ - assertEqual "Month Gap by Table : New Lease at period 0" - (CF.LeaseFlow (L.toDate "20240131") 335 8) - ((cf5 ^. CF.cashflowTxn)!!7) - ,testCase "Lease with Assumptions" $ - assertEqual "Month Gap by Table : New Lease at period 1" - (CF.LeaseFlow (L.toDate "20240229") 306 29) - ((cf5 ^. CF.cashflowTxn)!!8) + ((CF.LeaseFlow (L.toDate "20240630") 215 30.0),(CF.LeaseFlow (L.toDate "20250131") 0 31)) + (((cf4 ^. CF.cashflowTxn)!!11),(last (cf4 ^. CF.cashflowTxn))) -- `debug` ("CF4->"++show cf4) + -- ,testCase "Lease with Assumptions" $ + -- assertEqual "Month Gap by Table : New Lease at period 0" + -- (CF.LeaseFlow (L.toDate "20240131") 335 8) + -- ((cf5 ^. CF.cashflowTxn)!!7) `debug` ("CF5->"++show cf5) + -- ,testCase "Lease with Assumptions" $ + -- assertEqual "Month Gap by Table : New Lease at period 1" + -- (CF.LeaseFlow (L.toDate "20240229") 306 29) + -- ((cf5 ^. CF.cashflowTxn)!!8) ] installmentTest = From 8e7093c2d0213a2c7ee6ac7d4dfe6e4826ce2f84 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 26 Apr 2025 19:03:05 +0800 Subject: [PATCH 42/53] compete testbySpread --- app/Main.hs | 41 ++++++++++++++---------- app/MainBase.hs | 4 ++- swagger.json | 85 ++++++++++++++++++++++++++++++++++++++++++------- 3 files changed, 102 insertions(+), 28 deletions(-) diff --git a/app/Main.hs b/app/Main.hs index 8057bb41..60790c42 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -240,16 +240,6 @@ stressRevovlingPerf r (Just (AP.AvailableAssets rp applyAssumpType)) stressRevovlingPerf r (Just (AP.AvailableAssetsBy m)) = Just (AP.AvailableAssetsBy (Map.map (over (_2 . AP.applyAssumptionTypeAssetPerf . _1) (stressAssetPerf r)) m)) -dtToBonds :: DealType -> Map.Map BondName L.Bond -dtToBonds (MDeal d) = DB.bonds d -dtToBonds (RDeal d) = DB.bonds d -dtToBonds (IDeal d) = DB.bonds d -dtToBonds (LDeal d) = DB.bonds d -dtToBonds (FDeal d) = DB.bonds d -dtToBonds (UDeal d) = DB.bonds d -dtToBonds (VDeal d) = DB.bonds d -dtToBonds (PDeal d) = DB.bonds d - modifyDealType :: DM.ModifyType -> Double -> DealType -> DealType modifyDealType dm f (MDeal d) = MDeal $ DM.modDeal dm f d modifyDealType dm f (RDeal d) = RDeal $ DM.modDeal dm f d @@ -280,6 +270,25 @@ queryDealTypeBool (UDeal _d) d s = Q.queryDealBool _d s d queryDealTypeBool (VDeal _d) d s = Q.queryDealBool _d s d queryDealTypeBool (PDeal _d) d s = Q.queryDealBool _d s d +getDealBondMap :: DealType -> Map.Map BondName L.Bond +getDealBondMap (MDeal d) = DB.bonds d +getDealBondMap (RDeal d) = DB.bonds d +getDealBondMap (IDeal d) = DB.bonds d +getDealBondMap (LDeal d) = DB.bonds d +getDealBondMap (FDeal d) = DB.bonds d +getDealBondMap (UDeal d) = DB.bonds d +getDealBondMap (VDeal d) = DB.bonds d +getDealBondMap (PDeal d) = DB.bonds d + +getDealFeeMap :: DealType -> Map.Map FeeName F.Fee +getDealFeeMap (MDeal d) = DB.fees d +getDealFeeMap (RDeal d) = DB.fees d +getDealFeeMap (IDeal d) = DB.fees d +getDealFeeMap (LDeal d) = DB.fees d +getDealFeeMap (FDeal d) = DB.fees d +getDealFeeMap (UDeal d) = DB.fees d +getDealFeeMap (VDeal d) = DB.fees d +getDealFeeMap (PDeal d) = DB.fees d -- stress the pool performance, till a bond suffers first loss testByDefault :: DealType -> AP.ApplyAssumptionType -> AP.NonPerfAssumption -> BondName -> Double -> Double @@ -292,7 +301,7 @@ testByDefault dt assumps nonPerfAssump@AP.NonPerfAssumption{AP.revolving = mRevo case runResult of Right (d,mPoolCfMap,mResult,mPricing) -> let - bondBal = L.getOutstandingAmount $ (dtToBonds d) Map.! bn + bondBal = L.getOutstandingAmount $ (getDealBondMap dt) Map.! bn in (fromRational (toRational bondBal) - 0.01) Left errorMsg -> error $ "Error in test fun for first loss" ++ show errorMsg @@ -306,17 +315,17 @@ testBySpread (dt,mPAssump,runAssump) (bn,otherBondFlag,otherFeeFlag) f runResult = wrapRun (modifyDealType (DM.AddSpreadToBonds bn) f dt) mPAssump runAssump in case runResult of - Right (d@DB.TestDeal{DB.fees = feeMap,DB.bonds = bndMap}, mPoolCfMap, mResult, pResult) -> + Right (dt, mPoolCfMap, mResult, pResult) -> let -- bnds otherBondsName = [] -- check fees/other bonds + otherBondOustanding True = sum $ L.getOutstandingAmount <$> Map.elems (getDealBondMap dt) otherBondOustanding False = 0.0 - otherBondOustanding True = sum $ L.getOutstandingAmount <$> Map.elems bndMap - feeOutstanding True = sum $ L.getOutstandingAmount <$> Map.elems feeMap + feeOutstanding True = sum $ L.getOutstandingAmount <$> Map.elems (getDealFeeMap dt) feeOutstanding False = 0.0 v = getPriceValue $ pResult Map.! bn - bondBal = L.getOriginBalance $ dtToBonds d Map.! bn + bondBal = L.getOriginBalance $ (getDealBondMap dt) Map.! bn in if (otherBondOustanding otherBondFlag+feeOutstanding otherFeeFlag) > 0 then -1 @@ -350,7 +359,7 @@ runRootFinderBy (MaxSpreadToFaceReq (dt,pAssump,dAssump) bns chkOtherBnds chkOth Root r -> let dt' = modifyDealType (DM.AddSpreadToBonds bns) r dt in - Right $ BestSpreadResult r (dtToBonds dt') dt' + Right $ BestSpreadResult r (getDealBondMap dt') dt' NotBracketed -> Left "Not able to bracket the root" SearchFailed -> Left "Not able to find the root" diff --git a/app/MainBase.hs b/app/MainBase.hs index a6c02b03..0afcd112 100644 --- a/app/MainBase.hs +++ b/app/MainBase.hs @@ -11,8 +11,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ExistentialQuantification #-} + module MainBase(DealType(..),RunResp,PoolTypeWrap(..),RunPoolTypeRtn,RunPoolTypeRtn_ - ,RunAssetReq(..),RunAssetResp,ScenarioName,DealRunInput,RunDealReq(..),RunSimDealReq(..),RunPoolReq(..),RunDateReq(..) + ,RunAssetReq(..),RunAssetResp,ScenarioName,DealRunInput,RunDealReq(..),RunSimDealReq(..),RunPoolReq(..) ,RunDateReq(..),Version(..) ,RootFindReq(..),RootFindResp(..),TargetBonds,PoolRunResp ) diff --git a/swagger.json b/swagger.json index 53511f0c..01f067de 100644 --- a/swagger.json +++ b/swagger.json @@ -2352,9 +2352,7 @@ "AmortRule": { "enum": [ "DecliningBalance", - "DoubleDecliningBalance", - "StraightLine", - "SumYearsDigit" + "StraightLine" ], "type": "string" }, @@ -10909,6 +10907,70 @@ } ] }, + "LeaseRateCalc": { + "oneOf": [ + { + "properties": { + "contents": { + "items": [ + { + "multipleOf": 1.0e-2, + "type": "number" + }, + { + "$ref": "#/components/schemas/DatePattern" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + }, + "tag": { + "enum": [ + "ByDayRate" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "ByDayRate", + "type": "object" + }, + { + "properties": { + "contents": { + "items": [ + { + "multipleOf": 1.0e-2, + "type": "number" + }, + { + "$ref": "#/components/schemas/Period" + } + ], + "maxItems": 2, + "minItems": 2, + "type": "array" + }, + "tag": { + "enum": [ + "ByPeriodRental" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "ByPeriodRental", + "type": "object" + } + ] + }, "LeaseStepUp": { "oneOf": [ { @@ -12057,17 +12119,13 @@ "$ref": "#/components/schemas/Obligor" }, "originRental": { - "multipleOf": 1.0e-2, - "type": "number" + "$ref": "#/components/schemas/LeaseRateCalc" }, "originTerm": { "maximum": 9223372036854775807, "minimum": -9223372036854775808, "type": "integer" }, - "paymentDates": { - "$ref": "#/components/schemas/DatePattern" - }, "startDate": { "$ref": "#/components/schemas/Day" }, @@ -12081,7 +12139,6 @@ "required": [ "startDate", "originTerm", - "paymentDates", "originRental", "tag" ], @@ -16351,10 +16408,16 @@ }, { "type": "string" + }, + { + "type": "boolean" + }, + { + "type": "boolean" } ], - "maxItems": 2, - "minItems": 2, + "maxItems": 4, + "minItems": 4, "type": "array" }, "tag": { From 5c1b47d64a63605415926431403e99eaa7c20885 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 26 Apr 2025 19:22:40 +0800 Subject: [PATCH 43/53] bump version to-> < 0.45.4 > --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 60790c42..68a42267 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.45.3" +version1 = Version "0.45.4" wrapRun :: DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From c6b11a0855b7023b0af9798cb536de6670b1b19a Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sat, 10 May 2025 01:43:57 +0800 Subject: [PATCH 44/53] Expose default on lease --- app/MainBase.hs | 1 + src/Analytics.hs | 13 ++++- src/AssetClass/Lease.hs | 122 ++++++++++++++++++++++++++------------- src/Assumptions.hs | 12 ++-- src/Cashflow.hs | 80 ++++++++++++++----------- src/Lib.hs | 8 ++- src/Types.hs | 1 + src/Util.hs | 9 ++- swagger.json | 107 ++++++++++++++++++++-------------- test/MainTest.hs | 1 + test/UT/AnalyticsTest.hs | 13 ++++- test/UT/AssetTest.hs | 16 ++--- 12 files changed, 251 insertions(+), 132 deletions(-) diff --git a/app/MainBase.hs b/app/MainBase.hs index 0afcd112..50e7e143 100644 --- a/app/MainBase.hs +++ b/app/MainBase.hs @@ -283,6 +283,7 @@ instance ToSchema AP.FieldMatchRule instance ToSchema AP.ObligorStrategy instance ToSchema AP.ApplyAssumptionType instance ToSchema AP.LeaseEndType +instance ToSchema AP.LeaseDefaultType instance ToSchema AP.AssetPerfAssumption instance ToSchema AP.AssetDelinqPerfAssumption instance ToSchema AP.AssetDefaultedPerfAssumption diff --git a/src/Analytics.hs b/src/Analytics.hs index cf14a98f..e2a737a4 100644 --- a/src/Analytics.hs +++ b/src/Analytics.hs @@ -3,7 +3,9 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE ScopedTypeVariables #-} -module Analytics (calcConvexity,calcDuration,pv,calcWAL,pv2,pv3,fv2,pv21,calcRequiredAmtForIrrAtDate,calcIRR) +module Analytics (calcConvexity,calcDuration,pv,calcWAL,pv2,pv3 + ,fv2,pv21,calcRequiredAmtForIrrAtDate,calcIRR + ,calcSurvivorFactors) where import Types @@ -21,6 +23,15 @@ import Numeric.RootFinding import Debug.Trace debug = flip trace +calcSurvivorFactors :: Date -> [Date] -> Double -> [Double] +calcSurvivorFactors sd ds 0 = replicate (length ds) 1.0 +calcSurvivorFactors sd ds survivalRate = + let + yearFractions::[Double] = [ realToFrac (daysBetween sd d) / 365.0 | d <- ds ] + factors = [ (1 - survivalRate) ** x | x <- yearFractions ] + in + factors + -- ^ calculate the Weighted Average Life of cashflow, with unit option to Monthly or Yearly calcWAL :: TimeHorizion -> Balance -> Date -> [(Balance,Date)] -> Balance calcWAL th bal d ps = diff --git a/src/AssetClass/Lease.hs b/src/AssetClass/Lease.hs index f127728d..30f77952 100644 --- a/src/AssetClass/Lease.hs +++ b/src/AssetClass/Lease.hs @@ -26,6 +26,7 @@ import Data.Aeson.Types import GHC.Generics import Data.Maybe import AssetClass.AssetBase +import qualified Analytics as AN import Control.Lens hiding (element) import Control.Lens.TH @@ -61,17 +62,10 @@ calcEndDate :: Date -> Int -> LeaseRateCalc -> Date calcEndDate sd periods (ByDayRate _ dp) = last $ genSerialDates dp Exc sd periods calcEndDate sd periods (ByPeriodRental _ per) = last $ genDates sd per periods --- ByDayRate _ dp -> genSerialDates dp Exc (getOriginDate l) (ot + getTotalTerms l) --- ByPeriodRental _ per -> genDates (getOriginDate l) per (ot + getTotalTerms l) - - - calcGapDays :: AP.LeaseAssetGapAssump -> Date -> Int calcGapDays (AP.GapDays days) _ = days calcGapDays (AP.GapDaysByCurve ts) d = round $ fromRational $ getValByDate ts Exc d - - -- ^ Generate next lease with new rental / term changes/ day gap nextLease :: Lease -> (AP.LeaseAssetRentAssump, TermChangeRate, DayGap) -> (Lease, Date) nextLease l@(RegularLease (LeaseInfo sd ot rental ob) bal rt _) (rAssump,tc,gd) @@ -113,18 +107,6 @@ nextLeaseTill l (rsc,tc,mg) lastDate (AP.StopByExtTimes n) accum where (new_lease,new_lastDate) = nextLease l (rsc,tc,mg) - --- getGapDaysByBalance :: Lease -> ([(Amount,Int)],Int) -> Int --- getGapDaysByBalance l tbl@(rows,defaultVal) --- = let --- tbl = ThresholdTable rows --- pmt = case l of --- (RegularLease (LeaseInfo _ _ _ dr _) _ _ _) -> dr --- (StepUpLease (LeaseInfo _ _ _ dr _) _ _ _ _) -> dr --- in --- fromMaybe defaultVal $ lookupTable tbl Down (>= pmt) - - -- ^ calculate the daily rate for a step up lease -- TODO: factor rates to model the defaulted factors calcPmts :: LeaseStepUp -> [Rate] -> Amount -> Either String [Amount] @@ -151,10 +133,9 @@ patchBalance l@(RegularLease (LeaseInfo sd ot (ByDayRate dr dp) ob) bal rt st) patchBalance l@(RegularLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) bal rt st) = let - cf_dates = lastN (succ rt) $ getPaymentDates l 0 - intervals = daysInterval cf_dates - factors = replicate (pred ot) 1.0 - pmts = replicate rt rental + -- cf_dates = lastN (succ rt) $ getPaymentDates l 0 + -- intervals = daysInterval cf_dates + pmts = replicate ot rental new_bal = sum pmts in do @@ -173,23 +154,82 @@ patchBalance l@(StepUpLease (LeaseInfo sd ot (ByDayRate dr p) ob) lsu bal rt st) let new_bal = sum pmts return (StepUpLease (LeaseInfo sd ot (ByDayRate dr p) ob) lsu new_bal rt st,pmts) -- `debug` ("daily payments" ++ show pmts) +patchBalance l@(StepUpLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) lsu bal rt st) + = let + factors = replicate (pred ot) 1.0 + in + do + periodRentals <- calcPmts lsu factors rental + let new_bal = sum periodRentals + return (StepUpLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) lsu new_bal rt st,periodRentals) -- `debug` ("daily payments" ++ show pmts) + + +allocDefaultToLeaseFlow :: [Rate] -> (Rate,Balance) -> [CF.TsRow] -> [CF.TsRow] -> [CF.TsRow] +allocDefaultToLeaseFlow defaultRates (begFactor,begBal) rs [] = reverse rs +allocDefaultToLeaseFlow (defaultRate:defaultRates) (begFactor,begBal) rs (txn@(CF.LeaseFlow d b r def):txns) + = let + defaultAmt = mulBR begBal defaultRate + nextFactor = begFactor * (1-defaultRate) + newRental = mulBR r nextFactor + nextBal = min (begBal - defaultAmt - newRental) b -- TODO: hardcode to fix rounding issue + in + allocDefaultToLeaseFlow defaultRates (nextFactor,nextBal) ((CF.LeaseFlow d nextBal newRental defaultAmt):rs) txns + +calcDefaultRates :: Rate -> CF.CashFlowFrame -> [Rate] +calcDefaultRates r cf + = let + -- cfBegDate:cfDates = CF.getAllDatesCashFlowFrame cf + ds = CF.getAllDatesCashFlowFrame cf + in + Util.toPeriodRateByInterval r <$> getIntervalDays ds + +applyDefaults :: Maybe AP.LeaseDefaultType -> (CF.CashFlowFrame,[CF.CashFlowFrame]) -> ([CF.TsRow],[[CF.TsRow]]) +applyDefaults Nothing (CF.CashFlowFrame _ txn1,cfs) = (txn1,view CF.cashflowTxn <$> cfs) +-- applyDefaults (Just (AP.DefaultByContinuation r)) (CF.CashFlowFrame _ txn1,cfs) +-- = (txn1,(view CF.cashflowTxn) <$> cfs) +applyDefaults (Just (AP.DefaultByTermination r)) (cf1,cfs) + = let + cf1Factors = calcDefaultRates r cf1 + cfsFactors::[[Rate]] = (calcDefaultRates r) <$> cfs + in + (allocDefaultToLeaseFlow cf1Factors (1.0,(CF.getBegBalCashFlowFrame cf1)) [] (view CF.cashflowTxn cf1) + , (\(fs,cf) -> allocDefaultToLeaseFlow fs (1.0, (CF.getBegBalCashFlowFrame cf)) [] (view CF.cashflowTxn cf)) <$> (zip cfsFactors cfs) + ) + +applyDefaults (Just (AP.DefaultByContinuation r)) (cf1,cfs) + = let + cf1Defaults = calcDefaultRates r cf1 + cfsDefaults::[[Rate]] = calcDefaultRates r <$> cfs + + cf1Factor = foldr (*) 1.0 $ (1 -) <$> cf1Defaults + cfsFactors = (\df -> foldr (*) 1.0 ((1 -) <$> df)) <$> cfsDefaults + + cfFactors = cf1Factor : (init cfsFactors) + + cfs' = zipWith CF.splitCf cfsFactors cfs -- `debug` ("Cfs"++ show (cfsFactors)) + in + (allocDefaultToLeaseFlow cf1Defaults (1.0, (CF.getBegBalCashFlowFrame cf1)) [] (view CF.cashflowTxn cf1) + , (\(fs,cf) -> allocDefaultToLeaseFlow fs (1.0, (CF.getBegBalCashFlowFrame cf)) [] (view CF.cashflowTxn cf)) <$> (zip cfsDefaults cfs') + ) + instance Asset Lease where - calcCashflow l@(RegularLease (LeaseInfo sd ot or ob) _ rt st) d _ = + calcCashflow l d _ = do (l',pmts) <- patchBalance l let bal = getCurrentBal l' -- `debug` ("payments"++ show pmts) - let pDates = lastN rt $ getPaymentDates l 0 + let pDates = lastN (getRemainTerms l) $ getPaymentDates l 0 let bals = tail $ scanl (-) bal pmts -- `debug` ("pDates "++ show pDates) - return $ CF.CashFlowFrame (0,d,Nothing) $ cutBy Inc Future d (zipWith3 CF.LeaseFlow pDates bals pmts) + let defaults = replicate (length pDates) 0.0 + return $ CF.CashFlowFrame (head bals,max d (getOriginDate l),Nothing) $ cutBy Inc Future d (zipWith4 CF.LeaseFlow pDates bals pmts defaults) - calcCashflow l@(StepUpLease (LeaseInfo sd ot or ob) lsu bal rt st) d _ = - do - (l' ,pmts) <- patchBalance l - let bal = getCurrentBal l' - let pDates = (lastN rt) $ getPaymentDates l 0 - let bals = tail $ scanl (-) bal pmts - return $ CF.CashFlowFrame (0,d,Nothing) $ cutBy Inc Future d (zipWith3 CF.LeaseFlow pDates bals ((lastN rt) pmts)) + -- calcCashflow l@(StepUpLease (LeaseInfo sd ot or ob) lsu bal rt st) d _ = + -- do + -- (l' ,pmts) <- patchBalance l + -- let bal = getCurrentBal l' + -- let pDates = lastN rt $ getPaymentDates l 0 + -- let bals = tail $ scanl (-) bal pmts + -- return $ CF.CashFlowFrame (head bals,d,Nothing) $ cutBy Inc Future d (zipWith3 CF.LeaseFlow pDates bals pmts) getOriginInfo (StepUpLease lInfo lsteupInfo bal rt st) = lInfo @@ -221,26 +261,27 @@ instance Asset Lease where projCashflow l asOfDay (AP.LeaseAssump mDefault gapAssump rentAssump endType,_,_) mRates = let - -- (rc,rcCurve,mgTbl,gapDays,ed) = extractAssump (A.LeaseAssump gapAssump rentAssump) -- (0.0,mkTs [],([(0.0,0)],0),0,epocDate)-- `debug` ("7") pdates = getPaymentDates l 0 -- `debug` ("8")-- `debug` ("RCURVE"++show rcCurve) -- get the gap days between leases pickGapDays (AP.GapDays days) = days - -- TODO - pickGapDays (AP.GapDaysByAmount tbl defaultDays) = 0 + pickGapDays (AP.GapDaysByCurve cv) = getIntValOnByDate cv asOfDay newLeases = nextLeaseTill l - (rentAssump ,0.0,pickGapDays gapAssump) + (rentAssump , 0.0 , pickGapDays gapAssump) (last pdates) endType [] + stressRentals = 0 in do currentCf <- calcCashflow l asOfDay mRates newCfs <- sequenceA [ calcCashflow l asOfDay mRates | l <- newLeases ] -- `debug` ("Current CF\n "++ show currentCf) - let allTxns = view CF.cashflowTxn currentCf ++ (concat $ (view CF.cashflowTxn) <$> newCfs) + let (curCf,newTxns) = applyDefaults mDefault (currentCf, newCfs) + -- let allTxns = view CF.cashflowTxn currentCf ++ (concat $ (view CF.cashflowTxn) <$> newCfs) + let allTxns = curCf ++ concat newTxns let begBal = CF.buildBegBal allTxns - return $ (CF.CashFlowFrame (begBal,asOfDay,Nothing) allTxns, Map.empty) + return $ (CF.CashFlowFrame (begBal,max asOfDay (getOriginDate l),Nothing) allTxns, Map.empty) projCashflow a b c d = Left $ "Failed to match when proj lease with assumption >>" ++ show a ++ show b ++ show c ++ show d @@ -254,9 +295,8 @@ instance Asset Lease where getOriginRate _ = 0.0 isDefaulted (StepUpLease _ _ _ rt Current) = False - isDefaulted (StepUpLease _ _ _ rt _) = True isDefaulted (RegularLease _ _ rt Current) = False - isDefaulted (RegularLease _ _ rt _) = True + isDefaulted _ = True getOriginBal l = let diff --git a/src/Assumptions.hs b/src/Assumptions.hs index 3424d97b..77715f7a 100644 --- a/src/Assumptions.hs +++ b/src/Assumptions.hs @@ -21,7 +21,7 @@ module Assumptions (BondPricingInput(..),IrrType(..) ,_MortgageAssump,_MortgageDeqAssump,_LeaseAssump,_LoanAssump,_InstallmentAssump ,_ReceivableAssump,_FixedAssetAssump ,stressDefaultAssump,applyAssumptionTypeAssetPerf,TradeType(..) - ,LeaseEndType(..) + ,LeaseEndType(..),LeaseDefaultType(..) ) where @@ -189,7 +189,6 @@ data RecoveryAssumption = Recovery (Rate,Int) -- ^ recovery r deriving (Show,Generic,Read) data LeaseAssetGapAssump = GapDays Int -- ^ days between leases, when creating dummy leases - | GapDaysByAmount [(Amount,Int)] Int -- ^ days depends on the size of leases, when a default a default days for size greater | GapDaysByCurve Ts -- ^ days depends on the size of leases, when a default a default days for size greater deriving (Show,Generic,Read) @@ -197,6 +196,11 @@ data LeaseAssetRentAssump = BaseAnnualRate Rate | BaseCurve Ts deriving (Show,Generic,Read) +data LeaseDefaultType = DefaultByContinuation Rate + | DefaultByTermination Rate + deriving (Show,Generic,Read) + + data LeaseEndType = CutByDate Date | StopByExtTimes Int deriving (Show,Generic,Read) @@ -220,7 +224,7 @@ data AssetDelinqPerfAssumption = DummyDelinqAssump data AssetPerfAssumption = MortgageAssump (Maybe AssetDefaultAssumption) (Maybe AssetPrepayAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) | MortgageDeqAssump (Maybe AssetDelinquencyAssumption) (Maybe AssetPrepayAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) - | LeaseAssump (Maybe AssetDefaultAssumption) LeaseAssetGapAssump LeaseAssetRentAssump LeaseEndType + | LeaseAssump (Maybe LeaseDefaultType) LeaseAssetGapAssump LeaseAssetRentAssump LeaseEndType | LoanAssump (Maybe AssetDefaultAssumption) (Maybe AssetPrepayAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) | InstallmentAssump (Maybe AssetDefaultAssumption) (Maybe AssetPrepayAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) | ReceivableAssump (Maybe AssetDefaultAssumption) (Maybe RecoveryAssumption) (Maybe ExtraStress) @@ -335,7 +339,7 @@ $(deriveJSON defaultOptions ''RefiEvent) -$(concat <$> traverse (deriveJSON defaultOptions) [''LeaseEndType,''FieldMatchRule,''TagMatchRule, ''ObligorStrategy,''ApplyAssumptionType, ''AssetPerfAssumption +$(concat <$> traverse (deriveJSON defaultOptions) [''LeaseDefaultType, ''LeaseEndType,''FieldMatchRule,''TagMatchRule, ''ObligorStrategy,''ApplyAssumptionType, ''AssetPerfAssumption , ''AssetDefaultedPerfAssumption, ''AssetDelinqPerfAssumption, ''NonPerfAssumption, ''AssetDefaultAssumption , ''AssetPrepayAssumption, ''RecoveryAssumption, ''ExtraStress , ''LeaseAssetGapAssump, ''LeaseAssetRentAssump, ''RevolvingAssumption, ''AssetDelinquencyAssumption,''InspectType]) diff --git a/src/Cashflow.hs b/src/Cashflow.hs index 4e513605..dde9309e 100644 --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DataKinds #-} module Cashflow (CashFlowFrame(..),Principals,Interests,Amount ,combine,mergePoolCf,sumTsCF,tsSetLoss,tsSetRecovery @@ -23,7 +24,9 @@ module Cashflow (CashFlowFrame(..),Principals,Interests,Amount ,cashflowTxn,clawbackInt,scaleTsRow,mflowFeePaid, currentCumulativeStat, patchCumulativeAtInit ,mergeCf,buildStartTsRow ,txnCumulativeStats,consolidateCashFlow, cfBeginStatus, getBegBalCashFlowFrame - ,splitCashFlowFrameByDate, mergePoolCf2, buildBegBal, extendCashFlow, patchBalance) where + ,splitCashFlowFrameByDate, mergePoolCf2, buildBegBal, extendCashFlow, patchBalance + ,getAllDatesCashFlowFrame,splitCf + ) where import Data.Time (Day) import Data.Fixed @@ -101,10 +104,9 @@ data TsRow = CashFlow Date Amount | MortgageFlow Date Balance Principal Interest Prepayment Default Recovery Loss IRate (Maybe BorrowerNum) (Maybe PrepaymentPenalty) (Maybe CumulativeStat) | MortgageDelinqFlow Date Balance Principal Interest Prepayment Delinquent Default Recovery Loss IRate (Maybe BorrowerNum) (Maybe PrepaymentPenalty) (Maybe CumulativeStat) | LoanFlow Date Balance Principal Interest Prepayment Default Recovery Loss IRate (Maybe CumulativeStat) - | LeaseFlow Date Balance Rental + | LeaseFlow Date Balance Rental Default | FixedFlow Date Balance NewDepreciation Depreciation Balance Balance -- unit cash | ReceivableFlow Date Balance AccuredFee Principal FeePaid Default Recovery Loss (Maybe CumulativeStat) - -- remain balance, amortized amount, unit, cash deriving(Show,Eq,Ord,Generic,NFData) instance Semigroup TsRow where @@ -116,8 +118,8 @@ instance Semigroup TsRow where = MortgageDelinqFlow (max d1 d2) (b1 + b2) (p1 + p2) (i1 + i2) (prep1 + prep2) (delinq1 + delinq2) (def1 + def2) (rec1 + rec2) (los1 + los2) (fromRational (weightedBy (toRational <$> [b1,b2]) (toRational <$> [rat1,rat2]))) (liftA2 (+) mbn1 mbn2) (liftA2 (+) pn1 pn2) (sumStats st1 st2) LoanFlow d1 b1 p1 i1 prep1 def1 rec1 los1 rat1 st1 <> LoanFlow d2 b2 p2 i2 prep2 def2 rec2 los2 rat2 st2 = LoanFlow (max d1 d2) (b1 + b2) (p1 + p2) (i1 + i2) (prep1 + prep2) (def1 + def2) (rec1 + rec2) (los1 + los2) (fromRational (weightedBy (toRational <$> [b1,b2]) (toRational <$> [rat1,rat2]))) (sumStats st1 st2) - LeaseFlow d1 b1 r1 <> LeaseFlow d2 b2 r2 - = LeaseFlow (max d1 d2) (b1 + b2) (r1 + r2) + LeaseFlow d1 b1 r1 def1 <> LeaseFlow d2 b2 r2 def2 + = LeaseFlow (max d1 d2) (b1 + b2) (r1 + r2) (def1 + def2) FixedFlow d1 b1 ndep1 dep1 c1 a1 <> FixedFlow d2 b2 ndep2 dep2 c2 a2 = FixedFlow (max d1 d2) (b1 + b2) (ndep1 + ndep2) (dep1 + dep2) (c1 + c2) (a1 + a2) ReceivableFlow d1 b1 af1 p1 fp1 def1 rec1 los1 st1 <> ReceivableFlow d2 b2 af2 p2 fp2 def2 rec2 los2 st2 @@ -131,7 +133,7 @@ instance TimeSeries TsRow where getDate (MortgageFlow x _ _ _ _ _ _ _ _ _ _ _) = x getDate (MortgageDelinqFlow x _ _ _ _ _ _ _ _ _ _ _ _) = x getDate (LoanFlow x _ _ _ _ _ _ _ _ _) = x - getDate (LeaseFlow x _ _ ) = x + getDate (LeaseFlow x _ _ _) = x getDate (FixedFlow x _ _ _ _ _ ) = x getDate (ReceivableFlow x _ _ _ _ _ _ _ _) = x @@ -168,7 +170,7 @@ scaleTsRow r (MortgageDelinqFlow d b p i prep delinq def rec los rat mbn pp st) (splitStats r <$> st) scaleTsRow r (LoanFlow d b p i prep def rec los rat st) = LoanFlow d (fromRational r * b) (fromRational r * p) (fromRational r * i) (fromRational r * prep) (fromRational r * def) (fromRational r * rec) (fromRational r * los) rat ((splitStats r) <$> st) -scaleTsRow r (LeaseFlow d b rental) = LeaseFlow d (fromRational r * b) (fromRational r * rental) +scaleTsRow r (LeaseFlow d b rental def) = LeaseFlow d (fromRational r * b) (fromRational r * rental) (fromRational r * def) scaleTsRow r (FixedFlow d b ndep dep c a) = FixedFlow d (fromRational r * b) (fromRational r * ndep) (fromRational r * dep) (fromRational r * c) (fromRational r * a) scaleTsRow r (ReceivableFlow d b af p fp def rec los st) = ReceivableFlow d (fromRational r * b) (fromRational r * af) (fromRational r * p) (fromRational r * fp) (fromRational r * def) (fromRational r * rec) (fromRational r * los) ((splitStats r) <$> st) @@ -202,7 +204,7 @@ instance Show CashFlowFrame where getCs (MortgageFlow {}) = ["Balance", "Principal", "Interest", "Prepayment", "Default", "Recovery", "Loss", "IRate", "BorrowerNum", "PrepaymentPenalty", "CumulativeStat"] getCs (MortgageDelinqFlow {}) = [ "Balance", "Principal", "Interest", "Prepayment", "Delinquent", "Default", "Recovery", "Loss", "IRate", "BorrowerNum", "PrepaymentPenalty", "CumulativeStat"] getCs (LoanFlow {}) = ["Balance", "Principal", "Interest", "Prepayment", "Default", "Recovery", "Loss", "IRate", "CumulativeStat"] - getCs (LeaseFlow {}) = [ "Balance", "Rental"] + getCs (LeaseFlow {}) = [ "Balance", "Rental", "Default"] getCs (FixedFlow {}) = [ "Balance", "NewDepreciation", "Depreciation", "Balance", "Amount"] getCs (ReceivableFlow {}) = [ "Balance", "AccuredFee", "Principal", "FeePaid", "Default", "Recovery", "Loss", "CumulativeStat"] colHeader = [TT.Header c | c <- getCs (head txns) ] @@ -211,7 +213,7 @@ instance Show CashFlowFrame where getRs (MortgageFlow d b p i prep def rec los rat mbn pp st) = [ show b, show p, show i, show prep, show def, show rec, show los, show rat, show mbn, show pp, show st] getRs (MortgageDelinqFlow d b p i prep delinq def rec los rat mbn pp st) = [ show b, show p, show i, show prep, show delinq, show def, show rec, show los, show rat, show mbn, show pp, show st] getRs (LoanFlow d b p i prep def rec los rat st) = [ show b, show p, show i, show prep, show def, show rec, show los, show rat, show st] - getRs (LeaseFlow d b r) = [ show b, show r] + getRs (LeaseFlow d b r def) = [ show b, show r, show def] getRs (FixedFlow d b ndep dep c a) = [ show b, show ndep, show dep, show c, show a] getRs (ReceivableFlow d b af p fp def rec los st) = [ show b, show af, show p, show fp, show def, show rec, show los, show st] values = [ getRs txn | txn <- txns ] @@ -229,6 +231,9 @@ sizeCashFlowFrame (CashFlowFrame _ ts) = length ts getDatesCashFlowFrame :: CashFlowFrame -> [Date] getDatesCashFlowFrame (CashFlowFrame _ ts) = getDates ts +getAllDatesCashFlowFrame :: CashFlowFrame -> [Date] +getAllDatesCashFlowFrame (CashFlowFrame (_,d,_) ts) = d : getDates ts + getBegBalCashFlowFrame :: CashFlowFrame -> Balance getBegBalCashFlowFrame (CashFlowFrame _ []) = 0 getBegBalCashFlowFrame (CashFlowFrame _ (cf:cfs)) = mflowBegBalance cf @@ -281,8 +286,8 @@ addTs (MortgageDelinqFlow d1 b1 p1 i1 prep1 delinq1 def1 rec1 los1 rat1 mbn1 pn1 addTs (LoanFlow d1 b1 p1 i1 prep1 def1 rec1 los1 rat1 st1) tr@(LoanFlow _ b2 p2 i2 prep2 def2 rec2 los2 rat2 st2) = LoanFlow d1 (b1 - mflowAmortAmount tr) (p1 + p2) (i1 + i2) (prep1 + prep2) (def1 + def2) (rec1 + rec2) (los1+los2) (fromRational (weightedBy (toRational <$> [b1,b2]) (toRational <$> [rat1,rat2]))) (sumStats st1 st2) -addTs (LeaseFlow d1 b1 r1) tr@(LeaseFlow d2 b2 r2) - = LeaseFlow d1 (b1 - mflowAmortAmount tr) (r1 + r2) +addTs (LeaseFlow d1 b1 r1 def1) tr@(LeaseFlow d2 b2 r2 def2) + = LeaseFlow d1 (b1 - mflowAmortAmount tr) (r1 + r2) (def1 + def2) addTs (ReceivableFlow d1 b1 af1 p1 fp1 def1 rec1 los1 st1) tr@(ReceivableFlow _ b2 af2 p2 fp2 def2 rec2 los2 st2) = ReceivableFlow d1 (b1 - mflowAmortAmount tr) (af1 + af2) (p1 + p2) (fp1 + fp2) (def1 + def2) (rec1 + rec2) (los1 + los2) (sumStats st1 st2) @@ -314,8 +319,8 @@ combineTs (MortgageFlow d1 b1 p1 i1 prep1 def1 rec1 los1 rat1 mbn1 pn1 st1) tr@( combineTs (LoanFlow d1 b1 p1 i1 prep1 def1 rec1 los1 rat1 st1) tr@(LoanFlow _ b2 p2 i2 prep2 def2 rec2 los2 rat2 st2) = LoanFlow d1 (b1 + b2) (p1 + p2) (i1 + i2) (prep1 + prep2) (def1 + def2) (rec1 + rec2) (los1+los2) (fromRational (weightedBy (toRational <$> [b1,b2]) (toRational <$> [rat1,rat2]))) (sumStats st1 st2) -combineTs (LeaseFlow d1 b1 r1) tr@(LeaseFlow d2 b2 r2) - = LeaseFlow d1 (b1 + b2) (r1 + r2) +combineTs (LeaseFlow d1 b1 r1 def1) tr@(LeaseFlow d2 b2 r2 def2) + = LeaseFlow d1 (b1 + b2) (r1 + r2) (def1 + def2) combineTs (FixedFlow d1 b1 de1 cde1 p1 c1 ) (FixedFlow d2 b2 de2 cde2 p2 c2) = FixedFlow d1 (b1+b2) (de1+de2) (cde1+cde2) (p1+p2) (c1+c2) @@ -356,7 +361,7 @@ appendTs bn1@(MortgageFlow d1 b1 p1 i1 prep1 def1 rec1 los1 rat1 mbn1 _ mstat1) = set tsRowBalance (b1 - mflowAmortAmount bn2) bn2 -- `debug` ("Summing stats"++ show bn1 ++ show mstat1++">>"++ show bn2 ++ show mstat2) appendTs (LoanFlow d1 b1 p1 i1 prep1 def1 rec1 los1 rat1 mstat1) bn2@(LoanFlow _ b2 p2 i2 prep2 def2 rec2 los2 rat2 mstat2) = set tsRowBalance (b1 - mflowAmortAmount bn2) bn2 -appendTs (LeaseFlow d1 b1 r1) bn2@(LeaseFlow d2 b2 r2) +appendTs (LeaseFlow d1 b1 r1 def1) bn2@(LeaseFlow d2 b2 r2 def2) = set tsRowBalance (b1 - mflowAmortAmount bn2) bn2 appendTs (FixedFlow d1 b1 de1 cde1 p1 c1 ) bn2@(FixedFlow d2 b2 de2 cde2 p2 c2) = set tsRowBalance (b1 - mflowAmortAmount bn2) bn2 @@ -385,7 +390,7 @@ addTsCF (MortgageDelinqFlow d1 b1 p1 i1 prep1 delinq1 def1 rec1 los1 rat1 mbn1 p MortgageDelinqFlow d1 (min b1 b2) (p1 + p2) (i1 + i2) (prep1 + prep2) delinq (def1 + def2) (rec1 + rec2) (los1+los2) (fromRational (weightedBy (toRational <$> [b1,b2]) (toRational <$> [rat1,rat2]))) bn p st addTsCF (LoanFlow d1 b1 p1 i1 prep1 def1 rec1 los1 rat1 st1) (LoanFlow _ b2 p2 i2 prep2 def2 rec2 los2 rat2 st2) = LoanFlow d1 (min b1 b2) (p1 + p2) (i1 + i2) (prep1 + prep2) (def1 + def2) (rec1 + rec2) (los1+los2) (fromRational (weightedBy (toRational <$> [b1,b2]) (toRational <$> [rat1,rat2]))) (maxStats st1 st2) -addTsCF (LeaseFlow d1 b1 r1) (LeaseFlow d2 b2 r2) = LeaseFlow d1 (min b1 b2) (r1 + r2) +addTsCF (LeaseFlow d1 b1 r1 def1) (LeaseFlow d2 b2 r2 def2) = LeaseFlow d1 (min b1 b2) (r1 + r2) (def1 + def2) addTsCF (FixedFlow d1 b1 dep1 cd1 u1 c1) (FixedFlow d2 b2 dep2 cd2 u2 c2) = FixedFlow d1 (min b1 b2) (dep1 + dep2) (cd1 + cd2) u2 (c1 + c2) addTsCF (ReceivableFlow d1 b1 af1 p1 fp1 def1 rec1 los1 st1) (ReceivableFlow d2 b2 af2 p2 fp2 def2 rec2 los2 st2) @@ -412,7 +417,7 @@ tsTotalCash (BondFlow _ _ a b) = a + b tsTotalCash (MortgageDelinqFlow x _ a b c _ _ e _ _ _ mPn _ ) = a + b + c + e + fromMaybe 0 mPn tsTotalCash (MortgageFlow x _ a b c _ e _ _ _ mPn _) = a + b + c + e + fromMaybe 0 mPn tsTotalCash (LoanFlow _ _ a b c _ e _ _ _) = a + b + c + e -tsTotalCash (LeaseFlow _ _ a) = a +tsTotalCash (LeaseFlow _ _ a _) = a tsTotalCash (FixedFlow _ _ _ _ _ x) = x tsTotalCash (ReceivableFlow _ _ _ a b _ c _ _ ) = a + b + c @@ -422,7 +427,7 @@ tsDefaultBal BondFlow {} = Left "no default amount for bond flow" tsDefaultBal (MortgageDelinqFlow _ _ _ _ _ _ x _ _ _ _ _ _) = Right x tsDefaultBal (MortgageFlow _ _ _ _ _ x _ _ _ _ _ _) = Right x tsDefaultBal (LoanFlow _ _ _ _ _ x _ _ _ _) = Right x -tsDefaultBal LeaseFlow {} = Left "not default amoutn for lease flow" +tsDefaultBal (LeaseFlow _ _ _ x) = Right x tsDefaultBal (FixedFlow _ _ x _ _ _) = Right x tsDefaultBal (ReceivableFlow _ _ _ _ _ x _ _ _ ) = Right x @@ -461,7 +466,7 @@ tsDate = lens getter setter getter (MortgageDelinqFlow x _ _ _ _ _ _ _ _ _ _ _ _) = x getter (MortgageFlow x _ _ _ _ _ _ _ _ _ _ _) = x getter (LoanFlow x _ _ _ _ _ _ _ _ _) = x - getter (LeaseFlow x _ _) = x + getter (LeaseFlow x _ _ _ ) = x getter (FixedFlow x _ _ _ _ _) = x getter (ReceivableFlow x _ _ _ _ _ _ _ _) = x setter (CashFlow _ a) x = CashFlow x a @@ -469,7 +474,7 @@ tsDate = lens getter setter setter (MortgageDelinqFlow _ a b c d e f g h i j k l) x = MortgageDelinqFlow x a b c d e f g h i j k l setter (MortgageFlow _ a b c d e f g h i j k) x = MortgageFlow x a b c d e f g h i j k setter (LoanFlow _ a b c d e f g h i) x = LoanFlow x a b c d e f g h i - setter (LeaseFlow _ a b) x = LeaseFlow x a b + setter (LeaseFlow _ a b c) x = LeaseFlow x a b c setter (FixedFlow _ a b c d e) x = FixedFlow x a b c d e setter (ReceivableFlow _ a b c d e f g h) x = ReceivableFlow x a b c d e f g h @@ -493,7 +498,7 @@ tsOffsetDate x (BondFlow _d a b c) = BondFlow (T.addDays x _d) a b c tsOffsetDate x (MortgageDelinqFlow _d a b c d e f g h i j k l) = MortgageDelinqFlow (T.addDays x _d) a b c d e f g h i j k l tsOffsetDate x (MortgageFlow _d a b c d e f g h i j k) = MortgageFlow (T.addDays x _d) a b c d e f g h i j k tsOffsetDate x (LoanFlow _d a b c d e f g h i) = LoanFlow (T.addDays x _d) a b c d e f g h i -tsOffsetDate x (LeaseFlow _d a b) = LeaseFlow (T.addDays x _d) a b +tsOffsetDate x (LeaseFlow _d a b c) = LeaseFlow (T.addDays x _d) a b c tsOffsetDate x (ReceivableFlow _d a b c d e f g h) = ReceivableFlow (T.addDays x _d) a b c d e f g h tsReduceInt :: Balance -> TsRow -> TsRow @@ -604,7 +609,7 @@ tsRowBalance = lens getter setter getter (MortgageFlow _ x _ _ _ _ _ _ _ _ _ _) = x getter (MortgageDelinqFlow _ x _ _ _ _ _ _ _ _ _ _ _) = x getter (LoanFlow _ x _ _ _ _ _ _ _ _) = x - getter (LeaseFlow _ x _ ) = x + getter (LeaseFlow _ x _ _) = x getter (FixedFlow _ x _ _ _ _) = x getter (ReceivableFlow _ x _ _ _ _ _ _ _ ) = x @@ -612,7 +617,7 @@ tsRowBalance = lens getter setter setter (MortgageFlow a _ p i prep def rec los rat mbn pn st) x = MortgageFlow a x p i prep def rec los rat mbn pn st setter (MortgageDelinqFlow a _ p i prep delinq def rec los rat mbn pn st) x = MortgageDelinqFlow a x p i prep delinq def rec los rat mbn pn st setter (LoanFlow a _ p i prep def rec los rat st) x = LoanFlow a x p i prep def rec los rat st - setter (LeaseFlow a _ r) x = LeaseFlow a x r + setter (LeaseFlow a _ r def) x = LeaseFlow a x r def setter (FixedFlow a _ b c d e) x = FixedFlow a x b c d e setter (ReceivableFlow a _ b c d e f g h) x = ReceivableFlow a x b c d e f g h @@ -622,7 +627,7 @@ mflowBegBalance (BondFlow _ x p _) = x + p mflowBegBalance (MortgageDelinqFlow _ x p _ ppy delinq def _ _ _ _ _ _) = x + p + ppy + delinq mflowBegBalance (MortgageFlow _ x p _ ppy def _ _ _ _ _ _) = x + p + ppy + def mflowBegBalance (LoanFlow _ x p _ ppy def _ _ _ _) = x + p + ppy + def -mflowBegBalance (LeaseFlow _ b r) = b + r +mflowBegBalance (LeaseFlow _ b r def ) = b + r + def mflowBegBalance (FixedFlow a b c d e f ) = b + c mflowBegBalance (ReceivableFlow _ x _ b f def _ _ _) = x + b + def + f @@ -646,7 +651,7 @@ mflowRate (BondFlow _ _ _ _) = 0 mflowRate _ = 0 mflowRental :: TsRow -> Amount -mflowRental (LeaseFlow _ _ x ) = x +mflowRental (LeaseFlow _ _ x _) = x mflowRental x = error ("not support get rental from row"++show x) mflowFeePaid :: TsRow -> Amount @@ -658,7 +663,7 @@ mflowAmortAmount :: TsRow -> Balance mflowAmortAmount (MortgageFlow _ _ p _ ppy def _ _ _ _ _ _) = p + ppy + def mflowAmortAmount (MortgageDelinqFlow _ _ p _ ppy delinq _ _ _ _ _ _ _) = p + ppy + delinq mflowAmortAmount (LoanFlow _ _ x _ y z _ _ _ _) = x + y + z -mflowAmortAmount (LeaseFlow _ _ x ) = x +mflowAmortAmount (LeaseFlow _ _ x def) = x + def mflowAmortAmount (FixedFlow _ _ x _ _ _) = x mflowAmortAmount (BondFlow _ _ p i) = p mflowAmortAmount (ReceivableFlow _ _ _ x f def _ _ _ ) = x + def + f @@ -692,7 +697,7 @@ emptyTsRow :: Date -> TsRow -> TsRow emptyTsRow _d (MortgageDelinqFlow a x c d e f g h i j k l m) = MortgageDelinqFlow _d 0 0 0 0 0 0 0 0 0 Nothing Nothing Nothing emptyTsRow _d (MortgageFlow a x c d e f g h i j k l) = MortgageFlow _d 0 0 0 0 0 0 0 0 Nothing Nothing Nothing emptyTsRow _d (LoanFlow a x c d e f g i j k) = LoanFlow _d 0 0 0 0 0 0 0 0 Nothing -emptyTsRow _d (LeaseFlow a x c ) = LeaseFlow _d 0 0 +emptyTsRow _d (LeaseFlow a x c d) = LeaseFlow _d 0 0 0 emptyTsRow _d (FixedFlow a x c d e f ) = FixedFlow _d 0 0 0 0 0 emptyTsRow _d (BondFlow a x c d) = BondFlow _d 0 0 0 emptyTsRow _d (ReceivableFlow a x c d e f g h i) = ReceivableFlow _d 0 0 0 0 0 0 0 Nothing @@ -712,7 +717,7 @@ viewTsRow :: Date -> TsRow -> TsRow viewTsRow _d (MortgageDelinqFlow a b c d e f g h i j k l m) = MortgageDelinqFlow _d b 0 0 0 0 0 0 0 j k l m viewTsRow _d (MortgageFlow a b c d e f g h i j k l) = MortgageFlow _d b 0 0 0 0 0 0 i j k l viewTsRow _d (LoanFlow a b c d e f g i j k) = LoanFlow _d b 0 0 0 0 0 0 j k -viewTsRow _d (LeaseFlow a b c ) = LeaseFlow _d b 0 +viewTsRow _d (LeaseFlow a b c d) = LeaseFlow _d b 0 0 viewTsRow _d (FixedFlow a b c d e f ) = FixedFlow _d b 0 0 0 0 viewTsRow _d (BondFlow a b c d) = BondFlow _d b 0 0 viewTsRow _d (ReceivableFlow a b c d e f g h i) = ReceivableFlow _d b 0 0 0 0 0 0 i @@ -813,6 +818,7 @@ patchBalance (bal,stat) r (tr:trs) = patchBalance (newBal,stat) (rWithUpdatedBal:r) trs -- type CumulativeStat = (CumPrincipal,CumPrepay,CumDelinq,CumDefault,CumRecovery,CumLoss) +-- calcBeginStats :: Maybe CumulativeStat -> TsRow -> CumulativeStat calcBeginStats Nothing tr = (0,0,0,0,0,0) calcBeginStats (Just (cumPrin,cumPrepay,cumDlinq,cumDef,cumRec,cumLoss)) tr @@ -827,8 +833,8 @@ calcBeginStats (Just (cumPrin,cumPrepay,cumDlinq,cumDef,cumRec,cumLoss)) tr (cumPrin - p, 0 , 0 , cumDef - def, cumRec - rec , cumLoss - los) (BondFlow _ _ p i) -> (cumPrin - p,0 , 0 , 0, 0, 0) - (LeaseFlow _ b r) -> - (cumPrin - r,0 , 0, 0, 0, 0) + (LeaseFlow _ b r def ) -> + (cumPrin - r,0 , 0, cumDef - def, 0, 0) (FixedFlow _ b c d e _ ) -> (0, 0 ,0 , 0, 0, 0) (CashFlow _ amt) -> (0,0,0,0,0,0) @@ -951,11 +957,19 @@ splitTs r (MortgageFlow d bal p i ppy def recovery loss rate mB mPPN mStat) (mulBR def r) (mulBR recovery r) (mulBR loss r) rate ((\x -> round (toRational x * r)) <$> mB) ((`mulBR` r) <$> mPPN) (splitStats r <$> mStat) +splitTs r (LeaseFlow d bal p def) + = LeaseFlow d (mulBR bal r) (mulBR p r) (mulBR def r) splitTs _ tr = error $ "Not support for spliting TsRow"++show tr splitTrs :: Rate -> [TsRow] -> [TsRow] splitTrs r trs = splitTs r <$> trs +splitCf :: Rate -> CashFlowFrame -> CashFlowFrame +splitCf 1 cf = cf +splitCf r (CashFlowFrame st []) = CashFlowFrame st [] +splitCf r (CashFlowFrame (begBal, begDate, mAccInt) trs) + = CashFlowFrame (mulBR begBal r, begDate, (`mulBR` r) <$> mAccInt) $ splitTrs r trs -- `debug` ("split by rate"++ show (fromRational r)) + currentCumulativeStat :: [TsRow] -> CumulativeStat currentCumulativeStat [] = (0,0,0,0,0,0) currentCumulativeStat trs = @@ -1035,9 +1049,9 @@ patchCumulative (cPrin,cPrepay,cDelinq,cDefault,cRecovery,cLoss) patchCumulative (cPrin,cPrepay,cDelinq,cDefault,cRecovery,cLoss) rs - ((LeaseFlow a b c) :trs) + ((LeaseFlow a b c d) :trs) = patchCumulative newSt - (LeaseFlow a b c:rs) + (LeaseFlow a b c d:rs) trs where newSt = (0,0,0,0,0,0) @@ -1068,7 +1082,7 @@ isEmptyRow :: TsRow -> Bool isEmptyRow (MortgageDelinqFlow _ 0 0 0 0 0 0 0 0 _ _ _ _) = True isEmptyRow (MortgageFlow _ 0 0 0 0 0 0 0 _ _ _ _) = True isEmptyRow (LoanFlow _ 0 0 0 0 0 0 0 i j ) = True -isEmptyRow (LeaseFlow _ 0 0) = True +isEmptyRow (LeaseFlow _ 0 0 0) = True isEmptyRow (FixedFlow _ 0 0 0 0 0) = True isEmptyRow (BondFlow _ 0 0 0) = True isEmptyRow (CashFlow _ 0) = True @@ -1079,7 +1093,7 @@ isEmptyRow2 :: TsRow -> Bool isEmptyRow2 (MortgageDelinqFlow _ _ 0 0 0 0 0 0 0 _ _ _ _) = True isEmptyRow2 (MortgageFlow _ _ 0 0 0 0 0 0 _ _ _ _) = True isEmptyRow2 (LoanFlow _ _ 0 0 0 0 0 0 i j ) = True -isEmptyRow2 (LeaseFlow _ _ 0) = True +isEmptyRow2 (LeaseFlow _ _ 0 _) = True isEmptyRow2 (FixedFlow _ _ 0 0 0 0) = True isEmptyRow2 (BondFlow _ _ 0 0) = True isEmptyRow2 (CashFlow _ 0) = True diff --git a/src/Lib.hs b/src/Lib.hs index e535c5b4..fad28acd 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -11,7 +11,7 @@ module Lib ,periodRateFromAnnualRate ,Floor,Cap,TsPoint(..) ,toDate,toDates,genDates,nextDate - ,getValOnByDate,sumValTs,subTsBetweenDates,splitTsByDate + ,getValOnByDate,getIntValOnByDate,sumValTs,subTsBetweenDates,splitTsByDate ,paySeqLiabilitiesAmt,getIntervalDays,getIntervalFactors ,zipWith8,zipWith9,zipWith10,zipWith11,zipWith12 ,weightedBy, mkTs @@ -137,6 +137,12 @@ getValOnByDate (BalanceCurve dps) d Just (TsPoint _d v) -> v Nothing -> 0 +getIntValOnByDate :: Ts -> Date -> Int +getIntValOnByDate (IntCurve dps) d + = case find (\(TsPoint _d _) -> ( d >= _d )) (reverse dps) of + Just (TsPoint _d v) -> v + Nothing -> 0 + splitTsByDate :: Ts -> T.Day -> (Ts, Ts) splitTsByDate (BalanceCurve ds) d diff --git a/src/Types.hs b/src/Types.hs index 2381dfcc..28bc2c8f 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -428,6 +428,7 @@ data Ts = FloatCurve [TsPoint Rational] | FactorCurveClosed [TsPoint Rational] Date | PricingCurve [TsPoint Rational] | PeriodCurve [TsPoint Int] + | IntCurve [TsPoint Int] deriving (Show,Eq,Ord,Read,Generic) diff --git a/src/Util.hs b/src/Util.hs index 8281cdab..712f788e 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -16,7 +16,7 @@ module Util ,lookupInMap,selectInMap,scaleByFstElement ,lookupTuple6 ,lookupTuple7,diffNum -- for debug - ,debugOnDate,paySeqM + ,debugOnDate,paySeqM,splitByLengths ) where import qualified Data.Time as T @@ -461,6 +461,13 @@ lookupTuple7 (k1, k2, k3, k4, k5, k6, k7) m = ( Map.lookup k1 m , Map.lookup k2 m , Map.lookup k3 m , Map.lookup k4 m , Map.lookup k5 m , Map.lookup k6 m, Map.lookup k7 m) +splitByLengths :: Num a => [a] -> [Int] -> [[a]] +splitByLengths xs ns = go xs ns + where + go _ [] = [] + go [] _ = [] + go xs (n:ns) = take n xs : go (drop n xs) ns + ----- DEBUG/PRINT debugOnDate :: Date -> Date -> Date -> String debugOnDate d1 d2 d diff --git a/swagger.json b/swagger.json index 01f067de..17df31f2 100644 --- a/swagger.json +++ b/swagger.json @@ -3038,7 +3038,7 @@ "contents": { "items": [ { - "$ref": "#/components/schemas/AssetDefaultAssumption" + "$ref": "#/components/schemas/LeaseDefaultType" }, { "$ref": "#/components/schemas/LeaseAssetGapAssump" @@ -10755,39 +10755,35 @@ { "properties": { "contents": { - "items": [ - { - "items": { - "items": [ - { - "multipleOf": 1.0e-2, - "type": "number" - }, - { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" - } - ], - "maxItems": 2, - "minItems": 2, - "type": "array" - }, - "type": "array" - }, - { - "maximum": 9223372036854775807, - "minimum": -9223372036854775808, - "type": "integer" - } + "$ref": "#/components/schemas/Ts" + }, + "tag": { + "enum": [ + "GapDaysByCurve" ], - "maxItems": 2, - "minItems": 2, - "type": "array" + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "GapDaysByCurve", + "type": "object" + } + ] + }, + "LeaseAssetRentAssump": { + "oneOf": [ + { + "properties": { + "contents": { + "format": "double", + "type": "number" }, "tag": { "enum": [ - "GapDaysByAmount" + "BaseAnnualRate" ], "type": "string" } @@ -10796,7 +10792,7 @@ "tag", "contents" ], - "title": "GapDaysByAmount", + "title": "BaseAnnualRate", "type": "object" }, { @@ -10806,7 +10802,7 @@ }, "tag": { "enum": [ - "GapDaysByCurve" + "BaseCurve" ], "type": "string" } @@ -10815,12 +10811,12 @@ "tag", "contents" ], - "title": "GapDaysByCurve", + "title": "BaseCurve", "type": "object" } ] }, - "LeaseAssetRentAssump": { + "LeaseDefaultType": { "oneOf": [ { "properties": { @@ -10830,7 +10826,7 @@ }, "tag": { "enum": [ - "BaseAnnualRate" + "DefaultByContinuation" ], "type": "string" } @@ -10839,17 +10835,18 @@ "tag", "contents" ], - "title": "BaseAnnualRate", + "title": "DefaultByContinuation", "type": "object" }, { "properties": { "contents": { - "$ref": "#/components/schemas/Ts" + "format": "double", + "type": "number" }, "tag": { "enum": [ - "BaseCurve" + "DefaultByTermination" ], "type": "string" } @@ -10858,7 +10855,7 @@ "tag", "contents" ], - "title": "BaseCurve", + "title": "DefaultByTermination", "type": "object" } ] @@ -18823,6 +18820,28 @@ ], "title": "PeriodCurve", "type": "object" + }, + { + "properties": { + "contents": { + "items": { + "$ref": "#/components/schemas/TsPoint_Int" + }, + "type": "array" + }, + "tag": { + "enum": [ + "IntCurve" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "IntCurve", + "type": "object" } ] }, @@ -19308,13 +19327,17 @@ "multipleOf": 1.0e-2, "type": "number" }, + { + "multipleOf": 1.0e-2, + "type": "number" + }, { "multipleOf": 1.0e-2, "type": "number" } ], - "maxItems": 3, - "minItems": 3, + "maxItems": 4, + "minItems": 4, "type": "array" }, "tag": { @@ -20692,7 +20715,7 @@ "name": "BSD 3" }, "title": "Hastructure API", - "version": "0.45.3" + "version": "0.45.4" }, "openapi": "3.0.0", "paths": { diff --git a/test/MainTest.hs b/test/MainTest.hs index 38143a03..4730a3d4 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -107,6 +107,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,AnalyticsT.fvTest ,AnalyticsT.assetPricingTest ,AnalyticsT.irrTest + ,AnalyticsT.survivorTest ,DealTest.baseTests ,RevolvingTest.baseTests ,DealMultiTest.mPoolbaseTests diff --git a/test/UT/AnalyticsTest.hs b/test/UT/AnalyticsTest.hs index f2cbdcb8..68b35175 100644 --- a/test/UT/AnalyticsTest.hs +++ b/test/UT/AnalyticsTest.hs @@ -1,4 +1,4 @@ -module UT.AnalyticsTest(walTest,durationTest,fvTest,assetPricingTest,irrTest) +module UT.AnalyticsTest(walTest,durationTest,fvTest,assetPricingTest,irrTest,survivorTest) where import Test.Tasty @@ -124,3 +124,14 @@ irrTest = -- assertEqual "0.5-year" -- 103.89 -- (fv2 0.08 (L.toDate "20230101") (L.toDate "20230701") 100) +survivorTest = + testGroup "Survivor Test" [ + testCase "Survivor 1" $ + assertEqual "12 months" + [0.9] + (calcSurvivorFactors (L.toDate "20230101") [(L.toDate "20240101")] 0.1) + ,testCase "Survivor 2" $ + assertEqual "3 months" + [0.9743552534572951,0.9] + (calcSurvivorFactors (L.toDate "20230101") [(L.toDate "20230401"),(L.toDate "20240101")] 0.1) + ] \ No newline at end of file diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index 78132882..a6d5aac5 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -310,11 +310,11 @@ leaseTests = (CF.getDate <$> (cf1 ^. CF.cashflowTxn)) ,testCase "1 year Regular Lease sum of rentals/first" $ assertEqual "First flow" - (CF.LeaseFlow (L.toDate "20230630") 184.00 30.0) + (CF.LeaseFlow (L.toDate "20230630") 184.00 30.0 0.0) (head (cf1 ^. CF.cashflowTxn)) ,testCase "1 year Regular Lease sum of rentals/last" $ assertEqual "Last flow" - (CF.LeaseFlow (L.toDate "20231231") 0.00 31.0) + (CF.LeaseFlow (L.toDate "20231231") 0.00 31.0 0.0) (last (cf1 ^. CF.cashflowTxn)) ,testCase "1 year Regular Lease sum of rentals" $ assertEqual "total rental" @@ -326,7 +326,7 @@ leaseTests = (head (CF.getDatesCashFlowFrame cf1)) ,testCase "1 year Stepup lease first pay" $ assertEqual "first pay" - (CF.LeaseFlow (L.toDate "20230630") 376.24 29) + (CF.LeaseFlow (L.toDate "20230630") 376.24 29 0.0) (head (cf2 ^. CF.cashflowTxn)) ,testCase "1 year Stepup lease" $ assertEqual "total rental" @@ -334,23 +334,23 @@ leaseTests = (sum $ map CF.tsTotalCash (cf2 ^. CF.cashflowTxn)) ,testCase "1 year Stepup lease" $ assertEqual "first rental step up at Month 2" - (CF.LeaseFlow (L.toDate "20230731") 344.62 31.62) + (CF.LeaseFlow (L.toDate "20230731") 344.62 31.62 0.0) ((cf2 ^. CF.cashflowTxn)!!1) ,testCase "1 year Stepup Curve lease" $ assertEqual "first rental step up at Month 0" - (CF.LeaseFlow (L.toDate "20230430") 100.59 29.0) + (CF.LeaseFlow (L.toDate "20230430") 100.59 29.0 0.0) (head (cf3_0 ^. CF.cashflowTxn )) ,testCase "1 year Stepup Curve lease" $ assertEqual "first rental step up at Month 1" - (CF.LeaseFlow (L.toDate "20230630") 35.65 32.7) + (CF.LeaseFlow (L.toDate "20230630") 35.65 32.7 0.0) (head (cf3 ^. CF.cashflowTxn)) -- `debug` ("CF3->"++show cf3) ,testCase "1 year Stepup Curve lease" $ assertEqual "first rental step up at Month 2" - (CF.LeaseFlow (L.toDate "20230731") 0 35.65) + (CF.LeaseFlow (L.toDate "20230731") 0 35.65 0.0) ((cf3 ^. CF.cashflowTxn)!!1) ,testCase "Lease with Assumptions" $ assertEqual "Month Gap=45 days" - ((CF.LeaseFlow (L.toDate "20240630") 215 30.0),(CF.LeaseFlow (L.toDate "20250131") 0 31)) + ((CF.LeaseFlow (L.toDate "20240630") 215 30.0 0.0),(CF.LeaseFlow (L.toDate "20250131") 0 31 0)) (((cf4 ^. CF.cashflowTxn)!!11),(last (cf4 ^. CF.cashflowTxn))) -- `debug` ("CF4->"++show cf4) -- ,testCase "Lease with Assumptions" $ -- assertEqual "Month Gap by Table : New Lease at period 0" From 6d0615ddbdbecff88f22be91d75febfb86989bb2 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Mon, 12 May 2025 20:08:24 +0800 Subject: [PATCH 45/53] add default value to pricing function --- src/Deal.hs | 2 +- src/Types.hs | 1 + swagger.json | 15 +++++++++++++++ 3 files changed, 17 insertions(+), 1 deletion(-) diff --git a/src/Deal.hs b/src/Deal.hs index e33dc5be..bf5e0a03 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -984,7 +984,7 @@ runDeal t _ perfAssumps nonPerfAssumps@AP.NonPerfAssumption{AP.callWhen = opts , let poolFlowUsedNoEmpty = Map.map (over CF.cashflowTxn CF.dropTailEmptyTxns) poolFlowUsed bndPricing <- case mPricing of (Just p) -> priceBonds finalDeal p - Nothing -> Right Map.empty + Nothing -> Right $ Map.singleton "No Pricing" PriceResultNull return (finalDeal, Just poolFlowUsedNoEmpty, Just (getRunResult finalDeal ++ V.validateRun finalDeal ++ DL.toList logs), bndPricing) -- `debug` ("Run Deal end with") where (runFlag, valLogs) = V.validateReq t nonPerfAssumps diff --git a/src/Types.hs b/src/Types.hs index 28bc2c8f..5a3f876e 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -788,6 +788,7 @@ data PriceResult = PriceResult Valuation PerFace WAL Duration Convexity AccruedI | OASResult PriceResult [Valuation] Spread | ZSpread Spread | IrrResult IRR [Txn] + | PriceResultNull deriving (Show, Eq, Generic) getPriceValue :: PriceResult -> Balance diff --git a/swagger.json b/swagger.json index 17df31f2..0a27326a 100644 --- a/swagger.json +++ b/swagger.json @@ -14403,6 +14403,21 @@ ], "title": "IrrResult", "type": "object" + }, + { + "properties": { + "tag": { + "enum": [ + "PriceResultNull" + ], + "type": "string" + } + }, + "required": [ + "tag" + ], + "title": "PriceResultNull", + "type": "object" } ] }, From cb675a251ed4a3be8ef385d5084707ce9736adf4 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 13 May 2025 00:13:17 +0800 Subject: [PATCH 46/53] Revert "add default value to pricing function" This reverts commit 6d0615ddbdbecff88f22be91d75febfb86989bb2. --- src/Deal.hs | 2 +- src/Types.hs | 1 - swagger.json | 15 --------------- 3 files changed, 1 insertion(+), 17 deletions(-) diff --git a/src/Deal.hs b/src/Deal.hs index bf5e0a03..e33dc5be 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -984,7 +984,7 @@ runDeal t _ perfAssumps nonPerfAssumps@AP.NonPerfAssumption{AP.callWhen = opts , let poolFlowUsedNoEmpty = Map.map (over CF.cashflowTxn CF.dropTailEmptyTxns) poolFlowUsed bndPricing <- case mPricing of (Just p) -> priceBonds finalDeal p - Nothing -> Right $ Map.singleton "No Pricing" PriceResultNull + Nothing -> Right Map.empty return (finalDeal, Just poolFlowUsedNoEmpty, Just (getRunResult finalDeal ++ V.validateRun finalDeal ++ DL.toList logs), bndPricing) -- `debug` ("Run Deal end with") where (runFlag, valLogs) = V.validateReq t nonPerfAssumps diff --git a/src/Types.hs b/src/Types.hs index 5a3f876e..28bc2c8f 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -788,7 +788,6 @@ data PriceResult = PriceResult Valuation PerFace WAL Duration Convexity AccruedI | OASResult PriceResult [Valuation] Spread | ZSpread Spread | IrrResult IRR [Txn] - | PriceResultNull deriving (Show, Eq, Generic) getPriceValue :: PriceResult -> Balance diff --git a/swagger.json b/swagger.json index 0a27326a..17df31f2 100644 --- a/swagger.json +++ b/swagger.json @@ -14403,21 +14403,6 @@ ], "title": "IrrResult", "type": "object" - }, - { - "properties": { - "tag": { - "enum": [ - "PriceResultNull" - ], - "type": "string" - } - }, - "required": [ - "tag" - ], - "title": "PriceResultNull", - "type": "object" } ] }, From 965a2389cc347beb610ad70f969877509b4f7847 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 13 May 2025 00:04:50 +0800 Subject: [PATCH 47/53] fix frist loss algo --- Hastructure.cabal | 8 ++++++++ app/Main.hs | 6 +++--- 2 files changed, 11 insertions(+), 3 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index 48455140..9937f210 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -75,7 +75,15 @@ library src build-depends: Decimal + , base-compat + , attoparsec + , string-conversions + , warp + , wai-cors + , http-types + , exceptions , aeson + , attoparsec-aeson , aeson-pretty , base , bytestring diff --git a/app/Main.hs b/app/Main.hs index 68a42267..17eadd31 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -296,14 +296,14 @@ testByDefault dt assumps nonPerfAssump@AP.NonPerfAssumption{AP.revolving = mRevo = let stressed = over (AP.applyAssumptionTypeAssetPerf . _1 ) (stressAssetPerf (toRational r)) assumps stressedNonPerf = nonPerfAssump {AP.revolving = stressRevovlingPerf (toRational r) mRevolving } - runResult = wrapRun dt (Just stressed) stressedNonPerf + runResult = wrapRun dt (Just stressed) stressedNonPerf -- `debug` ("running stress "++ show stressed) in case runResult of Right (d,mPoolCfMap,mResult,mPricing) -> let - bondBal = L.getOutstandingAmount $ (getDealBondMap dt) Map.! bn + bondBal = L.getOutstandingAmount $ (getDealBondMap d) Map.! bn in - (fromRational (toRational bondBal) - 0.01) + (fromRational (toRational bondBal) - 0.01) -- `debug` (">>> test run result"++ show (fromRational (toRational bondBal) - 0.01)) Left errorMsg -> error $ "Error in test fun for first loss" ++ show errorMsg From 1c5cd3084aad9755e1b3269d67634c03bae99e75 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Tue, 13 May 2025 00:15:40 +0800 Subject: [PATCH 48/53] bump version to-> < 0.45.5 > --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 17eadd31..1f5f7de4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.45.4" +version1 = Version "0.45.5" wrapRun :: DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From 082b68be94f998439841834552bdbc5d6569ae08 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Thu, 22 May 2025 00:12:27 +0800 Subject: [PATCH 49/53] LEASE: fix current balance --- CHANGELOG.md | 13 ++++++++++++- src/AssetClass/Lease.hs | 34 +++++++++++++--------------------- swagger.json | 2 +- 3 files changed, 26 insertions(+), 23 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 8bc85de2..83019f08 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,16 +2,27 @@ +## 0.45.5 +### 2025-05-20 +* NEW: `MaxSpread` feature for structuring stage: get max possible bond coupon rate ! +* ENHANCE: Transfer from `stack` to `cabal` as build tool +* ENHANCE: Apply `DList` to trigger log +* ENHANCE: Enable `Double Decline Balance` in `FixedAsset` +* REFACTOR: Refactor `Leasing` asset type + * Add `Default` assumption + * Add `Period-based` rental ,in addition to `Day-based` rental calculation + + ## 0.45.2 ### 2025-04-01 * ENHANCE: Performance optimization by replace `List` with `DList`. * ENHANCE: In `inspection` ,expose `IsOutstanding` `HasPassedMaturity` in `Pre` + ## 0.45.1 ### 2025-03-25 * FIX: in `Pricing/IRR`, error when holding position is too small * ENHANCE: engine will auto patch `interest start date` for bonds if it is not modeled. In `PreClosing` status, engine will use `closing date` as bond interest begin date ; In `Non-PreClosing` status, it defaults to use last waterfall distribution date as bond interest begin date. - ## 0.45.0 ### 2025-03-21 * BREAK: remove unused `DealDates` : `FixInterval`, `CustomDates` and `PatternInterval`. Since all these can be replace by new `GenericDates` in type `DateDesp` diff --git a/src/AssetClass/Lease.hs b/src/AssetClass/Lease.hs index 30f77952..8ec66ac5 100644 --- a/src/AssetClass/Lease.hs +++ b/src/AssetClass/Lease.hs @@ -126,8 +126,8 @@ patchBalance :: Lease -> Either String (Lease,[Amount]) patchBalance l@(RegularLease (LeaseInfo sd ot (ByDayRate dr dp) ob) bal rt st) = let cf_dates = sd:getPaymentDates l 0 - pmts = [ fromRational (mulBInt dr ds) | ds <- getIntervalDays cf_dates ] - new_bal = sum pmts -- `debug` ("cf_date" ++ show cf_dates) + pmts = lastN rt $ [ fromRational (mulBInt dr ds) | ds <- getIntervalDays cf_dates ] + new_bal = sum pmts in Right (RegularLease (LeaseInfo sd ot (ByDayRate dr dp) ob) new_bal rt st, pmts) @@ -135,11 +135,11 @@ patchBalance l@(RegularLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) ba = let -- cf_dates = lastN (succ rt) $ getPaymentDates l 0 -- intervals = daysInterval cf_dates - pmts = replicate ot rental - new_bal = sum pmts + pmts = lastN rt $ replicate ot rental + new_bal = sum pmts -- `debug` ("cf_date" ++ show cf_dates) in do - return (RegularLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) new_bal rt st,pmts) -- `debug` ("daily payments" ++ show pmts) + return (RegularLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) new_bal rt st, pmts) -- `debug` ("daily payments" ++ show pmts) patchBalance l@(StepUpLease (LeaseInfo sd ot (ByDayRate dr p) ob) lsu bal rt st) @@ -150,9 +150,9 @@ patchBalance l@(StepUpLease (LeaseInfo sd ot (ByDayRate dr p) ob) lsu bal rt st) in do dailyRentals <- calcPmts lsu factors dr - let pmts = [ fromRational (mulBInteger r d) | (d,r) <- zip intervals dailyRentals ] - let new_bal = sum pmts - return (StepUpLease (LeaseInfo sd ot (ByDayRate dr p) ob) lsu new_bal rt st,pmts) -- `debug` ("daily payments" ++ show pmts) + let pmts = lastN rt $ [ fromRational (mulBInteger r d) | (d,r) <- zip intervals dailyRentals ] + let new_bal = sum pmts -- `debug` ("cf_date" ++ show cf_dates) + return (StepUpLease (LeaseInfo sd ot (ByDayRate dr p) ob) lsu new_bal rt st, pmts) -- `debug` ("daily payments" ++ show pmts) patchBalance l@(StepUpLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) lsu bal rt st) = let @@ -160,8 +160,9 @@ patchBalance l@(StepUpLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) lsu in do periodRentals <- calcPmts lsu factors rental - let new_bal = sum periodRentals - return (StepUpLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) lsu new_bal rt st,periodRentals) -- `debug` ("daily payments" ++ show pmts) + let pmts = lastN rt periodRentals + let new_bal = sum pmts + return (StepUpLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) lsu new_bal rt st, pmts) -- `debug` ("daily payments" ++ show pmts) allocDefaultToLeaseFlow :: [Rate] -> (Rate,Balance) -> [CF.TsRow] -> [CF.TsRow] -> [CF.TsRow] @@ -219,19 +220,10 @@ instance Asset Lease where (l',pmts) <- patchBalance l let bal = getCurrentBal l' -- `debug` ("payments"++ show pmts) let pDates = lastN (getRemainTerms l) $ getPaymentDates l 0 - let bals = tail $ scanl (-) bal pmts -- `debug` ("pDates "++ show pDates) - let defaults = replicate (length pDates) 0.0 + let bals = tail $ scanl (-) bal pmts -- `debug` ("pDates "++ show pDates) + let defaults = replicate (length pDates) 0.0 -- `debug` ("bals"++ show bals++ ">> d"++ show d) return $ CF.CashFlowFrame (head bals,max d (getOriginDate l),Nothing) $ cutBy Inc Future d (zipWith4 CF.LeaseFlow pDates bals pmts defaults) - -- calcCashflow l@(StepUpLease (LeaseInfo sd ot or ob) lsu bal rt st) d _ = - -- do - -- (l' ,pmts) <- patchBalance l - -- let bal = getCurrentBal l' - -- let pDates = lastN rt $ getPaymentDates l 0 - -- let bals = tail $ scanl (-) bal pmts - -- return $ CF.CashFlowFrame (head bals,d,Nothing) $ cutBy Inc Future d (zipWith3 CF.LeaseFlow pDates bals pmts) - - getOriginInfo (StepUpLease lInfo lsteupInfo bal rt st) = lInfo getOriginInfo (RegularLease lInfo bal rt st) = lInfo diff --git a/swagger.json b/swagger.json index 17df31f2..74816c98 100644 --- a/swagger.json +++ b/swagger.json @@ -20715,7 +20715,7 @@ "name": "BSD 3" }, "title": "Hastructure API", - "version": "0.45.4" + "version": "0.45.5" }, "openapi": "3.0.0", "paths": { From 4055839c78312ad48472ba34efe5289fcd264a0b Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sun, 25 May 2025 19:28:11 +0800 Subject: [PATCH 50/53] fix default on rental algo --- src/AssetClass/Lease.hs | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/src/AssetClass/Lease.hs b/src/AssetClass/Lease.hs index 8ec66ac5..2112e7d6 100644 --- a/src/AssetClass/Lease.hs +++ b/src/AssetClass/Lease.hs @@ -20,6 +20,7 @@ import DateUtil import qualified Data.Map as Map import Data.List import Data.Aeson hiding (json) +import Data.Decimal import Language.Haskell.TH import Data.Aeson.TH import Data.Aeson.Types @@ -166,15 +167,17 @@ patchBalance l@(StepUpLease (LeaseInfo sd ot (ByPeriodRental rental per) ob) lsu allocDefaultToLeaseFlow :: [Rate] -> (Rate,Balance) -> [CF.TsRow] -> [CF.TsRow] -> [CF.TsRow] +-- allocDefaultToLeaseFlow :: [Decimal] -> (Decimal,Decimal) -> [CF.TsRow] -> [CF.TsRow] -> [CF.TsRow] allocDefaultToLeaseFlow defaultRates (begFactor,begBal) rs [] = reverse rs allocDefaultToLeaseFlow (defaultRate:defaultRates) (begFactor,begBal) rs (txn@(CF.LeaseFlow d b r def):txns) = let defaultAmt = mulBR begBal defaultRate nextFactor = begFactor * (1-defaultRate) newRental = mulBR r nextFactor - nextBal = min (begBal - defaultAmt - newRental) b -- TODO: hardcode to fix rounding issue + rentalDiff = r - newRental + nextBal = (begBal - rentalDiff - newRental) -- TODO: hardcode to fix rounding issue in - allocDefaultToLeaseFlow defaultRates (nextFactor,nextBal) ((CF.LeaseFlow d nextBal newRental defaultAmt):rs) txns + allocDefaultToLeaseFlow defaultRates (nextFactor,nextBal) ((CF.LeaseFlow d nextBal newRental rentalDiff):rs) txns calcDefaultRates :: Rate -> CF.CashFlowFrame -> [Rate] calcDefaultRates r cf @@ -191,9 +194,9 @@ applyDefaults Nothing (CF.CashFlowFrame _ txn1,cfs) = (txn1,view CF.cashflowTxn applyDefaults (Just (AP.DefaultByTermination r)) (cf1,cfs) = let cf1Factors = calcDefaultRates r cf1 - cfsFactors::[[Rate]] = (calcDefaultRates r) <$> cfs + cfsFactors::[[Rate]] = calcDefaultRates r <$> cfs in - (allocDefaultToLeaseFlow cf1Factors (1.0,(CF.getBegBalCashFlowFrame cf1)) [] (view CF.cashflowTxn cf1) + (allocDefaultToLeaseFlow cf1Factors (1.0, (CF.getBegBalCashFlowFrame cf1)) [] (view CF.cashflowTxn cf1) , (\(fs,cf) -> allocDefaultToLeaseFlow fs (1.0, (CF.getBegBalCashFlowFrame cf)) [] (view CF.cashflowTxn cf)) <$> (zip cfsFactors cfs) ) From f544050291e4f24d1c84230e8f7faaf60cef8420 Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Sun, 25 May 2025 21:24:41 +0800 Subject: [PATCH 51/53] bump version to-> < 0.45.6 > --- app/Main.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/app/Main.hs b/app/Main.hs index 1f5f7de4..a4fdd9e9 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.45.5" +version1 = Version "0.45.6" wrapRun :: DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From 3de2c31cb4436ef21e542c31fa1404e4e354d40f Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Mon, 26 May 2025 21:30:43 +0800 Subject: [PATCH 52/53] expose rental change vec --- src/AssetClass/Lease.hs | 66 +++++++++++++++++++++++++++-------------- src/Assumptions.hs | 1 + swagger.json | 25 +++++++++++++++- 3 files changed, 69 insertions(+), 23 deletions(-) diff --git a/src/AssetClass/Lease.hs b/src/AssetClass/Lease.hs index 2112e7d6..6e25365c 100644 --- a/src/AssetClass/Lease.hs +++ b/src/AssetClass/Lease.hs @@ -44,20 +44,39 @@ type TermChangeRate = Rate type DayGap = Int type LastAccuredDate = Date -calcChangeRateOnRental :: AP.LeaseAssetRentAssump -> Date -> Date -> Rate -calcChangeRateOnRental (AP.BaseAnnualRate r) sd ed = 1 + yearCountFraction DC_ACT_365F sd ed * r -calcChangeRateOnRental (AP.BaseCurve rc) sd ed = 1 + yearCountFraction DC_ACT_365F sd ed * getValByDate rc Exc ed -getNewRental :: AP.LeaseAssetRentAssump -> Date -> Date -> LeaseRateCalc -> LeaseRateCalc +getNewRental :: AP.LeaseAssetRentAssump -> Date -> Date -> LeaseRateCalc -> (AP.LeaseAssetRentAssump, LeaseRateCalc) +-- by day rate getNewRental (AP.BaseAnnualRate r) sd ed (ByDayRate dr dp) - = ByDayRate (mulBR dr (1 + yearCountFraction DC_ACT_365F sd ed * fromRational r)) dp + = (AP.BaseAnnualRate r + , ByDayRate (mulBR dr (1 + yearCountFraction DC_ACT_365F sd ed * fromRational r)) dp) getNewRental (AP.BaseCurve rc) sd ed (ByDayRate dr dp) - = ByDayRate (mulBR dr (1 + yearCountFraction DC_ACT_365F sd ed * getValByDate rc Exc ed)) dp + = (AP.BaseCurve rc + , ByDayRate (mulBR dr (1 + yearCountFraction DC_ACT_365F sd ed * getValByDate rc Exc ed)) dp) +getNewRental (AP.BaseByVec rs) sd ed (ByDayRate dr dp) + = let + (newDr,nextRs) = case Data.List.uncons rs of + Just (r,_rs) -> (mulBR dr (1 + yearCountFraction DC_ACT_365F sd ed * fromRational r) + , _rs) + Nothing -> (dr,[0.0]) + in + (AP.BaseByVec nextRs, ByDayRate newDr dp) +-- by period rental getNewRental (AP.BaseAnnualRate r) sd ed (ByPeriodRental rental per) - = ByPeriodRental (mulBR rental (1 + yearCountFraction DC_ACT_365F sd ed * fromRational r)) per + = (AP.BaseAnnualRate r + , ByPeriodRental (mulBR rental (1 + yearCountFraction DC_ACT_365F sd ed * fromRational r)) per) getNewRental (AP.BaseCurve rc) sd ed (ByPeriodRental rental per) - = ByPeriodRental (mulBR rental (1 + yearCountFraction DC_ACT_365F sd ed * (fromRational (getValByDate rc Exc ed)))) per + = (AP.BaseCurve rc + , ByPeriodRental (mulBR rental (1 + yearCountFraction DC_ACT_365F sd ed * (fromRational (getValByDate rc Exc ed)))) per) +getNewRental (AP.BaseByVec rs) sd ed (ByPeriodRental rental per) + = let + (newRental,nextRs) = case Data.List.uncons rs of + Just (r,_rs) -> (mulBR rental (1 + yearCountFraction DC_ACT_365F sd ed * fromRational r) + , _rs) + Nothing -> (rental,[0.0]) + in + (AP.BaseByVec nextRs, ByPeriodRental newRental per) calcEndDate :: Date -> Int -> LeaseRateCalc -> Date calcEndDate sd periods (ByDayRate _ dp) = last $ genSerialDates dp Exc sd periods @@ -68,7 +87,7 @@ calcGapDays (AP.GapDays days) _ = days calcGapDays (AP.GapDaysByCurve ts) d = round $ fromRational $ getValByDate ts Exc d -- ^ Generate next lease with new rental / term changes/ day gap -nextLease :: Lease -> (AP.LeaseAssetRentAssump, TermChangeRate, DayGap) -> (Lease, Date) +nextLease :: Lease -> (AP.LeaseAssetRentAssump, TermChangeRate, DayGap) -> (Lease, Date ,(AP.LeaseAssetRentAssump, TermChangeRate, DayGap)) nextLease l@(RegularLease (LeaseInfo sd ot rental ob) bal rt _) (rAssump,tc,gd) = let leaseEndDate = last $ getPaymentDates l 0 @@ -76,40 +95,45 @@ nextLease l@(RegularLease (LeaseInfo sd ot rental ob) bal rt _) (rAssump,tc,gd) nextOriginTerm = round $ mulIR ot (1+tc) nextEndDate = calcEndDate nextStartDate ot rental - nextRental = getNewRental rAssump sd nextStartDate rental + (newRassump, nextRental) = getNewRental rAssump sd nextStartDate rental newBal = -1 in (RegularLease (LeaseInfo nextStartDate nextOriginTerm nextRental ob) - newBal nextOriginTerm Current,nextEndDate) -- `debug` ("1+tc"++show (1+tc) ++">>"++ show (mulIR ot (1+tc))) + newBal nextOriginTerm Current + ,nextEndDate + ,(newRassump,tc,gd) + ) -- `debug` ("1+tc"++show (1+tc) ++">>"++ show (mulIR ot (1+tc))) nextLease l@(StepUpLease (LeaseInfo sd ot rental ob) lsteupInfo bal rt _) (rAssump,tc,gd) = let leaseEndDate = last $ getPaymentDates l 0 nextStartDate = T.addDays (succ (toInteger gd)) leaseEndDate -- `debug` ("Gap Day ->"++ show gd) nextOriginTerm = round $ mulIR ot (1+tc) - nextEndDate = calcEndDate sd ot rental - nextRental = getNewRental rAssump sd nextStartDate rental + nextEndDate = calcEndDate nextStartDate ot rental + (newRassump, nextRental) = getNewRental rAssump sd nextStartDate rental newBal = -1 in (StepUpLease (LeaseInfo nextStartDate nextOriginTerm nextRental ob) - lsteupInfo newBal nextOriginTerm Current,nextEndDate) -- `debug` ("leaseEndDate>>"++show leaseEndDate++">>>"++show (succ (toInteger gd))) + lsteupInfo newBal nextOriginTerm Current + ,nextEndDate + ,(newRassump,tc,gd) + ) -- `debug` ("leaseEndDate>>"++show leaseEndDate++">>>"++show (succ (toInteger gd))) -- | create a new lease base on the lease in 1st argument, with new rental/term, a gap days, till the end date nextLeaseTill :: Lease -> (AP.LeaseAssetRentAssump, TermChangeRate, DayGap) -> Date -> AP.LeaseEndType -> [Lease] -> [Lease] nextLeaseTill l (rsc,tc,mg) lastDate (AP.CutByDate ed) accum | lastDate >= ed = accum - | otherwise = nextLeaseTill new_lease (rsc,tc,mg) new_lastDate (AP.CutByDate ed) (accum++[new_lease]) + | otherwise = nextLeaseTill new_lease newAssump new_lastDate (AP.CutByDate ed) (accum++[new_lease]) where - (new_lease,new_lastDate) = nextLease l (rsc,tc,mg) + (new_lease,new_lastDate, newAssump) = nextLease l (rsc,tc,mg) nextLeaseTill l (rsc,tc,mg) lastDate (AP.StopByExtTimes n) accum | n == 0 = accum - | otherwise = nextLeaseTill new_lease (rsc,tc,mg) new_lastDate (AP.StopByExtTimes (pred n)) (accum++[new_lease]) + | otherwise = nextLeaseTill new_lease newAssump new_lastDate (AP.StopByExtTimes (pred n)) (accum++[new_lease]) where - (new_lease,new_lastDate) = nextLease l (rsc,tc,mg) + (new_lease,new_lastDate, newAssump) = nextLease l (rsc,tc,mg) -- ^ calculate the daily rate for a step up lease --- TODO: factor rates to model the defaulted factors calcPmts :: LeaseStepUp -> [Rate] -> Amount -> Either String [Amount] calcPmts (FlatRate _r) fs amt = Right (scanl mulBR amt (replicate (length fs) _r)) calcPmts (ByFlatAmount _amt) fs amt = Right (scanl (+) amt (replicate (length fs) _amt)) @@ -120,8 +144,6 @@ calcPmts (ByAmountCurve amts) fs amt | length amts /= length fs = Left "ByAmountCurve: the rate curve should be the same length as remain pay dates" | otherwise = Right $ scanl (+) amt amts - - -- ^ return a lease contract with opening balance and a payment cashflow on each payment date patchBalance :: Lease -> Either String (Lease,[Amount]) patchBalance l@(RegularLease (LeaseInfo sd ot (ByDayRate dr dp) ob) bal rt st) @@ -225,7 +247,7 @@ instance Asset Lease where let pDates = lastN (getRemainTerms l) $ getPaymentDates l 0 let bals = tail $ scanl (-) bal pmts -- `debug` ("pDates "++ show pDates) let defaults = replicate (length pDates) 0.0 -- `debug` ("bals"++ show bals++ ">> d"++ show d) - return $ CF.CashFlowFrame (head bals,max d (getOriginDate l),Nothing) $ cutBy Inc Future d (zipWith4 CF.LeaseFlow pDates bals pmts defaults) + return $ CF.CashFlowFrame (head bals,max d (getOriginDate l), Nothing) $ cutBy Inc Future d (zipWith4 CF.LeaseFlow pDates bals pmts defaults) getOriginInfo (StepUpLease lInfo lsteupInfo bal rt st) = lInfo getOriginInfo (RegularLease lInfo bal rt st) = lInfo diff --git a/src/Assumptions.hs b/src/Assumptions.hs index 77715f7a..bb6e64f8 100644 --- a/src/Assumptions.hs +++ b/src/Assumptions.hs @@ -194,6 +194,7 @@ data LeaseAssetGapAssump = GapDays Int -- ^ days betwe data LeaseAssetRentAssump = BaseAnnualRate Rate | BaseCurve Ts + | BaseByVec [Rate] deriving (Show,Generic,Read) data LeaseDefaultType = DefaultByContinuation Rate diff --git a/swagger.json b/swagger.json index 74816c98..cfe016a3 100644 --- a/swagger.json +++ b/swagger.json @@ -10813,6 +10813,29 @@ ], "title": "BaseCurve", "type": "object" + }, + { + "properties": { + "contents": { + "items": { + "format": "double", + "type": "number" + }, + "type": "array" + }, + "tag": { + "enum": [ + "BaseByVec" + ], + "type": "string" + } + }, + "required": [ + "tag", + "contents" + ], + "title": "BaseByVec", + "type": "object" } ] }, @@ -20715,7 +20738,7 @@ "name": "BSD 3" }, "title": "Hastructure API", - "version": "0.45.5" + "version": "0.45.6" }, "openapi": "3.0.0", "paths": { From 73eceb80134f8faf30f70d3782f2cdaf306af20a Mon Sep 17 00:00:00 2001 From: Xiaoyu Date: Mon, 26 May 2025 21:32:08 +0800 Subject: [PATCH 53/53] bump version to-> < 0.45.7 > --- CHANGELOG.md | 5 +++++ app/Main.hs | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 83019f08..0569783d 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ +## 0.45.7 +### 2025-05-26 +* ENHANCE: add `BaseByVec` for vector-based rental change + + ## 0.45.5 ### 2025-05-20 * NEW: `MaxSpread` feature for structuring stage: get max possible bond coupon rate ! diff --git a/app/Main.hs b/app/Main.hs index a4fdd9e9..c92a21d4 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.45.6" +version1 = Version "0.45.7" wrapRun :: DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp