From b00df768d2a331593decea30d602f1bad71df621 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 23 Aug 2026 23:52:29 +0800 Subject: [PATCH 01/10] add .gitignore --- .gitignore | 1 + 1 file changed, 1 insertion(+) create mode 100644 .gitignore diff --git a/.gitignore b/.gitignore new file mode 100644 index 00000000..c33954f5 --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +dist-newstyle/ From 391afe927968ed3477fbd354f1a94ffba88e622a Mon Sep 17 00:00:00 2001 From: Samuel Naughton Baldwin Date: Sun, 16 Aug 2026 15:23:48 +0100 Subject: [PATCH 02/10] feat: fix pool-level DefaultByAmt allocation across multiple assets --- Hastructure.cabal | 1 + src/Pool.hs | 35 +++++++++++++++++++++-- test/MainTest.hs | 3 +- test/UT/PoolTest.hs | 70 +++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 105 insertions(+), 4 deletions(-) create mode 100644 test/UT/PoolTest.hs diff --git a/Hastructure.cabal b/Hastructure.cabal index e958482e..86c2ef24 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -193,6 +193,7 @@ test-suite Hastructure-test UT.ExpTest UT.InterestRateTest UT.LibTest + UT.PoolTest UT.QueryTest UT.RateHedgeTest UT.StmtTest diff --git a/src/Pool.hs b/src/Pool.hs index 4f65918b..ed6e31da 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -14,7 +14,7 @@ module Pool (Pool(..),aggPool import Lib (Period(..) ,Ts(..),periodRateFromAnnualRate,toDate ,getIntervalDays,zipWith9,mkTs,periodsBetween - ,mkRateTs,daysBetween, ) + ,mkRateTs,daysBetween, prorataFactors) import Control.Parallel.Strategies import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) @@ -206,8 +206,13 @@ runPool (Pool as _ _ asof _ _) Nothing mRates return [ (x, Map.empty) | x <- cf ] -- asset cashflow with credit stress ---- By pool level -runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates - = sequenceA $ parMap rdeepseq (\x -> projCashflow x asof assumps mRates) as +runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates = + sequenceA $ parMap rdeepseq + (\(x, assump) -> projCashflow x asof assump mRates) (zip as assetAssumps) + where + assetAssumps = allocateDefaultByAmt balances assumps + balances = getCurrentBal <$> as + ---- By index runPool (Pool as _ Nothing asof _ _) (Just (A.ByIndex idxAssumps)) mRates = let @@ -299,5 +304,29 @@ runPool (Pool as _ Nothing asof _ _) (Just (A.ByObligor obligorRules)) mRates = runPool _a _b _c = Left $ "[Run Pool]: Failed to match" ++ show _a ++ show _b ++ show _c +allocateDefaultByAmt :: [Balance] -> A.AssetPerf -> [A.AssetPerf] +allocateDefaultByAmt + balances + ( A.MortgageAssump + (Just (A.DefaultByAmt (total, rates))) + prepay + recovery + extra + , delinqAssump + , defaultAssump + ) = + [ (A.MortgageAssump + (Just (A.DefaultByAmt (amount, rates))) + prepay + recovery + extra + , delinqAssump + , defaultAssump + ) + | amount <- prorataFactors balances total + ] +allocateDefaultByAmt balances assumps = + replicate (length balances) assumps + $(deriveJSON defaultOptions ''Pool) diff --git a/test/MainTest.hs b/test/MainTest.hs index 21729d67..3b4d2ecc 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -20,7 +20,7 @@ import qualified UT.InterestRateTest as IRT import qualified UT.RateHedgeTest as RHT import qualified UT.CeTest as CET import qualified UT.LedgerTest as LeT - +import qualified UT.PoolTest as PT import qualified DealTest.DealTest as DealTest import qualified DealTest.RevolvingTest as RevolvingTest @@ -119,4 +119,5 @@ tests = testGroup "Tests" [AT.mortgageTests ,RHT.capRateTests ,CET.liqTest ,LeT.bookTest + ,PT.poolTest ] diff --git a/test/UT/PoolTest.hs b/test/UT/PoolTest.hs new file mode 100644 index 00000000..8e4a30b5 --- /dev/null +++ b/test/UT/PoolTest.hs @@ -0,0 +1,70 @@ +module UT.PoolTest (poolTest) +where + +import Test.Tasty +import Test.Tasty.HUnit + +import qualified AssetClass.AssetBase as AB +import qualified Assumptions as A +import qualified Cashflow as CF +import qualified Lib as L +import qualified Pool as P + +import InterestRate (RateType (Fix)) +import Types (DayCount (DC_ACT_365F)) + +poolTest :: TestTree +poolTest = + testGroup + "Pool test" + [ testCase "pool DefaultByAmt is allocated proportional to current balance" $ + case P.runPool pool (Just defaultAss) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual + "a total default of 40 (25% and 75%) across the asets" + [10, 30] + (totalDefaults <$> proj) + ] + where + pool = + P.Pool + { P.assets = [mortgage 100, mortgage 300] + , P.futureCf = Nothing + , P.futureScheduleCf = Nothing + , P.asOfDate = L.toDate "20240101" + , P.issuanceStat = Nothing + , P.extendPeriods = Nothing + } + + defaultAss = + A.PoolLevel + ( A.MortgageAssump + (Just (A.DefaultByAmt (40, [1]))) + Nothing + Nothing + Nothing + , A.DummyDelinqAssump + , A.DummyDefaultAssump + ) + + mortgage balance = + AB.Mortgage + ( AB.MortgageOriginalInfo + balance + (Fix DC_ACT_365F 0.08) + 12 + L.Monthly + (L.toDate "20240101") + AB.Level + Nothing + Nothing + ) + balance + 0.08 + 12 + Nothing + AB.Current + + totalDefaults (CF.CashFlowFrame _ txns, _) = + sum (CF.mflowDefault <$> txns) From 9d87a968e47c054c2d14a98e9a052b6adbb61da7 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Mon, 31 Aug 2026 15:59:20 +0800 Subject: [PATCH 03/10] fix: fee double-count in FeeFlowByPoolPeriod/FeeFlowByBondPeriod --- src/Deal/DealAction.hs | 4 ++-- test/MainTest.hs | 1 + test/UT/ExpTest.hs | 28 +++++++++++++++++++++++++++- 3 files changed, 30 insertions(+), 3 deletions(-) diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index 2be13e8c..13b4e459 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -208,7 +208,7 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByPoolPeriod pc) fs fd fdday fa lp currentPoolPeriod <- queryCompound t rc calcDay (DealStatInt PoolCollectedPeriod) feePaidAmt <- queryCompound t rc calcDay (FeePaidAmt [fn]) let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentPoolPeriod))) - return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay} + return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt), F.feeDueDate = Just calcDay} -- ^ fee based on a bond period number calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lpd stmt) @@ -216,7 +216,7 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lp currentBondPeriod <- queryCompound t rc calcDay (DealStatInt BondPaidPeriod) feePaidAmt <- queryCompound t rc calcDay (FeePaidAmt [fn]) let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentBondPeriod))) - return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay} + return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt), F.feeDueDate = Just calcDay} disableLiqProvider :: Ast.Asset a => TestDeal a -> Date -> CE.LiqFacility -> CE.LiqFacility diff --git a/test/MainTest.hs b/test/MainTest.hs index 3b4d2ecc..db8a5f3e 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -74,6 +74,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,LT.tsOperationTests ,ET.expTests ,ET.expPayTest + ,ET.expFlowByPeriodTest ,DT.queryTests ,DT.triggerTests ,DT.dateTests diff --git a/test/UT/ExpTest.hs b/test/UT/ExpTest.hs index c910df47..75aab64d 100644 --- a/test/UT/ExpTest.hs +++ b/test/UT/ExpTest.hs @@ -1,10 +1,11 @@ -module UT.ExpTest(expTests,expPayTest) +module UT.ExpTest(expTests,expPayTest,expFlowByPeriodTest) where import Test.Tasty import Test.Tasty.HUnit import qualified Data.Time as T +import qualified Data.Map as Map import qualified Lib as L import qualified Asset as P import qualified Deal as D @@ -64,6 +65,31 @@ expTests = testGroup "Expense Tests" ] +expFlowByPeriodTest = + let + pc = CurrentVal [PerPoint 1 10.0, PerPoint 2 20.0, PerPoint 3 30.0, PerPoint 4 40.0] + ctx = RunContext {} + calcDay = L.toDate "20220401" + partialPayStmt = Just (S.Statement (DL.fromList [ExpTxn (L.toDate "20220201") 35.0 10.0 0.0 (PayFee "feePool")])) + fullPayStmt = Just (S.Statement (DL.fromList [ExpTxn (L.toDate "20220201") 0.0 40.0 0.0 (PayFee "feePool")])) + poolFee = Fee "feePool" (FeeFlowByPoolPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing partialPayStmt + poolFeeFull = Fee "feePool" (FeeFlowByPoolPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing fullPayStmt + bondFee = Fee "feeBond" (FeeFlowByBondPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing partialPayStmt + dealWithFee f = DT.td2 { fees = Map.fromList [(feeName f, f)] + , stats = (Map.empty, Map.empty, Map.empty, Map.fromList [(PoolCollectedPeriod, 3), (BondPaidPeriod, 3)]) } + in + testGroup "Fee flow by period tests" + [ testCase "pool period fee: due = cumulative due - paid, no double count" $ + assertEqual "" (Right 30.0) + (feeDue <$> DA.calcDueFee (dealWithFee poolFee) ctx calcDay poolFee) + , testCase "pool period fee: fully paid yields zero due" $ + assertEqual "" (Right 0.0) + (feeDue <$> DA.calcDueFee (dealWithFee poolFeeFull) ctx calcDay poolFeeFull) + , testCase "bond period fee: due = cumulative due - paid, no double count" $ + assertEqual "" (Right 30.0) + (feeDue <$> DA.calcDueFee (dealWithFee bondFee) ctx calcDay bondFee) + ] + expPayTest = let f1 = Fee "FeeName1" (FixFee 100) (L.toDate "20220101") 100 Nothing 0 Nothing Nothing From 639b85ffc8c5869ae4f69a9983a2fa72a1c5a9b4 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Tue, 1 Sep 2026 10:45:41 +0800 Subject: [PATCH 04/10] Revert "fix: fee double-count in FeeFlowByPoolPeriod/FeeFlowByBondPeriod" This reverts commit 9d87a968e47c054c2d14a98e9a052b6adbb61da7. --- src/Deal/DealAction.hs | 4 ++-- test/MainTest.hs | 1 - test/UT/ExpTest.hs | 28 +--------------------------- 3 files changed, 3 insertions(+), 30 deletions(-) diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index 13b4e459..2be13e8c 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -208,7 +208,7 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByPoolPeriod pc) fs fd fdday fa lp currentPoolPeriod <- queryCompound t rc calcDay (DealStatInt PoolCollectedPeriod) feePaidAmt <- queryCompound t rc calcDay (FeePaidAmt [fn]) let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentPoolPeriod))) - return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt), F.feeDueDate = Just calcDay} + return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay} -- ^ fee based on a bond period number calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lpd stmt) @@ -216,7 +216,7 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlowByBondPeriod pc) fs fd fdday fa lp currentBondPeriod <- queryCompound t rc calcDay (DealStatInt BondPaidPeriod) feePaidAmt <- queryCompound t rc calcDay (FeePaidAmt [fn]) let dueAmt = fromMaybe 0 $ getValFromPerCurve pc Past Inc (succ (floor (fromRational currentBondPeriod))) - return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt), F.feeDueDate = Just calcDay} + return f {F.feeDue = max 0 (dueAmt - fromRational feePaidAmt) + fd, F.feeDueDate = Just calcDay} disableLiqProvider :: Ast.Asset a => TestDeal a -> Date -> CE.LiqFacility -> CE.LiqFacility diff --git a/test/MainTest.hs b/test/MainTest.hs index db8a5f3e..3b4d2ecc 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -74,7 +74,6 @@ tests = testGroup "Tests" [AT.mortgageTests ,LT.tsOperationTests ,ET.expTests ,ET.expPayTest - ,ET.expFlowByPeriodTest ,DT.queryTests ,DT.triggerTests ,DT.dateTests diff --git a/test/UT/ExpTest.hs b/test/UT/ExpTest.hs index 75aab64d..c910df47 100644 --- a/test/UT/ExpTest.hs +++ b/test/UT/ExpTest.hs @@ -1,11 +1,10 @@ -module UT.ExpTest(expTests,expPayTest,expFlowByPeriodTest) +module UT.ExpTest(expTests,expPayTest) where import Test.Tasty import Test.Tasty.HUnit import qualified Data.Time as T -import qualified Data.Map as Map import qualified Lib as L import qualified Asset as P import qualified Deal as D @@ -65,31 +64,6 @@ expTests = testGroup "Expense Tests" ] -expFlowByPeriodTest = - let - pc = CurrentVal [PerPoint 1 10.0, PerPoint 2 20.0, PerPoint 3 30.0, PerPoint 4 40.0] - ctx = RunContext {} - calcDay = L.toDate "20220401" - partialPayStmt = Just (S.Statement (DL.fromList [ExpTxn (L.toDate "20220201") 35.0 10.0 0.0 (PayFee "feePool")])) - fullPayStmt = Just (S.Statement (DL.fromList [ExpTxn (L.toDate "20220201") 0.0 40.0 0.0 (PayFee "feePool")])) - poolFee = Fee "feePool" (FeeFlowByPoolPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing partialPayStmt - poolFeeFull = Fee "feePool" (FeeFlowByPoolPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing fullPayStmt - bondFee = Fee "feeBond" (FeeFlowByBondPeriod pc) (L.toDate "20220101") 5 Nothing 0 Nothing partialPayStmt - dealWithFee f = DT.td2 { fees = Map.fromList [(feeName f, f)] - , stats = (Map.empty, Map.empty, Map.empty, Map.fromList [(PoolCollectedPeriod, 3), (BondPaidPeriod, 3)]) } - in - testGroup "Fee flow by period tests" - [ testCase "pool period fee: due = cumulative due - paid, no double count" $ - assertEqual "" (Right 30.0) - (feeDue <$> DA.calcDueFee (dealWithFee poolFee) ctx calcDay poolFee) - , testCase "pool period fee: fully paid yields zero due" $ - assertEqual "" (Right 0.0) - (feeDue <$> DA.calcDueFee (dealWithFee poolFeeFull) ctx calcDay poolFeeFull) - , testCase "bond period fee: due = cumulative due - paid, no double count" $ - assertEqual "" (Right 30.0) - (feeDue <$> DA.calcDueFee (dealWithFee bondFee) ctx calcDay bondFee) - ] - expPayTest = let f1 = Fee "FeeName1" (FixFee 100) (L.toDate "20220101") 100 Nothing 0 Nothing Nothing From 0c3bfcddf8c0788b62fca39f6cb2283a01249b35 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 27 Sep 2026 01:19:15 +0800 Subject: [PATCH 05/10] fix prorata calc & enable apply default by amount to scheduleMortgage --- src/AssetClass/Mortgage.hs | 4 ++++ src/Lib.hs | 37 ++++++++++++++--------------- test/UT/LibTest.hs | 26 +++++++++++++++++++++ test/UT/PoolTest.hs | 48 +++++++++++++++++++++++++++++++++++++- 4 files changed, 94 insertions(+), 21 deletions(-) diff --git a/src/AssetClass/Mortgage.hs b/src/AssetClass/Mortgage.hs index 008c503b..08684968 100644 --- a/src/AssetClass/Mortgage.hs +++ b/src/AssetClass/Mortgage.hs @@ -325,6 +325,10 @@ instance Ast.Asset Mortgage where getCurrentBal (Mortgage _ _bal _ _ _ _) = _bal getCurrentBal (AdjustRateMortgage _ _ _bal _ _ _ _) = _bal + getCurrentBal (ScheduleMortgageFlow _ flows _) = + case flows of + [] -> 0 + (f:_) -> CF.mflowBegBalance f getOriginBal (Mortgage (MortgageOriginalInfo _bal _ _ _ _ _ _ _) _ _ _ _ _ ) = _bal getOriginBal (AdjustRateMortgage (MortgageOriginalInfo _bal _ _ _ _ _ _ _) _ _ _ _ _ _ ) = _bal diff --git a/src/Lib.hs b/src/Lib.hs index 7b36a309..ed23ba27 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -20,6 +20,7 @@ module Lib import qualified Data.Time as T import qualified Data.Time.Format as TF import Data.List +import Data.Ord (Down) -- import qualified Data.Scientific as SCI import qualified Data.Map as M import Language.Haskell.TH @@ -30,9 +31,6 @@ import Data.Aeson hiding (json) import Data.Fixed (Fixed(..), HasResolution,Centi, resolution) import Data.Ratio import Types -import Control.Lens -import Data.List.Lens -import Control.Lens.TH import Data.Decimal import Debug.Trace debug = flip trace @@ -62,24 +60,23 @@ getIntervalFactors ds = (\x -> toRational x / 365) <$> getIntervalDays ds -- `de centiToDecimal :: Centi -> Decimal centiToDecimal c = Decimal 2 (round c * 100) --- | +-- | Allocate amt across balances pro-rata using the largest remainder +-- method: every allocation is non-negative and allocations sum exactly to +-- min (sum of balances) amt (to the cent). Residual cents go to the elements +-- with the largest fractional remainders, ties broken by index order. prorataFactors :: [Balance] -> Balance -> [Balance] -prorataFactors bals amt = - let - s = toRational $ sum bals - amtToPay = toRational $ min s (toRational amt) - in - case s of - 0.0 -> replicate (length bals) 0.0 - _ -> let - weights = map (\x -> toRational x / s) bals - outPut = (\y -> fromRational (y * amtToPay)) <$> weights - eps = amt - sum outPut - in - if eps == 0.00 then - outPut - else - over (ix 0) (+ eps) outPut +prorataFactors bals amt + | totalCents <= 0 = replicate (length bals) 0 + | otherwise = map (toEnum . fromInteger) $ zipWith (+) baseAdds extraCents + where + centList = toInteger . fromEnum <$> bals + totalCents = sum centList + payCents = max 0 $ min totalCents (toInteger $ fromEnum amt) + baseAdds = [ b * payCents `div` totalCents | b <- centList ] + residual = payCents - sum baseAdds + order = sortOn (Down . snd) $ zip [0..] [ b * payCents `mod` totalCents | b <- centList ] + extraIdx = fst <$> take (fromInteger residual) order + extraCents = [ if i `elem` extraIdx then 1 else 0 | i <- [0 .. length bals - 1] ] -- diff --git a/test/UT/LibTest.hs b/test/UT/LibTest.hs index 39d9ecc8..b10fe19f 100644 --- a/test/UT/LibTest.hs +++ b/test/UT/LibTest.hs @@ -134,6 +134,32 @@ prorataTests = testGroup "prorata Test" assertEqual "" [20,40,0] (prorataFactors bals2 60) + , + let + bals3 = [100,100,100] + in + testCase "residual goes to first on tie" $ + assertEqual "" + [13.34,13.33,13.33] + (prorataFactors bals3 40) + , + let + bals4 = replicate 12 0.01 + alloc4 = prorataFactors bals4 0.10 + in + testCase "many small bals has no negative allocation" $ do + assertBool "all allocations non-negative" (all (>= 0) alloc4) + assertEqual "allocations sum to requested amount" 0.10 (sum alloc4) + , + testCase "amt greater than total balance is capped" $ + assertEqual "" + [100,200] + (prorataFactors [100,200] 500) + , + testCase "zero total balance gives zeros" $ + assertEqual "" + [0,0] + (prorataFactors [0,0] 40) ] tsOperationTests = diff --git a/test/UT/PoolTest.hs b/test/UT/PoolTest.hs index 8e4a30b5..22ca8c58 100644 --- a/test/UT/PoolTest.hs +++ b/test/UT/PoolTest.hs @@ -11,7 +11,7 @@ import qualified Lib as L import qualified Pool as P import InterestRate (RateType (Fix)) -import Types (DayCount (DC_ACT_365F)) +import Types (DayCount (DC_ACT_365F), DatePattern (MonthEnd)) poolTest :: TestTree poolTest = @@ -25,6 +25,25 @@ poolTest = "a total default of 40 (25% and 75%) across the asets" [10, 30] (totalDefaults <$> proj) + , testCase "pool DefaultByAmt with many small balances allocates no negative amounts" $ + case P.runPool smallPool (Just smallDefaultAss) Nothing of + Left err -> assertFailure err + Right proj -> + let defaults = totalDefaults <$> proj + in do + assertBool "no negative default allocations" (all (>= 0) defaults) + assertEqual + "a total default of 0.10 across 12 assets of 0.01 balance" + (replicate 10 0.01 ++ replicate 2 0) + defaults + , testCase "pool DefaultByAmt with ScheduleMortgageFlow assets" $ + case P.runPool schedulePool (Just defaultAss) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual + "a total default of 40 (25% and 75%) across the schedule assets" + [10, 30] + (totalDefaults <$> proj) ] where pool = @@ -37,6 +56,14 @@ poolTest = , P.extendPeriods = Nothing } + smallPool = pool {P.assets = replicate 12 (mortgage 0.01)} + + schedulePool = + pool + { P.assets = [scheduleMortgage 100, scheduleMortgage 300] + , P.asOfDate = L.toDate "20240101" + } + defaultAss = A.PoolLevel ( A.MortgageAssump @@ -48,6 +75,17 @@ poolTest = , A.DummyDefaultAssump ) + smallDefaultAss = + A.PoolLevel + ( A.MortgageAssump + (Just (A.DefaultByAmt (0.10, [1]))) + Nothing + Nothing + Nothing + , A.DummyDelinqAssump + , A.DummyDefaultAssump + ) + mortgage balance = AB.Mortgage ( AB.MortgageOriginalInfo @@ -66,5 +104,13 @@ poolTest = Nothing AB.Current + scheduleMortgage balance = + AB.ScheduleMortgageFlow + (L.toDate "20240101") + [ CF.MortgageFlow (L.toDate d) balance 0 0 0 0 0 0 0.08 Nothing Nothing Nothing + | d <- ["20240101", "20240201", "20240301"] + ] + MonthEnd + totalDefaults (CF.CashFlowFrame _ txns, _) = sum (CF.mflowDefault <$> txns) From 023a2af0178c9536911a6431962784216d51624a Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 27 Sep 2026 02:26:17 +0800 Subject: [PATCH 06/10] fix: error when pool DefaultByAmt exceeds total current balance runPool now returns a Left from allocateDefaultByAmt when the pool-level DefaultByAmt total is greater than the sum of current balances, instead of silently dropping the excess. Also fixes the Data.Ord Down/Direction name clash in prorataFactors that broke compilation. --- src/Lib.hs | 3 +-- src/Pool.hs | 37 ++++++++++++++++++++++--------------- test/UT/PoolTest.hs | 41 +++++++++++++++++++++++++++++++++++++++++ 3 files changed, 64 insertions(+), 17 deletions(-) diff --git a/src/Lib.hs b/src/Lib.hs index ed23ba27..2f06dce0 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -20,7 +20,6 @@ module Lib import qualified Data.Time as T import qualified Data.Time.Format as TF import Data.List -import Data.Ord (Down) -- import qualified Data.Scientific as SCI import qualified Data.Map as M import Language.Haskell.TH @@ -74,7 +73,7 @@ prorataFactors bals amt payCents = max 0 $ min totalCents (toInteger $ fromEnum amt) baseAdds = [ b * payCents `div` totalCents | b <- centList ] residual = payCents - sum baseAdds - order = sortOn (Down . snd) $ zip [0..] [ b * payCents `mod` totalCents | b <- centList ] + order = sortOn (negate . snd) $ zip [0..] [ b * payCents `mod` totalCents | b <- centList ] extraIdx = fst <$> take (fromInteger residual) order extraCents = [ if i `elem` extraIdx then 1 else 0 | i <- [0 .. length bals - 1] ] diff --git a/src/Pool.hs b/src/Pool.hs index ed6e31da..47ef190c 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -206,11 +206,11 @@ runPool (Pool as _ _ asof _ _) Nothing mRates return [ (x, Map.empty) | x <- cf ] -- asset cashflow with credit stress ---- By pool level -runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates = +runPool (Pool as _ Nothing asof _ _) (Just (A.PoolLevel assumps)) mRates = do + assetAssumps <- allocateDefaultByAmt balances assumps sequenceA $ parMap rdeepseq (\(x, assump) -> projCashflow x asof assump mRates) (zip as assetAssumps) where - assetAssumps = allocateDefaultByAmt balances assumps balances = getCurrentBal <$> as ---- By index @@ -304,7 +304,7 @@ runPool (Pool as _ Nothing asof _ _) (Just (A.ByObligor obligorRules)) mRates = runPool _a _b _c = Left $ "[Run Pool]: Failed to match" ++ show _a ++ show _b ++ show _c -allocateDefaultByAmt :: [Balance] -> A.AssetPerf -> [A.AssetPerf] +allocateDefaultByAmt :: [Balance] -> A.AssetPerf -> Either ErrorRep [A.AssetPerf] allocateDefaultByAmt balances ( A.MortgageAssump @@ -314,19 +314,26 @@ allocateDefaultByAmt extra , delinqAssump , defaultAssump - ) = - [ (A.MortgageAssump - (Just (A.DefaultByAmt (amount, rates))) - prepay - recovery - extra - , delinqAssump - , defaultAssump - ) - | amount <- prorataFactors balances total - ] + ) + | total > sumBalances = + Left $ "[Run Pool]: DefaultByAmt total " ++ show total + ++ " exceeds total current balance " ++ show sumBalances + | otherwise = + Right + [ (A.MortgageAssump + (Just (A.DefaultByAmt (amount, rates))) + prepay + recovery + extra + , delinqAssump + , defaultAssump + ) + | amount <- prorataFactors balances total + ] + where + sumBalances = sum balances allocateDefaultByAmt balances assumps = - replicate (length balances) assumps + Right (replicate (length balances) assumps) $(deriveJSON defaultOptions ''Pool) diff --git a/test/UT/PoolTest.hs b/test/UT/PoolTest.hs index 22ca8c58..7f927c61 100644 --- a/test/UT/PoolTest.hs +++ b/test/UT/PoolTest.hs @@ -4,6 +4,8 @@ where import Test.Tasty import Test.Tasty.HUnit +import Data.List (isInfixOf) + import qualified AssetClass.AssetBase as AB import qualified Assumptions as A import qualified Cashflow as CF @@ -44,6 +46,23 @@ poolTest = "a total default of 40 (25% and 75%) across the schedule assets" [10, 30] (totalDefaults <$> proj) + , testCase "pool DefaultByAmt greater than total balance fails with Left" $ + case P.runPool pool (Just overDefaultAss) Nothing of + Left err -> + assertBool + ("error should mention the pool total: " ++ err) + ("exceeds total current balance" `isInfixOf` err) + Right _ -> + assertFailure + "expected Left when DefaultByAmt total exceeds total current balance" + , testCase "pool DefaultByAmt equal to total balance is allowed" $ + case P.runPool pool (Just exactDefaultAss) Nothing of + Left err -> assertFailure err + Right proj -> + assertEqual + "each asset defaults its full current balance" + [100, 300] + (totalDefaults <$> proj) ] where pool = @@ -86,6 +105,28 @@ poolTest = , A.DummyDefaultAssump ) + overDefaultAss = + A.PoolLevel + ( A.MortgageAssump + (Just (A.DefaultByAmt (500, [1]))) + Nothing + Nothing + Nothing + , A.DummyDelinqAssump + , A.DummyDefaultAssump + ) + + exactDefaultAss = + A.PoolLevel + ( A.MortgageAssump + (Just (A.DefaultByAmt (400, [1]))) + Nothing + Nothing + Nothing + , A.DummyDelinqAssump + , A.DummyDefaultAssump + ) + mortgage balance = AB.Mortgage ( AB.MortgageOriginalInfo From 52b58bfd0d5871780117e430be04671f2ffaca5a Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 27 Sep 2026 22:22:16 +0800 Subject: [PATCH 07/10] expose PrepaymentABS (only for monthly) --- src/Asset.hs | 24 +++++++++++++++++++++++- src/Assumptions.hs | 2 ++ src/Lib.hs | 18 ++++++++---------- src/Pool.hs | 2 +- test/MainTest.hs | 1 + test/UT/AssetTest.hs | 30 +++++++++++++++++++++++++++++- 6 files changed, 64 insertions(+), 13 deletions(-) diff --git a/src/Asset.hs b/src/Asset.hs index cfcca12b..a532eb3b 100644 --- a/src/Asset.hs +++ b/src/Asset.hs @@ -19,7 +19,7 @@ import Text.Read (readMaybe) import Lib (Period(..) ,Ts(..),periodRateFromAnnualRate,toDate - ,getIntervalDays,zipWith9,mkTs,periodsBetween + ,getIntervalDays,zipWith9,mkTs,monthsBetween ,mkRateTs,daysBetween, getIntervalFactors) import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) @@ -174,6 +174,8 @@ cpr2smm r = toRational $ 1 - (1 - fromRational r :: Double) ** (1/12) normalPerfVector :: [Rate] -> [Rate] normalPerfVector = floorWith 0.0 . capWith 1.0 + +-- ^ Given a prerpayment assumption , convert it to based prepayment rate buildPrepayRates :: Asset b => b -> [Date] -> Maybe A.AssetPrepayAssumption -> Either ErrorRep [Rate] buildPrepayRates _ ds Nothing = return $ replicate ((pred . length) ds) 0.0 buildPrepayRates a ds (Just (A.PrepaymentConstant r)) @@ -184,21 +186,40 @@ buildPrepayRates a ds (Just (A.PrepaymentCPR r)) | r < 0 || r > 1.0 = Left $ "buildPrepayRates: prepayment CPR rate should be between 0 and 1, got " ++ show r | otherwise = return $ Util.toPeriodRateByInterval r <$> getIntervalDays ds + +-- TODO: can be generlized to irregular payments +buildPrepayRates a ds (Just (A.PrepaymentABS r)) + | r < 0 || r > 1.0 = Left $ "buildPrepayRates: prepayment ABS rate should be between 0 and 1, got " ++ show r + | otherwise + = let + originDate = getOriginDate a + pojectedMonthAges = (monthsBetween originDate) <$> ds + smm m = r / (1 - r * fromIntegral (pred m)) + smmVector = smm <$> pojectedMonthAges + in + case period (getOriginInfo a) of + Monthly -> return smmVector + _ -> Left $ "prepayment ABS is only supported for monthly payment but got "++ show (period (getOriginInfo a)) + -- buildPrepayRates a ds (Just (A.PrepaymentVec smmVector)) + buildPrepayRates a ds (Just (A.PrepaymentVec vs)) | any (> 1.0) vs || any (< 0.0) vs = Left $ "buildPrepayRates: prepayment vector should be between 0 and 1, got " ++ show vs | otherwise = return $ zipWith Util.toPeriodRateByInterval (paddingDefault 0.0 vs (pred (length ds))) (getIntervalDays ds) + buildPrepayRates a ds (Just (A.PrepaymentVecPadding vs)) | any (> 1.0) vs || any (< 0.0) vs = Left $ "buildPrepayRates: prepayment vector should be between 0 and 1, got " ++ show vs | otherwise = return $ zipWith Util.toPeriodRateByInterval (paddingDefault (last vs) vs (pred (length ds))) (getIntervalDays ds) + buildPrepayRates a ds (Just (A.PrepayStressByTs ts x)) | any (< 0.0) (getTsVals ts) = Left $ "buildPrepayRates: prepayment vector by ts should be non-negative, got " ++ show (getTsVals ts) | otherwise = do rs <- buildPrepayRates a ds (Just x) return $ getTsVals $ multiplyTs Exc (zipTs (tail ds) rs) ts + buildPrepayRates a ds (Just (A.PrepaymentPSA r)) | r < 0 = Left $ "buildPrepayRates: PSA rate should be non-negative, got " ++ show r | otherwise = let @@ -210,6 +231,7 @@ buildPrepayRates a ds (Just (A.PrepaymentPSA r)) case period (getOriginInfo a) of Monthly -> return $ cpr2smm <$> vectorUsed _ -> Left $ "PSA is only supported for monthly payment but got "++ show (period (getOriginInfo a)) + buildPrepayRates a ds (Just (A.PrepaymentByTerm rs)) | any (< 0.0) (concat rs) = Left $ "buildPrepayRates: prepayment by term vector should be non-negative, got " ++ show rs | any (> 1.0) (concat rs) = Left $ "buildPrepayRates: prepayment by term vector should be between 0 and 1, got " ++ show rs diff --git a/src/Assumptions.hs b/src/Assumptions.hs index c46fa122..59372c7e 100644 --- a/src/Assumptions.hs +++ b/src/Assumptions.hs @@ -178,6 +178,7 @@ stressDefaultAssump x (DefaultByTerm rss) = DefaultByTerm $ ((capWith 1.0) <$> ( stressPrepaymentAssump :: Rate -> AssetPrepayAssumption -> AssetPrepayAssumption stressPrepaymentAssump x (PrepaymentConstant r) = PrepaymentConstant $ min 1.0 (r*x) stressPrepaymentAssump x (PrepaymentCPR r) = PrepaymentCPR $ min 1.0 (r*x) +stressPrepaymentAssump x (PrepaymentABS r) = PrepaymentABS $ min 1.0 (r*x) stressPrepaymentAssump x (PrepaymentVec rs) = PrepaymentVec $ capWith 1.0 ((x*) <$> rs) stressPrepaymentAssump x (PrepaymentVecPadding rs) = PrepaymentVecPadding $ capWith 1.0 ((x*) <$> rs) stressPrepaymentAssump x (PrepayByAmt (b,rs)) = PrepayByAmt (max (mulBR b x) 0, rs) @@ -188,6 +189,7 @@ stressPrepaymentAssump x (PrepaymentByTerm rss) = PrepaymentByTerm $ (capWith 1. data AssetPrepayAssumption = PrepaymentConstant Rate | PrepaymentCPR Rate + | PrepaymentABS Rate | PrepaymentVec [Rate] | PrepaymentVecPadding [Rate] | PrepayByAmt (Balance,[Rate]) diff --git a/src/Lib.hs b/src/Lib.hs index 2f06dce0..6534ccb2 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -7,7 +7,7 @@ module Lib ,StartDate,EndDate,daysBetween,daysBetweenI ,Spread,Date ,paySeqLiabilities,prorataFactors - ,afterNPeriod,Ts(..),periodsBetween + ,afterNPeriod,Ts(..),monthsBetween ,periodRateFromAnnualRate ,Floor,Cap,TsPoint(..) ,toDate,toDates,genDates,nextDate @@ -113,15 +113,13 @@ afterNPeriod d i p = SemiAnnually -> 6 Annually -> 12 -periodsBetween :: T.Day -> T.Day -> Period -> Integer -periodsBetween t1 t2 p - = case p of - Weekly -> div (T.diffDays t1 t2) 7 - Monthly -> _diff - Annually -> div _diff 12 - Quarterly -> div _diff 4 - where - _diff = T.cdMonths $ T.diffGregorianDurationClip t1 t2 +-- | Number of whole calendar months between two dates, i.e. how many complete +-- months have elapsed from @t1@ to @t2@. Partial months are clipped, so e.g. +-- 2021-01-31 -> 2021-02-01 is 0 months. Returns a negative value when @t2@ is +-- earlier than @t1@ and 0 when both dates are equal. +monthsBetween :: Date -> Date -> Integer +monthsBetween t1 t2 + = T.cdMonths $ T.diffGregorianDurationClip t2 t1 mkTs :: [(Date,Rational)] -> Ts diff --git a/src/Pool.hs b/src/Pool.hs index 47ef190c..d4f36d90 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -13,7 +13,7 @@ module Pool (Pool(..),aggPool import Lib (Period(..) ,Ts(..),periodRateFromAnnualRate,toDate - ,getIntervalDays,zipWith9,mkTs,periodsBetween + ,getIntervalDays,zipWith9,mkTs,monthsBetween ,mkRateTs,daysBetween, prorataFactors) import Control.Parallel.Strategies diff --git a/test/MainTest.hs b/test/MainTest.hs index 3b4d2ecc..881f7f6a 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -45,6 +45,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,AT.installmentTest ,AT.armTest ,AT.ppyTest + ,AT.ppyVectorTest -- ,AT.delinqScheduleCFTest ,AT.delinqMortgageTest ,AT.nonPayMortgageTest diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index 09874e20..e3fa1c4e 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -1,4 +1,4 @@ -module UT.AssetTest(mortgageTests,mortgageCalcTests,loanTests,leaseTests,installmentTest,armTest,ppyTest +module UT.AssetTest(mortgageTests,mortgageCalcTests,loanTests,leaseTests,installmentTest,armTest,ppyTest,ppyVectorTest ,delinqScheduleCFTest,delinqMortgageTest,btlMortgageTest,nonPayMortgageTest,receivableTest,fixedAssetTest) where @@ -620,6 +620,34 @@ ppyTest = (CF.cfAt ppy_cf_5 4) ] +ppyVectorTest :: TestTree +ppyVectorTest = + let + -- tm origin date is 2021-01-01 + absDsFirst = L.toDate <$> ["20210201","20210301","20210401","20210501"] + absDs = L.toDate <$> ["20210701","20210801","20210901","20211001"] + absRatesFirst r = Ast.buildPrepayRates tm absDsFirst (Just (A.PrepaymentABS r)) + absRates r = Ast.buildPrepayRates tm absDs (Just (A.PrepaymentABS r)) + in + testGroup "Prepayment vector tests" [ + testCase "PrepaymentABS 2% => SMM by month age | fisth 4 months" $ + assertEqual "abs vector" + (Right [1/50,1/49,1/48,1/47]) + (absRatesFirst 0.02) + ,testCase "PrepaymentABS 2% => SMM by month age" $ + assertEqual "abs vector" + (Right [1/45,1/44,1/43,1/42]) + (absRates 0.02) + ,testCase "PrepaymentABS 0% => all zero" $ + assertEqual "abs zero" + (Right [0,0,0,0]) + (absRates 0.0) + ,testCase "PrepaymentABS rejects rate > 1" $ + assertBool "rate > 1 should be Left" (isLeft (absRates 1.5)) + ,testCase "PrepaymentABS rejects negative rate" $ + assertBool "negative rate should be Left" (isLeft (absRates (-0.1))) + ] + delinqScheduleCFTest = let cfs = [CF.MortgageDelinqFlow (L.toDate "20230901") 1000 0 0 0 0 0 0 0 0.08 Nothing Nothing Nothing From 225b1526063480d40e580f284390bee9633c915e Mon Sep 17 00:00:00 2001 From: yellowbean Date: Sun, 27 Sep 2026 23:01:26 +0800 Subject: [PATCH 08/10] bump version to-> < 0.52.6 > --- CHANGELOG.md | 5 +++++ Hastructure.cabal | 2 +- app/Main.hs | 2 +- 3 files changed, 7 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index e6c588d2..07fa5e96 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,11 @@ # Changelog for Hastructure +## 0.52.6 +### 2026-09-27 +* NEW: add new prepayment assumption `PrepaymentABS`, an ABS / absolute prepayment model driven by the asset's seasoning (months elapsed since origin). Supported for `Monthly` assets only. +* FIX: pool-level `DefaultByAmt` is now allocated across multiple assets proportionally to their current balance. + ## 0.52.5 ### 2026-08-23 diff --git a/Hastructure.cabal b/Hastructure.cabal index 86c2ef24..f4c7d79d 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.5 +version: 0.52.6 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow diff --git a/app/Main.hs b/app/Main.hs index bb33b33d..ca4609ea 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.52.5" +version1 = Version "0.52.6" wrapRun :: [D.ExpectReturn] -> DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp From 1742d6517076e6089f0296c0220c2ca07049173d Mon Sep 17 00:00:00 2001 From: yellowbean Date: Mon, 28 Sep 2026 12:40:13 +0800 Subject: [PATCH 09/10] update dockerfile & workflow to cover arm64 --- .github/workflows/docker-image-dev-by-tag.yml | 7 +++-- Dockerfile | 28 +++++++++---------- 2 files changed, 19 insertions(+), 16 deletions(-) diff --git a/.github/workflows/docker-image-dev-by-tag.yml b/.github/workflows/docker-image-dev-by-tag.yml index 065a100e..97af02cf 100644 --- a/.github/workflows/docker-image-dev-by-tag.yml +++ b/.github/workflows/docker-image-dev-by-tag.yml @@ -49,9 +49,12 @@ jobs: uses: docker/build-push-action@v3 with: platforms: linux/amd64,linux/arm64 - push: true + push: true + build-args: | + CFLAGS=-march=armv8-a + CPPFLAGS=-march=armv8-a 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/Dockerfile b/Dockerfile index 0461a30e..c4fdeabe 100644 --- a/Dockerfile +++ b/Dockerfile @@ -1,21 +1,21 @@ -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 --platform=$BUILDPLATFORM haskell:9.8.4-slim-bullseye AS build -FROM --platform=linux/amd64 ubuntu:25.04 -RUN mkdir -p /opt/myapp -ARG BINARY_PATH -WORKDIR /opt/myapp -RUN apt-get update && apt-get install -y \ - ca-certificates \ - libgmp-dev -# NOTICE THIS LINE +ARG TARGETPLATFORM +RUN case "$TARGETPLATFORM" in \ + linux/arm64) \ + export CFLAGS="-march=armv8-a" \ + export CPPFLAGS="-march=armv8-a" ;; \ + *) ;; \ + esac +WORKDIR /opt/build +COPY . /opt/build +RUN cabal update && cabal install +FROM ubuntu:25.04 +WORKDIR /opt/myapp +RUN apt-get update && apt-get install -y ca-certificates libgmp-dev 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 CMD ["/opt/myapp/Hastructure-exe"] From aa5ec3312c4f3697a2be6ac3948508981a701e85 Mon Sep 17 00:00:00 2001 From: yellowbean Date: Mon, 28 Sep 2026 12:41:10 +0800 Subject: [PATCH 10/10] bump version to-> < 0.52.7 > --- Hastructure.cabal | 2 +- app/Main.hs | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/Hastructure.cabal b/Hastructure.cabal index f4c7d79d..56626b1c 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -5,7 +5,7 @@ cabal-version: 3.0 -- see: https://github.com/sol/hpack name: Hastructure -version: 0.52.6 +version: 0.52.7 synopsis: Cashflow modeling library for structured finance description: Please see the README on GitHub at category: StructuredFinance,Securitisation,Cashflow diff --git a/app/Main.hs b/app/Main.hs index ca4609ea..badd3e83 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -100,7 +100,7 @@ debug = flip Debug.Trace.trace version1 :: Version -version1 = Version "0.52.6" +version1 = Version "0.52.7" wrapRun :: [D.ExpectReturn] -> DealType -> Maybe AP.ApplyAssumptionType -> AP.NonPerfAssumption -> RunResp