diff --git a/.github/workflows/docker-image.yml b/.github/workflows/docker-image.yml index 2a61e809..e93aea4c 100644 --- a/.github/workflows/docker-image.yml +++ b/.github/workflows/docker-image.yml @@ -4,7 +4,9 @@ name: Docker Image CI # (e.g. `v0.52.12`), which: # * builds native binaries for linux/amd64, linux/arm64, macOS/arm64 and # Windows/amd64 and publishes them automatically to the GitHub "Releases" -# page for that tag (the release is created non-draft, with generated notes) +# page for that tag (the release is created non-draft, with generated notes); +# every target is also published stripped, and Linux/Windows additionally +# as a UPX-packed binary # * builds and pushes the amd64 image to Docker Hub (:latest + semver tags) # * publishes the tagged version to Hackage (the tag must match the cabal # version, e.g. `v0.53.0` <-> `version: 0.53.0`) @@ -90,6 +92,131 @@ jobs: fi mv "dist/Hastructure-exe${EXT}" "dist/Hastructure-${GITHUB_REF_NAME}-${{ matrix.name }}${EXT}" + # Publish three variants of every Linux/Windows target (two on macOS), + # all from the exact same build: + # Hastructure-- normal, full symbol table + # Hastructure---stripped same code/data, no symbols + # Hastructure---upx stripped + UPX (-9) + # Stripping here (instead of a second `cabal install`) guarantees the + # binaries differ only in the symbol/debug metadata, and avoids doubling + # the build time. + - name: Create stripped variant + id: variants + shell: bash + run: | + set -euo pipefail + EXT="" + if [ "$RUNNER_OS" = "Windows" ]; then EXT=".exe"; fi + base="dist/Hastructure-${GITHUB_REF_NAME}-${{ matrix.name }}" + full="${base}${EXT}" + slim="${base}-stripped${EXT}" + cp "$full" "$slim" + chmod +x "$slim" + + if [ "$RUNNER_OS" = "macOS" ]; then + # Apple's strip does not know --strip-unneeded. Rewriting the Mach-O + # invalidates the linker's ad-hoc arm64 signature, so re-sign or the + # binary is killed at exec time. + /usr/bin/strip -x "$slim" + codesign --force --sign - "$slim" + codesign --verify --strict "$slim" + elif [ "$RUNNER_OS" = "Windows" ]; then + ghc_lib="$(ghc --print-libdir 2>/dev/null | sed 's|\\|/|g' || true)" + candidates=() + if [ -n "$ghc_lib" ]; then + candidates+=("$(dirname "$ghc_lib")/mingw/bin/strip.exe") + fi + candidates+=("C:/msys64/usr/bin/strip.exe" "C:/Strawberry/c/bin/strip.exe") + strip_bin="" + for c in "${candidates[@]}"; do + if [ -x "$c" ]; then strip_bin="$c"; break; fi + done + if [ -z "$strip_bin" ]; then strip_bin="$(command -v strip || true)"; fi + if [ -z "$strip_bin" ]; then + echo "No strip executable found (tried GHC mingw, MSYS2, Strawberry, PATH)" >&2 + exit 1 + fi + echo "Using $strip_bin" + "$strip_bin" --strip-unneeded "$slim" + else + strip --strip-unneeded "$slim" + fi + + size_full=$(wc -c <"$full") + size_slim=$(wc -c <"$slim") + echo "unstripped: $size_full bytes, stripped: $size_slim bytes" + test "$size_slim" -lt "$size_full" + echo "stripped=$slim" >> "$GITHUB_OUTPUT" + + # Third variant for Linux and Windows only: strip first, then let UPX + # pack a *copy* (the action compresses in place). macOS is excluded + # because UPX/ghaction-upx does not support Mach-O. + - name: Stage UPX variant + id: upx + if: runner.os != 'macOS' + shell: bash + run: | + set -euo pipefail + EXT="" + if [ "$RUNNER_OS" = "Windows" ]; then EXT=".exe"; fi + path="dist/Hastructure-${GITHUB_REF_NAME}-${{ matrix.name }}-upx${EXT}" + cp "${{ steps.variants.outputs.stripped }}" "$path" + chmod +x "$path" + echo "path=$path" >> "$GITHUB_OUTPUT" + + - name: Compress UPX variant + if: runner.os != 'macOS' + uses: crazy-max/ghaction-upx@v4 + with: + version: v5.2.1 + files: ${{ steps.upx.outputs.path }} + args: -9 + + - name: Verify UPX variant + if: runner.os != 'macOS' + shell: bash + run: | + set -euo pipefail + size_stripped=$(wc -c <"${{ steps.variants.outputs.stripped }}") + size_upx=$(wc -c <"${{ steps.upx.outputs.path }}") + echo "stripped: $size_stripped bytes, upx: $size_upx bytes" + test "$size_upx" -lt "$size_stripped" + + # The stripped and UPX assets are the ones at risk (symbols removed, + # macOS re-signed, UPX-packed), so start each and require a real HTTP + # answer before anything is published. Runs in `smoke/`, not `dist/`, to + # keep config.yml/swagger.json out of the release assets. + - name: Smoke test stripped and UPX variants + shell: bash + run: | + set -euo pipefail + EXT="" + if [ "$RUNNER_OS" = "Windows" ]; then EXT=".exe"; fi + variants=(stripped) + if [ "$RUNNER_OS" != "macOS" ]; then variants+=(upx); fi + mkdir -p smoke + cd smoke + port=18080 + for variant in "${variants[@]}"; do + bin="Hastructure-${GITHUB_REF_NAME}-${{ matrix.name }}-${variant}${EXT}" + cp "../dist/$bin" . + printf 'port: %s\n' "$port" > config.yml + "./$bin" > "$variant.log" 2>&1 & + pid=$! + ok=0 + for _ in $(seq 1 60); do + if curl -fsS "http://127.0.0.1:${port}/version" 2>/dev/null; then ok=1; break; fi + sleep 1 + done + kill "$pid" 2>/dev/null || true + if [ "$ok" -ne 1 ]; then + echo "$variant binary failed to serve /version" >&2 + cat "$variant.log" >&2 + exit 1 + fi + port=$((port + 1)) + done + - name: Upload artifact uses: actions/upload-artifact@v7 with: diff --git a/Hastructure.cabal b/Hastructure.cabal index 7d45a644..177ce06e 100644 --- a/Hastructure.cabal +++ b/Hastructure.cabal @@ -74,7 +74,7 @@ library Paths_Hastructure hs-source-dirs: src - ghc-options: -Werror=missing-fields + ghc-options: -O2 -Werror=missing-fields -Werror=incomplete-record-updates build-depends: Decimal >= 0.5.2 && < 0.6, base >= 4.18.0 && < 4.22, @@ -118,7 +118,7 @@ executable Hastructure-exe Paths_Hastructure hs-source-dirs: app - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Werror=missing-fields -Wincomplete-patterns -Werror=incomplete-patterns + ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N -Werror=missing-fields -Wincomplete-patterns -Werror=incomplete-patterns -Werror=incomplete-record-updates build-depends: Hastructure, base, @@ -180,7 +180,7 @@ test-suite Hastructure-test Paths_Hastructure hs-source-dirs: test - ghc-options: -threaded -rtsopts -with-rtsopts=-N -Werror=missing-fields + ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N -Werror=missing-fields build-depends: Hastructure, base, diff --git a/README.md b/README.md index b060ca00..74e8b3dc 100644 --- a/README.md +++ b/README.md @@ -26,8 +26,7 @@ # I'm using language XXX * :snake: [Python wrapper](https://github.com/yellowbean/PyABS) is in ``Beta`` now ! -* :coffee: Easy integration with ``Java/C#/C++/JavaScript/Python`` with ``RESTful`` interface and Docker image are ready. - * C/Java : [here](https://github.com/absbox/Hastructure/issues/106) +* :coffee: _Protobuf in Progress_ ### Installation @@ -72,11 +71,17 @@ nix-build release.nix -A hastructure # build the engine -> result/bin/Hastruc #### From release executables -Prebuilt executables for Linux/macOS/Windows are attached to [GitHub releases](https://github.com/absbox/Hastructure/releases) as `Hastructure---ghc-`. Download one, then: +Prebuilt executables for Linux/macOS/Windows are attached to [GitHub releases](https://github.com/absbox/Hastructure/releases) as `Hastructure--`, where `` is one of `linux-amd64`, `linux-arm64`, `macos-arm64` and `windows-amd64`. Every target is published in two or three variants: + +* `Hastructure--` — normal build, full symbol table (useful for debugging/profiling). +* `Hastructure---stripped` — same binary with the symbol table removed (and, on macOS, re-signed). Much smaller and functionally identical; use this one to run the engine. +* `Hastructure---upx` — Linux and Windows only: the stripped binary packed with UPX at level `-9`. Smallest download; it decompresses itself in memory at startup. UPX does not support macOS. + +Download one, then: ```bash -chmod +x Hastructure--Linux-ghc-9.10.2 -./Hastructure--Linux-ghc-9.10.2 +chmod +x Hastructure-v0.52.14-linux-amd64-stripped +./Hastructure-v0.52.14-linux-amd64-stripped ``` Run it from a directory containing `config.yml`: the engine reads the file at startup and refuses to start when it is missing, malformed or contains an invalid value. diff --git a/app/Main.hs b/app/Main.hs index ad352ab1..3475624f 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -104,8 +104,6 @@ import Numeric.RootFinding import qualified Data.Version as DV import qualified Paths_Hastructure as Paths -import Debug.Trace -debug = flip Debug.Trace.trace version1 :: Version version1 = Version (DV.showVersion Paths.version) diff --git a/src/Accounts.hs b/src/Accounts.hs index 89d3097b..703453e0 100644 --- a/src/Accounts.hs +++ b/src/Accounts.hs @@ -8,28 +8,25 @@ module Accounts (Account(..),ReserveAmount(..),draw,deposit ,transfer,depositInt ,InterestInfo(..),buildEarnIntAction ,accBalLens,buildRateResetDates,accrueInt,accTypeLens) where -import qualified Data.Time as T -import Stmt (Statement(..),appendStmt,getTxnBegBalance,getDate - ,TxnComment(..),QueryByComment(..),getTxnComment,getTxnAmt,weightAvgBalanceByDates) +import qualified Data.Time as T () +import Stmt (Statement(..),appendStmt,getTxnBegBalance,QueryByComment(..),getTxnComment) import Types -import Lib +import Lib () import Util import DateUtil import Interface -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Data.Aeson +import Language.Haskell.TH () import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () import GHC.Generics -import Control.Lens.Tuple +import Control.Lens.Tuple () import Control.Lens hiding (Index) import qualified InterestRate as IR import qualified Data.DList as DL -- import Web.Hyperbole -import Debug.Trace -debug = flip trace data InterestInfo -- | fix reinvest return rate @@ -139,8 +136,7 @@ buildRateResetDates ed Account{accName = n, accInterest = Just (InvestmentAccoun buildRateResetDates _ _ = Nothing -makeLensesFor [("accBalance","accBalLens") ,("accName","accNameLens") - ,("accType","accTypeLens") ,("accStmt","accStmtLens"),("accInterest","accIntLens")] ''Account +makeLensesFor [("accBalance","accBalLens") ,("accType","accTypeLens")] ''Account instance IR.UseRate Account where @@ -149,6 +145,12 @@ instance IR.UseRate Account where getIndex (Account _ an (Just (InvestmentAccount idx _ _ _ _ _)) _ _) = Just idx getIndex _ = Nothing + + getIndexes (Account _ an (Just (InvestmentAccount idx _ _ _ _ _)) _ _) = Just [idx] + getIndexes _ = Nothing + + getResetDates _ = [] -- ^ re-investment interest does not reset a contractual index + getSpread _ = Nothing makePrisms ''InterestInfo diff --git a/src/Analytics.hs b/src/Analytics.hs index 79f0d90c..347b0bc9 100644 --- a/src/Analytics.hs +++ b/src/Analytics.hs @@ -12,21 +12,18 @@ import Types import Lib import Util import DateUtil -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types -import Data.Ord (comparing) -import Data.List (sortBy, uncons) -import GHC.Generics +import Data.Aeson () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () +import Data.List (uncons) +import GHC.Generics () import Data.Ratio import Numeric.RootFinding import qualified Numeric.Interpolation.Piecewise as Piecewise import qualified Numeric.Interpolation.Type as Type import qualified Numeric.Interpolation.NodeList as Nodes -import Debug.Trace -debug = flip trace calcSurvivorFactors :: Date -> [Date] -> Double -> [Double] calcSurvivorFactors sd ds 0 = replicate (length ds) 1.0 @@ -40,48 +37,35 @@ calcSurvivorFactors sd ds survivalRate = -- ^ interpolate the yield curve using Fritsch-Carlson method type TimeYield = (Double, Double) -type YieldPoint = (Date, Double) -toTimeYield :: Date -> [YieldPoint] -> [TimeYield] -toTimeYield refDate points - = let - sorted = sortBy (comparing fst) points - in - [ (fromRational (yearCountFraction DC_ACT_365F refDate d), y) | (d, y) <- sorted] secantSlopes :: [TimeYield] -> [Double] -secantSlopes points = zipWith - (\(t1, y1) (t2, y2) -> (y2 - y1) / (t2 - t1)) - points - (tail points) - --- Compute initial slopes (average of adjacent secant slopes for interior points) -initialSlopes :: [TimeYield] -> [Double] -initialSlopes [] = [] -initialSlopes [_] = [0] -initialSlopes points@((t0, y0):rest) = - let deltas = secantSlopes points - n = length points - slopes = [head deltas] ++ -- First slope: use first secant slope - [ (d1 + d2) / 2 | (d1, d2) <- zip deltas (tail deltas) ] ++ -- Interior slopes - [last deltas] -- Last slope: use last secant slope - in slopes +secantSlopes ((t1, y1) : rest@((t2, y2) : _)) = + (y2 - y1) / (t2 - t1) : secantSlopes rest +secantSlopes _ = [] fritschCarlsonSlopes :: [TimeYield] -> [Double] -fritschCarlsonSlopes points - | length points < 2 = replicate (length points) 0 - | otherwise = adjustSlopes points initialSlopes +fritschCarlsonSlopes [] = [] +fritschCarlsonSlopes [_] = [0] +fritschCarlsonSlopes points = adjustSlopes points initialSlopes where -- Compute initial slopes initialSlopes :: [Double] - initialSlopes = let deltas = secantSlopes points - n = length points - in [head deltas] ++ -- First slope: use first secant slope - [ if d1 * d2 > 0 then 2 / (1 / d1 + 1 / d2) else 0 - | (d1, d2) <- zip deltas (tail deltas) ] ++ -- Interior slopes: harmonic mean - [last deltas] -- Last slope: use last secant slope - - -- Adjust slopes for monotonicity + initialSlopes = case secantSlopes points of + [] -> [] + (d0:ds) -> d0 : go d0 ds + where + go prev [] = [prev] + go prev (d:rest) = harmonicMean prev d : go d rest + + harmonicMean d1 d2 + | d1 * d2 > 0 = 2 / (1 / d1 + 1 / d2) + | otherwise = 0 + + -- Adjust slopes for monotonicity. + -- INVARIANT: `pts` and `slopes` have the same length (`initialSlopes` + -- produces exactly one slope per point). The final clause is a total + -- fallback that is unreachable while that invariant holds. adjustSlopes :: [TimeYield] -> [Double] -> [Double] adjustSlopes pts slopes = go pts slopes [] where @@ -96,7 +80,7 @@ fritschCarlsonSlopes points else if r > 3 then (m1 * 3 / r, m2 * 3 / r) -- Scale slopes else (m1, m2) in go p2 (m2':ms) (m1':acc) - go _ _ _ = error "Invalid input" + go _ _ acc = reverse acc -- totality fallback for an impossible length mismatch interpolateWithHermite :: (Date,[(Date, Double)]) -> Dates -> [Double] interpolateWithHermite (_sd, []) ds = replicate (length ds) 0 @@ -109,33 +93,82 @@ interpolateWithHermite (sd, ts) ds nodes = Nodes.fromList $ zipWith3 (\x' y' yd' -> (x',(y',yd'))) xs ys yds -- `debug` ("x y yd"++ show xs ++">>"++ show ys ++">>"++show yds) - lookupFn = Piecewise.interpolate Type.hermite1 nodes + lookupFn = Piecewise.interpolateConstantExt Type.hermite1 nodes xs' = (fromRational . yearCountFraction DC_ACT_365F sd) <$> ds in lookupFn <$> xs' --- ^ calculate the Weighted Average Life of cashflow, with unit option to Monthly or Yearly +-- ^ calculate the Weighted Average Life of cashflow, with unit option to Monthly, Quarterly or Yearly calcWAL :: TimeHorizion -> Balance -> Date -> [(Balance,Date)] -> Balance calcWAL th bal d ps = let interval = case th of ByYear -> 365 ByMonth -> 30 + ByQuarter -> 91 weightedAmts = [ mulBR futureAmt ((daysBetween d futureDate) % interval) | (futureAmt,futureDate) <- ps ] in sum weightedAmts / bal +-- | Curve types that take part in Hermite rate interpolation (the same set as +-- getTsDates/getTsVals). Everything else keeps the getValByDate lookup. +isHermiteCurve :: Ts -> Bool +isHermiteCurve (IRateCurve _) = True +isHermiteCurve (RatioCurve _) = True +isHermiteCurve (FloatCurve _) = True +isHermiteCurve (PricingCurve _) = True +isHermiteCurve (BalanceCurve _) = True +isHermiteCurve _ = False + +-- | Curve tag for pv4's typed error on unsupported pricing-curve types. +tsTypeName :: Ts -> String +tsTypeName (FloatCurve _) = "FloatCurve" +tsTypeName (BoolCurve _) = "BoolCurve" +tsTypeName (BalanceCurve _) = "BalanceCurve" +tsTypeName (LeftBalanceCurve _) = "LeftBalanceCurve" +tsTypeName (RatioCurve _) = "RatioCurve" +tsTypeName (ThresholdCurve _) = "ThresholdCurve" +tsTypeName (IRateCurve _) = "IRateCurve" +tsTypeName (FactorCurveClosed _ _) = "FactorCurveClosed" +tsTypeName (PricingCurve _) = "PricingCurve" +tsTypeName (PeriodCurve _) = "PeriodCurve" +tsTypeName (IntCurve _) = "IntCurve" + +-- | The single discount-rate evaluator shared by pv, pv3, duration and +-- convexity: Hermite (Fritsch-Carlson) through the curve nodes with constant +-- extension at both borders, exactly like pv4. Flat curves short-circuit to the +-- constant rate so legacy constant-rate arithmetic stays bit-identical. +curveRatesAt :: Date -> Ts -> [Date] -> [Double] +curveRatesAt d curve ds + | isHermiteCurve curve = rates + | otherwise = map (fromRational . getValByDate curve Exc) ds + where + rates = case rs of + [] -> replicate (length ds) 0 + (r:_) | all (== r) rs -> replicate (length ds) r + | otherwise -> interpolateWithHermite (d, zip (getTsDates curve) rs) ds + rs = map fromRational (getTsVals curve) + +-- | Discount one amount at an explicit rate (same arithmetic as pv). +pvWithRate :: Double -> Date -> Date -> Amount -> Amount +pvWithRate discount_rate today d amt + = realToFrac $ (realToFrac amt) * (1 / factor) + where + distance::Double = fromIntegral $ daysBetween today d + factor::Double = (1 + realToFrac discount_rate) ** (distance / 365) + calcDuration :: DayCount -> Date -> [(Date,Balance)] -> Ts -> Rate calcDuration dc d ps pricingCurve - = (foldr (\(_d,_b) acc -> + = (foldr (\(r,(_d,_b)) acc -> (*) - (divideBB (pv pricingCurve d _d _b) presentValue) + (divideBB (pvWithRate r d _d _b) presentValue) (yearCountFraction dc d _d) + acc) 0.0000 - ps) + (zip rates ps)) where - presentValue = sum [ pv pricingCurve d _d _b | (_d,_b) <- ps ] + rates = curveRatesAt d pricingCurve (fst <$> ps) + presentValue = sum [ pvWithRate r d _d _b | (r,(_d,_b)) <- zip rates ps ] calcConvexity :: DayCount -> Date -> [(Date,Balance)] -> Ts -> Rate calcConvexity dc d ps pricingCurve @@ -143,24 +176,23 @@ calcConvexity dc d ps pricingCurve (*) presentValue' $ (foldr (\(_t,_c,_f) acc -> - (_t * (_t + 1) * fromRational _c) / ((1.000 + _f) ** (_t+2)) + (_t * (_t + 1) * fromRational _c) / ((1.000 + _f) ** (_t+2)) + acc ) 0.0000 - (zip3 ts payments pvFactors)) -- `debug` ("'v"++show presentValue'++"others"++ show (zip3 ts payments pvFactors)) + (zip3 ts payments pvFactors)) where - pvFactors::[Double] = fromRational <$> getValByDate pricingCurve Inc <$> fst <$> ps - presentValue'::Double = 1 / (fromRational . toRational) (sum [ pv pricingCurve d _d _b | (_d,_b) <- ps ]) + pvFactors::[Double] = curveRatesAt d pricingCurve (fst <$> ps) + presentValue'::Double = 1 / (fromRational . toRational) (sum [ pvWithRate r d _d _b | (r,(_d,_b)) <- zip pvFactors ps ]) payments = toRational . snd <$> ps ts::[Double] = fromRational <$> yearCountFraction dc d <$> fst <$> ps -- ^ calculate present value of input amount in future with given a curve and PV date pv :: Ts -> Date -> Date -> Amount -> Amount -pv pc today d amt = - realToFrac $ (realToFrac amt) * (1 / factor) -- `debug` ("DF:"++show factor++" PV AMT"++show amt) +pv pc today d amt = pvWithRate rate today d amt where - distance::Double = fromIntegral $ daysBetween today d - discount_rate = fromRational $ getValByDate pc Exc d -- `debug` ("Get val by ts"++show pc ++">>d"++ show d) - factor::Double = (1 + realToFrac discount_rate) ** (distance / 365) -- `debug` ("discount_rate"++show(discount_rate) ++" dist days=>"++show(distance)) + rate = case curveRatesAt today pc [d] of + (r:_) -> r + [] -> 0 -- ^ calculate present value in the future using constant rate pv2 :: IRate -> Date -> Date -> Amount -> Amount @@ -195,43 +227,39 @@ pv22 r d ds vs = sum [ pv2' r d _d amt | (_d,amt) <- zip ds vs ] pv3 :: Ts -> Date -> [Date] -> [Amount] -> Balance pv3 pvCurve pricingDate ds vs = let - rs = fromRational <$> getValByDates pvCurve Inc ds - pvs = [ pv2 r pricingDate d amt | (r,d,amt) <- zip3 rs ds vs ] + rs = curveRatesAt pricingDate pvCurve ds + pvs = [ pvWithRate r pricingDate d amt | (r,d,amt) <- zip3 rs ds vs ] in sum pvs -pv3' :: Ts -> Date -> [Date] -> [Amount] -> Balance -pv3' pvCurve pricingDate ds vs - = let - rs = fromRational <$> getValByDates pvCurve Inc ds - vs' = (fromRational . toRational) <$> vs - pvs = [ pv2' r pricingDate d amt | (r,d,amt) <- zip3 rs ds vs' ] - in - fromRational . toRational $ foldr (+) 0 pvs -- ^ using hermite interpolation to get present value pv4 :: (Date,Ts) -> [(Date,Amount)] -> Either ErrorRep Balance pv4 _ [] = Left "pv4: No cashflow to get present value" pv4 (pricingDate, pvCurve) (cf:cfs) - | null ds' = Left "pv4: empty pricing curve" - | head ds' < pricingDate = Left $ "pv4: cashflow date "++ show (head ds') ++" is before pricing date "++ show pricingDate - | fst cf < pricingDate = Left $ "pv4: cashflow date "++ show (fst cf) ++" is before pricing date "++ show pricingDate - | otherwise - = let - ds = fst <$> (cf:cfs) - rs = let - ds' = getTsDates pvCurve - vs'::[Double] = fromRational <$> (getTsVals pvCurve) - in - interpolateWithHermite - (pricingDate, zip ds' vs') - ds - vs' = (fromRational . toRational . snd) <$> (cf:cfs) - pvs = [ pv2' r pricingDate d amt | (r,d,amt) <- zip3 rs ds vs' ] - in - return $ fromRational . toRational $ foldr (+) 0 pvs + | not (isHermiteCurve pvCurve) = Left $ "pv4: unsupported pricing curve type: " ++ tsTypeName pvCurve + | otherwise = case ds' of + [] -> Left "pv4: empty pricing curve" + (d0:_) + | d0 < pricingDate -> Left $ "pv4: cashflow date "++ show d0 ++" is before pricing date "++ show pricingDate + | fst cf < pricingDate -> Left $ "pv4: cashflow date "++ show (fst cf) ++" is before pricing date "++ show pricingDate + | length ds' > 1 && firstCfDate < d0 -> Left $ "pv4: first cashflow date " ++ show firstCfDate ++ " is before pricing curve start " ++ show d0 + | otherwise + -> let + ds = fst <$> (cf:cfs) + rs = let + vs'::[Double] = fromRational <$> (getTsVals pvCurve) + in + interpolateWithHermite + (pricingDate, zip ds' vs') + ds + vs' = (fromRational . toRational . snd) <$> (cf:cfs) + pvs = [ pv2' r pricingDate d amt | (r,d,amt) <- zip3 rs ds vs' ] + in + return $ fromRational . toRational $ foldr (+) 0 pvs where ds' = getTsDates pvCurve + firstCfDate = minimum (fst <$> (cf:cfs)) diff --git a/src/Asset.hs b/src/Asset.hs index 8c6598e0..6f39293d 100644 --- a/src/Asset.hs +++ b/src/Asset.hs @@ -9,18 +9,15 @@ module Asset ( Asset(..), buildAssumptionPpyDefRecRate,buildAssumptionPpyDelinqDefRecRate ,calcRecoveriesFromDefault - ,priceAsset,applyHaircut,buildPrepayRates,buildDefaultRates,getObligorFields - ,getObligorTags,getObligorId,getRecoveryLagAndRate,getDefaultDelinqAssump,getOriginInfo + ,priceAsset,applyHaircut,buildPrepayRates,buildDefaultRates + ,getRecoveryLagAndRate,getDefaultDelinqAssump ) where import qualified Data.Time as T -import qualified Data.Text as Text -import Text.Read (readMaybe) +import qualified Data.Text as Text () +import Text.Read () -import Lib (Period(..) - ,Ts(..),periodRateFromAnnualRate,toDate - ,getIntervalDays,zipWith9,mkTs,monthsBetween - ,mkRateTs,daysBetween, getIntervalFactors) +import Lib (getIntervalDays, mkTs, monthsBetween, daysBetween) import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) import qualified Assumptions as A @@ -30,31 +27,29 @@ import AssetClass.AssetCashflow import qualified Data.Map as Map import Analytics import Data.List -import Data.Maybe -import Data.Ratio -import Data.Aeson hiding (json) -import Language.Haskell.TH -import GHC.Generics -import Data.Aeson.TH -import Data.Aeson.Types -import Types hiding (Current) -import Text.Printf -import Data.Fixed +import Data.Maybe () +import Data.Ratio () +import Data.Aeson () +import Language.Haskell.TH () +import GHC.Generics () +import Data.Aeson.TH () +import Data.Aeson.Types () +import Types +import Text.Printf () +import Data.Fixed () import qualified InterestRate as IR import qualified Data.Set as Set import Util -import AssetClass.AssetBase ( OriginalInfo(..), calcPmt, AssetUnion, Obligor(..) ) +import AssetClass.AssetBase (OriginalInfo(..), Obligor(..)) -import Debug.Trace import Assumptions (ExtraStress(ExtraStress)) -import Control.Lens hiding (element) -import Control.Lens.TH +import Control.Lens () +import Control.Lens.TH () import DateUtil (yearCountFraction) -debug = flip trace class (Show a,IR.UseRate a) => Asset a where -- | project contractual cashflow of an asset with interest assumptions @@ -171,8 +166,6 @@ applyExtraStress (Just ExtraStress{A.defaultFactors= mDefFactor cpr2smm :: Rate -> Rate 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 @@ -325,9 +318,6 @@ getDefaultDelinqAssump (Just (A.DelinqCDR r (lag,pct))) ds ,lag ,pct) -getDefaultLagAndRate :: Maybe A.RecoveryAssumption -> (Rate,Int) -getDefaultLagAndRate Nothing = (0,0) -getDefaultLagAndRate (Just (A.Recovery (r,lag))) = (r,lag) -- | build prepayment rates/ delinq rates and (%,lag) convert to default, recovery rate, recovery lag buildAssumptionPpyDelinqDefRecRate :: Asset a => a -> [Date] -> A.AssetPerfAssumption -> Either String ([Rate],[Rate],(Rate,Lag),Rate,Int) diff --git a/src/AssetClass/AssetBase.hs b/src/AssetClass/AssetBase.hs index f4fe3169..8bf09ab8 100644 --- a/src/AssetClass/AssetBase.hs +++ b/src/AssetClass/AssetBase.hs @@ -15,15 +15,17 @@ module AssetClass.AssetBase ) where -import Language.Haskell.TH +import Language.Haskell.TH () import GHC.Generics import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () --import Asset import Data.OpenApi hiding (Server,contentType) -import Types hiding (Current,startDate,originTerm) +import Types hiding (startDate) +import DateUtil (genSerialDatesTill2) +import qualified Data.Time as T import Data.Ratio import Data.Proxy import Data.Decimal @@ -32,10 +34,8 @@ import qualified Data.Map as Map import qualified InterestRate as IR import qualified Cashflow as CF import Control.Lens hiding (element,Index) -import Control.Lens.TH +import Control.Lens.TH () -import Debug.Trace (trace) -debug = flip Debug.Trace.trace type DailyRate = Balance @@ -259,6 +259,25 @@ data AssetUnion = MO Mortgage deriving (Show, Generic,Ord,Eq) +-- ^ end date of an original term expressed in payment periods +termEndDate :: Period -> Date -> Int -> Date +termEndDate p sd n = case p of + Daily -> T.addDays (toInteger n) sd + Weekly -> T.addDays (toInteger n * 7) sd + BiWeekly -> T.addDays (toInteger n * 14) sd + Monthly -> T.addGregorianDurationClip (T.CalendarDiffDays (toInteger n) 0) sd + Quarterly -> T.addGregorianDurationClip (T.CalendarDiffDays (toInteger n * 3) 0) sd + SemiAnnually -> T.addGregorianDurationClip (T.CalendarDiffDays (toInteger n * 6) 0) sd + Annually -> T.addGregorianDurationClip (T.CalendarDiffDays (toInteger n * 12) 0) sd + + +-- ^ reset dates of a floating rate type over the asset's original term +rateResetDatesOverTerm :: IR.RateType -> Date -> Int -> Period -> Dates +rateResetDatesOverTerm (IR.Floater _ _ _ _ dp _ _ _) sd n p + = genSerialDatesTill2 NO_IE sd dp (termEndDate p sd n) +rateResetDatesOverTerm _ _ _ _ = [] + + instance IR.UseRate AssetUnion where getIndex (MO ma) = IR.getIndex ma getIndex (LO ma) = IR.getIndex ma @@ -268,6 +287,38 @@ instance IR.UseRate AssetUnion where getIndex (RE ma) = IR.getIndex ma getIndex (PF ma) = IR.getIndex ma + getIndexes (MO ma) = IR.getIndexes ma + getIndexes (LO ma) = IR.getIndexes ma + getIndexes (IL ma) = IR.getIndexes ma + getIndexes (LS ma) = IR.getIndexes ma + getIndexes (FA ma) = IR.getIndexes ma + getIndexes (RE ma) = IR.getIndexes ma + getIndexes (PF ma) = IR.getIndexes ma + + isAdjustableRate (MO ma) = IR.isAdjustableRate ma + isAdjustableRate (LO ma) = IR.isAdjustableRate ma + isAdjustableRate (IL ma) = IR.isAdjustableRate ma + isAdjustableRate (LS ma) = IR.isAdjustableRate ma + isAdjustableRate (FA ma) = IR.isAdjustableRate ma + isAdjustableRate (RE ma) = IR.isAdjustableRate ma + isAdjustableRate (PF ma) = IR.isAdjustableRate ma + + getResetDates (MO ma) = IR.getResetDates ma + getResetDates (LO ma) = IR.getResetDates ma + getResetDates (IL ma) = IR.getResetDates ma + getResetDates (LS ma) = IR.getResetDates ma + getResetDates (FA ma) = IR.getResetDates ma + getResetDates (RE ma) = IR.getResetDates ma + getResetDates (PF ma) = IR.getResetDates ma + + getSpread (MO ma) = IR.getSpread ma + getSpread (LO ma) = IR.getSpread ma + getSpread (IL ma) = IR.getSpread ma + getSpread (LS ma) = IR.getSpread ma + getSpread (FA ma) = IR.getSpread ma + getSpread (RE ma) = IR.getSpread ma + getSpread (PF ma) = IR.getSpread ma + instance IR.UseRate Mortgage where getIndex (Mortgage oi@MortgageOriginalInfo{ originRate = IR.Floater _ idx _ _ _ _ _ _ } _ _ _ _ _) = Just idx @@ -275,23 +326,89 @@ instance IR.UseRate Mortgage where getIndex (AdjustRateMortgage oi@MortgageOriginalInfo{ originRate = IR.Floater _ idx _ _ _ _ _ _ } _ _ _ _ _ _) = Just idx getIndex AdjustRateMortgage {} = Nothing + -- ^ look-up from the single origin index + getIndexes m@Mortgage {} = case IR.getIndex m of + Just idx -> Just [idx] + _ -> Nothing + getIndexes m@AdjustRateMortgage {} = case IR.getIndex m of + Just idx -> Just [idx] + _ -> Nothing + + isAdjustableRate m@Mortgage {} = case IR.getIndex m of + Just _ -> True + _ -> False + isAdjustableRate m@AdjustRateMortgage {} = case IR.getIndex m of + Just _ -> True + _ -> False + + -- ^ spread from the origin rate + getSpread (Mortgage oi@MortgageOriginalInfo{originRate = rt} _ _ _ _ _) = IR._getSpread rt + getSpread (AdjustRateMortgage oi@MortgageOriginalInfo{originRate = rt} _ _ _ _ _ _) = IR._getSpread rt + + -- ^ reset dates of the origin floating rate over the originated term + getResetDates (Mortgage oi@MortgageOriginalInfo{originRate = rt, originTerm = ot, startDate = sd, period = p} _ _ _ _ _) + = rateResetDatesOverTerm rt sd ot p + getResetDates (AdjustRateMortgage oi@MortgageOriginalInfo{originRate = rt, originTerm = ot, startDate = sd, period = p} _ _ _ _ _ _) + = rateResetDatesOverTerm rt sd ot p + instance IR.UseRate Loan where getIndex (PersonalLoan oi@LoanOriginalInfo{originRate = IR.Floater _ idx _ _ _ _ _ _ } _ _ _ _) = Just idx getIndex PersonalLoan {} = Nothing + getIndexes p@PersonalLoan {} = case IR.getIndex p of + Just idx -> Just [idx] + _ -> Nothing + + isAdjustableRate p@PersonalLoan {} = case IR.getIndex p of + Just _ -> True + _ -> False + + getSpread (PersonalLoan oi@LoanOriginalInfo{originRate = rt} _ _ _ _) = IR._getSpread rt + + getResetDates (PersonalLoan oi@LoanOriginalInfo{originRate = rt, originTerm = ot, startDate = sd, period = p} _ _ _ _) + = rateResetDatesOverTerm rt sd ot p + instance IR.UseRate Installment where getIndex (Installment oi@LoanOriginalInfo{originRate = IR.Floater _ idx _ _ _ _ _ _ } _ _ _) = Just idx getIndex Installment {} = Nothing + + getIndexes p@Installment {} = case IR.getIndex p of + Just idx -> Just [idx] + _ -> Nothing + + isAdjustableRate p@Installment {} = case IR.getIndex p of + Just _ -> True + _ -> False + + getSpread (Installment oi@LoanOriginalInfo{originRate = rt} _ _ _) = IR._getSpread rt + + getResetDates (Installment oi@LoanOriginalInfo{originRate = rt, originTerm = ot, startDate = sd, period = p} _ _ _) + = rateResetDatesOverTerm rt sd ot p instance IR.UseRate Lease where getIndex :: Lease -> Maybe Index getIndex _ = Nothing + -- ^ the rental rate is contractual (fixed by day), no floating index + getIndexes _ = Nothing + isAdjustableRate _ = False + getResetDates _ = [] + getSpread _ = Nothing instance IR.UseRate FixedAsset where getIndex _ = Nothing + -- ^ depreciation-type asset with no indexed rate + getIndexes _ = Nothing + isAdjustableRate _ = False + getResetDates _ = [] + getSpread _ = Nothing instance IR.UseRate Receivable where getIndex _ = Nothing + -- ^ receivable pays a face balance, no indexed rate + getIndexes _ = Nothing + isAdjustableRate _ = False + getResetDates _ = [] + getSpread _ = Nothing instance IR.UseRate ProjectedCashFlow where getIndex (ProjectedByFactor cf _ _ []) = Nothing @@ -302,6 +419,8 @@ instance IR.UseRate ProjectedCashFlow where isAdjustableRate (ProjectedByFactor _ _ _ []) = False isAdjustableRate (ProjectedByFactor _ _ _ _) = True isAdjustableRate (ProjectedCashflow _ _ _) = False + getResetDates _ = [] + getSpread _ = Nothing $(concat <$> traverse (deriveJSON defaultOptions) [''Obligor, ''OriginalInfo, ''FixedAsset, ''AmortPlan, ''PrepayPenaltyType diff --git a/src/AssetClass/AssetCashflow.hs b/src/AssetClass/AssetCashflow.hs index 784ca7fc..2ba1ec33 100644 --- a/src/AssetClass/AssetCashflow.hs +++ b/src/AssetClass/AssetCashflow.hs @@ -7,31 +7,29 @@ module AssetClass.AssetCashflow ,patchLossRecovery,getRecoveryLagFromAssumption) where -import qualified Data.Time as T +import qualified Data.Time as T () import qualified Cashflow as CF import Types -import Lib +import Lib () import Util -import DateUtil -import InterestRate as IR +import DateUtil () +import InterestRate as IR () -import qualified Data.Map as Map +import qualified Data.Map as Map () import Data.List -import Data.Ratio -import Data.Maybe -import GHC.Generics -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types +import Data.Ratio () +import Data.Maybe () +import GHC.Generics () +import Data.Aeson () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () import AssetClass.AssetBase -import Debug.Trace import qualified Assumptions as A -import GHC.Float.RealFracMethods (truncateFloatInteger) +import GHC.Float.RealFracMethods () import Cashflow (mflowDefault) -debug = flip trace -- This module is a collection of common cashflow functions to project cashflow for different asset types. diff --git a/src/AssetClass/FixedAsset.hs b/src/AssetClass/FixedAsset.hs index 888bf928..7d198815 100644 --- a/src/AssetClass/FixedAsset.hs +++ b/src/AssetClass/FixedAsset.hs @@ -7,34 +7,32 @@ module AssetClass.FixedAsset () where -import qualified Data.Time as T +import qualified Data.Time as T () import Data.Ratio -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Data.Aeson () +import Language.Haskell.TH () import Data.Maybe import Data.List -import Data.Aeson.TH +import Data.Aeson.TH () import qualified Data.Map as Map -import Data.Aeson.Types -import GHC.Generics +import Data.Aeson.Types () +import GHC.Generics () import qualified Assumptions as A import Types hiding (startDate) import Lib import Util -import DateUtil +import DateUtil () import qualified Cashflow as CF import AssetClass.AssetBase -import Debug.Trace -import AssetClass.AssetCashflow +import AssetClass.AssetCashflow () import qualified Asset as Ast import Asset (Asset(projCashflow)) -import Assumptions (AssetDelinqPerfAssumption(DummyDelinqAssump)) -debug = flip trace +import Assumptions () -- life time schedule amortization amount list @@ -57,14 +55,6 @@ calcAmortAmt fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, ori in Right (diffNum futureBals'') - _ -> Left ("Not implemented for depreciation rule"++show ar) - -calcAmortBals ::FixedAsset -> Either String [Balance] -calcAmortBals fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, originTerm=ot - ,residualBalance=rb ,capacity=cap} b rt) - = do - bals <- calcAmortAmt fa - return $ scanl (-) ob bals instance Ast.Asset FixedAsset where @@ -76,6 +66,10 @@ instance Ast.Asset FixedAsset where ,residualBalance=rb ,capacity=cap} curBal rt) = curBal + getOriginBal fa@(FixedAsset FixedAssetInfo{originBalance=ob} _ _) = ob + -- ^ a depreciation-modelled asset carries no rate + getOriginRate _ = 0 + resetToOrig fa@(FixedAsset fai@FixedAssetInfo{originBalance=ob, accRule=ar, originTerm=ot ,residualBalance=rb ,capacity=cap} b rt) = FixedAsset fai b ot diff --git a/src/AssetClass/Installment.hs b/src/AssetClass/Installment.hs index 888b911f..7b94064a 100644 --- a/src/AssetClass/Installment.hs +++ b/src/AssetClass/Installment.hs @@ -6,18 +6,18 @@ module AssetClass.Installment (projectInstallmentFlow, updateOriginDate) where -import qualified Data.Time as T -import Data.Ratio +import qualified Data.Time as T () +import Data.Ratio () -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Maybe +import Data.Aeson () +import Language.Haskell.TH () +import Data.Maybe () import Data.List import qualified Data.DList as DL -import Data.Aeson.TH +import Data.Aeson.TH () import qualified Data.Map as Map -import Data.Aeson.Types -import GHC.Generics +import Data.Aeson.Types () +import GHC.Generics () import Asset import InterestRate @@ -25,17 +25,15 @@ import qualified Assumptions as A import Types import Lib import Util -import DateUtil +import DateUtil () import qualified Cashflow as CF import AssetClass.AssetBase -import Debug.Trace import AssetClass.AssetCashflow import qualified Asset as Ast -import Control.Lens hiding (element) -import Control.Lens.TH -debug = flip trace +import Control.Lens () +import Control.Lens.TH () projectInstallmentFlow :: (Balance,Date,(Balance,Balance),IRate,Rational,AmortPlan,Int) -> (Dates, [DefaultRate], [PrepaymentRate], [Int]) -> (DL.DList CF.TsRow, Balance ,Rational) diff --git a/src/AssetClass/Lease.hs b/src/AssetClass/Lease.hs index a7908d7f..cc1ad541 100644 --- a/src/AssetClass/Lease.hs +++ b/src/AssetClass/Lease.hs @@ -12,37 +12,32 @@ import qualified Data.Time as T import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) import qualified Assumptions as AP import Asset -import Types hiding (getOriginDate) +import Types import Lib import Util import DateUtil import qualified Data.Map as Map +import qualified Data.DList as DL import Data.List -import Data.Aeson hiding (json) -import Data.Decimal -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types -import GHC.Generics -import Data.Maybe +import Data.Aeson () +import Data.Decimal () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () +import GHC.Generics () +import Data.Maybe () +import Data.Bifunctor (first) import AssetClass.AssetBase -import qualified Analytics as AN +import qualified Analytics as AN () import Control.Lens hiding (element) -import Control.Lens.TH +import Control.Lens.TH () -import Debug.Trace -import qualified Assumptions as A -debug = flip trace +import qualified Assumptions as A () -type PeriodAmount = Balance -type CapRate = Rate -type RentChangeRate = Rate -type RentChangeCurve = Ts type TermChangeRate = Rate type DayGap = Int -type LastAccuredDate = Date getNewRental :: AP.LeaseAssetRentAssump -> Date -> Date -> LeaseRateCalc -> (AP.LeaseAssetRentAssump, LeaseRateCalc) @@ -86,9 +81,6 @@ calcEndDate sd periods (ByPeriodRental _ per) = case genDates sd per periods of [] -> sd ds -> last ds -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 ,(AP.LeaseAssetRentAssump, TermChangeRate, DayGap)) @@ -125,30 +117,33 @@ nextLease l@(StepUpLease (LeaseInfo sd ot rental ob) lsteupInfo bal rt _) (rAssu -- | 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 newAssump new_lastDate (AP.CutByDate ed) (accum++[new_lease]) - where - (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 newAssump new_lastDate (AP.StopByExtTimes (pred n)) (accum++[new_lease]) - where - (new_lease,new_lastDate, newAssump) = nextLease l (rsc,tc,mg) - -nextLeaseTill l (rsc,tc,mg) lastDate (AP.EarlierOf ed n) accum - | lastDate >= ed = accum - | n == 0 = accum - | otherwise = nextLeaseTill new_lease newAssump new_lastDate (AP.EarlierOf ed (pred n)) (accum++[new_lease]) - where - (new_lease,new_lastDate, newAssump) = nextLease l (rsc,tc,mg) - -nextLeaseTill l (rsc,tc,mg) lastDate (AP.LaterOf ed n) accum - | lastDate >= ed && n == 0 = accum - | otherwise = nextLeaseTill new_lease newAssump new_lastDate (AP.LaterOf ed (pred n)) (accum++[new_lease]) - where - (new_lease,new_lastDate, newAssump) = nextLease l (rsc,tc,mg) +nextLeaseTill l assump lastDate endType accum = + DL.toList (go l assump lastDate endType (DL.fromList accum)) + where + go l (rsc,tc,mg) lastDate (AP.CutByDate ed) accum + | lastDate >= ed = accum + | otherwise = + let (new_lease,new_lastDate,newAssump) = nextLease l (rsc,tc,mg) + in go new_lease newAssump new_lastDate (AP.CutByDate ed) (DL.snoc accum new_lease) + + go l (rsc,tc,mg) lastDate (AP.StopByExtTimes n) accum + | n == 0 = accum + | otherwise = + let (new_lease,new_lastDate,newAssump) = nextLease l (rsc,tc,mg) + in go new_lease newAssump new_lastDate (AP.StopByExtTimes (pred n)) (DL.snoc accum new_lease) + + go l (rsc,tc,mg) lastDate (AP.EarlierOf ed n) accum + | lastDate >= ed = accum + | n == 0 = accum + | otherwise = + let (new_lease,new_lastDate,newAssump) = nextLease l (rsc,tc,mg) + in go new_lease newAssump new_lastDate (AP.EarlierOf ed (pred n)) (DL.snoc accum new_lease) + + go l (rsc,tc,mg) lastDate (AP.LaterOf ed n) accum + | lastDate >= ed && n == 0 = accum + | otherwise = + let (new_lease,new_lastDate,newAssump) = nextLease l (rsc,tc,mg) + in go new_lease newAssump new_lastDate (AP.LaterOf ed (pred n)) (DL.snoc accum new_lease) -- ^ calculate the daily rate for a step up lease calcPmts :: LeaseStepUp -> [Rate] -> Amount -> Either String [Amount] @@ -294,28 +289,25 @@ instance Asset Lease where -- = fst . patchBalance $ RegularLease (LeaseInfo sd ot dp dr ob) bal ot st projCashflow l asOfDay (AP.LeaseAssump mDefault gapAssump rentAssump endType,_,_) mRates - = let - pdates = getPaymentDates l 0 -- `debug` ("8")-- `debug` ("RCURVE"++show rcCurve) - -- get the gap days between leases - pickGapDays (AP.GapDays days) = days - pickGapDays (AP.GapDaysByCurve cv) = getIntValOnByDate cv asOfDay - - newLeases = nextLeaseTill - l - (rentAssump , 0.0 , pickGapDays gapAssump) - (case pdates of [] -> getOriginDate l; _ -> 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 (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,max asOfDay (getOriginDate l),Nothing) allTxns, Map.empty) + = do + gapDays <- case gapAssump of + AP.GapDays days -> Right days + AP.GapDaysByCurve cv -> first ("GapDaysByCurve: " ++) (tryGetIntValOnByDate cv asOfDay) + let pdates = getPaymentDates l 0 -- `debug` ("8")-- `debug` ("RCURVE"++show rcCurve) + newLeases = nextLeaseTill + l + (rentAssump , 0.0 , gapDays) + (case pdates of [] -> getOriginDate l; _ -> last pdates) + endType + [] + stressRentals = 0 + currentCf <- calcCashflow l asOfDay mRates + newCfs <- sequenceA [ calcCashflow l asOfDay mRates | l <- newLeases ] -- `debug` ("Current CF\n "++ show currentCf) + 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,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 diff --git a/src/AssetClass/Loan.hs b/src/AssetClass/Loan.hs index 0bafc448..22522363 100644 --- a/src/AssetClass/Loan.hs +++ b/src/AssetClass/Loan.hs @@ -6,7 +6,7 @@ module AssetClass.Loan (projectLoanFlow,updateOriginDate) where -import qualified Data.Time as T +import qualified Data.Time as T () import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) import qualified Assumptions as A import InterestRate @@ -18,22 +18,20 @@ import Types import qualified Data.Map as Map import Data.List import Data.Maybe -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types -import GHC.Generics +import Data.Aeson () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () +import GHC.Generics () import AssetClass.AssetBase import AssetClass.AssetCashflow -import Debug.Trace -import Assumptions (AssetDefaultAssumption(DefaultCDR)) +import Assumptions () import qualified Asset as A -import Control.Lens hiding (element) -import Control.Lens.TH +import Control.Lens () +import Control.Lens.TH () import qualified Data.DList as DL -debug = flip trace -- instance Asset Loan where diff --git a/src/AssetClass/MixedAsset.hs b/src/AssetClass/MixedAsset.hs index eea638c2..9563d57c 100644 --- a/src/AssetClass/MixedAsset.hs +++ b/src/AssetClass/MixedAsset.hs @@ -7,39 +7,38 @@ module AssetClass.MixedAsset (projAssetUnion,projAssetUnionList,projectCashflow, calcAssetUnion,curBal) where -import qualified Data.Time as T +import qualified Data.Time as T () import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) import qualified Assumptions as A import qualified AssetClass.AssetBase as ACM -import InterestRate -import Interface +import InterestRate () +import Interface () import qualified Asset as P import Lib -import Util -import DateUtil +import Util () +import DateUtil () import Types import qualified Data.Map as Map -import Data.List -import Data.Maybe -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types -import GHC.Generics +import Data.List () +import Data.Maybe () +import Data.Aeson () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () +import GHC.Generics () import AssetClass.AssetBase import AssetClass.Mortgage import AssetClass.Lease -import AssetClass.Loan -import AssetClass.Installment -import AssetClass.Receivable -import AssetClass.AssetCashflow -import AssetClass.FixedAsset -import AssetClass.ProjectedCashFlow +import AssetClass.Loan () +import AssetClass.Installment () +import AssetClass.Receivable () +import AssetClass.AssetCashflow () +import AssetClass.FixedAsset () +import AssetClass.ProjectedCashFlow () -import Debug.Trace -import Assumptions (AssetDefaultAssumption(DefaultCDR)) -import qualified Asset as Ast +import Assumptions () +import qualified Asset as Ast () @@ -205,7 +204,6 @@ calcAssetUnion (ACM.LS ast) d mRates = P.calcCashflow ast d mRates calcAssetUnion (ACM.FA ast) d mRates = P.calcCashflow ast d mRates calcAssetUnion (ACM.RE ast) d mRates = P.calcCashflow ast d mRates calcAssetUnion (ACM.PF ast) d mRates = P.calcCashflow ast d mRates -calcAssetUnion x _ _ = Left ("Failed to match proj AssetUnion"++ show x) projAssetUnion :: ACM.AssetUnion -> Date -> A.AssetPerf -> Maybe [RateAssumption] -> Either String (CF.CashFlowFrame, Map.Map CutoffFields Balance) @@ -216,7 +214,6 @@ projAssetUnion (ACM.LS ast) d assumps mRates = P.projCashflow ast d assumps mRat projAssetUnion (ACM.FA ast) d assumps mRates = P.projCashflow ast d assumps mRates projAssetUnion (ACM.RE ast) d assumps mRates = P.projCashflow ast d assumps mRates projAssetUnion (ACM.PF ast) d assumps mRates = P.projCashflow ast d assumps mRates -projAssetUnion x _ _ _ = Left ("Failed to match proj AssetUnion"++ show x) projAssetUnionList :: [ACM.AssetUnion] -> Date -> A.ApplyAssumptionType -> Maybe [RateAssumption] -> Either String (CF.CashFlowFrame, Map.Map CutoffFields Balance) diff --git a/src/AssetClass/Mortgage.hs b/src/AssetClass/Mortgage.hs index 0497808b..1d9913b6 100644 --- a/src/AssetClass/Mortgage.hs +++ b/src/AssetClass/Mortgage.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveGeneric #-} @@ -7,7 +8,7 @@ module AssetClass.Mortgage ,buildARMrates) where -import qualified Data.Time as T +import qualified Data.Time as T () import qualified Cashflow as CF import qualified Assumptions as A import Asset as Ast @@ -19,25 +20,23 @@ import InterestRate as IR import qualified Data.Map as Map import Data.List -import Data.Ratio +import Data.Ratio () import Data.Maybe -import GHC.Generics -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types +import GHC.Generics () +import Data.Aeson () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () import AssetClass.AssetBase import AssetClass.AssetCashflow -import Debug.Trace import Assumptions (AssetPerfAssumption(MortgageAssump)) -import GHC.Float.RealFracMethods (truncateFloatInteger) +import GHC.Float.RealFracMethods () import Cashflow (extendTxns) import Control.Lens hiding (element) -import Control.Lens.TH +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]) -> (DL.DList CF.TsRow, Balance, Balance) projectMortgageFlow (originBal, startBal, lastPayDate, mbn, pt, dc, startRate, p, oTerms) (cfDates, defRates, ppyRates, rateVector, remainTerms) = @@ -70,174 +69,185 @@ projectMortgageFlow (originBal, startBal, lastPayDate, mbn, pt, dc, startRate, p projectDelinqMortgageFlow :: ([CF.TsRow],[CF.TsRow]) -> Balance -> Maybe Int -> Date -> [Date] -> [Rate] -> [PrepaymentRate] -> [IRate] -> (Rate,Lag,Rate,Lag,Period,AmortPlan,Int) -> ([Balance],[Balance],[Balance]) -> [CF.TsRow] -projectDelinqMortgageFlow (trs,[]) _ _ _ [] _ _ _ _ _ = CF.dropTailEmptyTxns trs -projectDelinqMortgageFlow (trs,backToPerfs) _ _ _ [] _ _ _ _ _ = - let - consolTxn = sort backToPerfs -- `debug` ("Hit pay dates = []") - (trsKeep,trsMerge) = splitByDate trs (getDate (head backToPerfs)) EqToRight - mergedTrs = CF.combineTss [] trsMerge consolTxn -- `debug` ("before Merge for delinq Mortgage \n >>> "++ show trs++"Back to Perf"++ show backToPerfs) - in - trsKeep ++ mergedTrs -- `debug` ("\n MergedTrs \n"++ show mergedTrs) - -projectDelinqMortgageFlow (trs,backToPerfs) beginBal mbn lastDate (pDate:pDates) (delinqRate:delinqRates) (ppyRate:ppyRates) (rate:rates) - (defaultPct,defaultLag,recoveryRate,recoveryLag,p,prinType,ot) - (dBal:defaultVec,rAmt:recoveryVec,lAmt:lossVec) - = projectDelinqMortgageFlow (trs++[tr],CF.combineTss [] backToPerfs newPerfCfs) endingBal newMbn pDate pDates delinqRates ppyRates rates - (defaultPct,defaultLag,recoveryRate,recoveryLag,p,prinType,ot) - (newDefaultVec,newRecoveryVec,newLossVec) -- `debug` ("\n calc Date"++ show pDate ++"\n from new perf"++ show backToPerfBal ++"\n new cfs >>> \n"++ show newPerfCfs) - where - remainTerms = succ $ max 0 (length pDates - recoveryLag - defaultLag) - delinqBal = mulBR beginBal delinqRate - - defaultBal = mulBR delinqBal defaultPct - recBal = mulBR defaultBal recoveryRate - lossBal = mulBR defaultBal (1 - recoveryRate) - - newDefaultVec = replace defaultVec (pred defaultLag) defaultBal - newRecoveryVec = replace recoveryVec (pred recoveryLag + defaultLag) recBal - newLossVec = replace lossVec (pred recoveryLag + defaultLag) lossBal - - backToPerfBal = mulBR delinqBal (1 - defaultPct) - - restPerfVector = replicate (succ (length delinqRates)) 0 - restPerfBal = fromRational <$> restPerfVector -- `debug` ("Dates"++show (pDate:pDates)) - newPerfCfs = if backToPerfBal > 0.0 then - projectDelinqMortgageFlow ([],[]) backToPerfBal Nothing (pDates!!defaultLag) (drop defaultLag (pDate:pDates)) - restPerfVector restPerfVector - (drop defaultLag (rate:rates)) - (0,0,0,0,p,prinType,ot) - (restPerfBal,restPerfBal,restPerfBal) -- `debug` ("\nStarting new perf >>> \n"++ show backToPerfBal) - else - [] - - balAfterDelinq = beginBal - delinqBal - ppyAmt = mulBR balAfterDelinq ppyRate - balAfterPpy = balAfterDelinq - ppyAmt - periodRate = periodRateFromAnnualRate p rate - amortTerm = case prinType of - Balloon aTerm -> aTerm - _ -> ot - -- scheduleBalance = calcScheduleBalaceToday m - (intAmt, prinAmt) = calcAssetPrinInt prinType balAfterPpy periodRate ot remainTerms (0,amortTerm) - - endingBal = beginBal - prinAmt - ppyAmt - delinqBal -- `debug` ("DATE"++show pDate++">>>"++ show beginBal++">>"++show prinAmt ++ ">>" ++ show ppyAmt ++ ">>"++ show delinqBal) - downFactor = divideBB beginBal endingBal - newMbn = decreaseBorrowerNum beginBal endingBal mbn - tr = CF.MortgageDelinqFlow pDate endingBal prinAmt intAmt ppyAmt delinqBal dBal rAmt lAmt rate newMbn Nothing Nothing-- `debug` ("Date"++ show pDate ++ "ENDING BAL AT"++ show endingBal) - +projectDelinqMortgageFlow (trs, backToPerfs) beginBal mbn lastDate pDates delinqRates ppyRates rates assump vectors = + go (DL.fromList trs) backToPerfs beginBal mbn lastDate pDates delinqRates ppyRates rates assump vectors + where + go acc [] _ _ _ [] _ _ _ _ _ = CF.dropTailEmptyTxns (DL.toList acc) + go acc backToPerfs _ _ _ [] _ _ _ _ _ = + let + consolTxn = sort backToPerfs + trsList = DL.toList acc + (trsKeep,trsMerge) = splitByDate trsList (getDate (head backToPerfs)) EqToRight + mergedTrs = CF.combineTss [] trsMerge consolTxn + in + trsKeep ++ mergedTrs + + go acc backToPerfs beginBal mbn lastDate (pDate:pDates) (delinqRate:delinqRates) (ppyRate:ppyRates) (rate:rates) + (defaultPct,defaultLag,recoveryRate,recoveryLag,p,prinType,ot) + (dBal:defaultVec,rAmt:recoveryVec,lAmt:lossVec) + = go (DL.snoc acc tr) (CF.combineTss [] backToPerfs newPerfCfs) endingBal newMbn pDate pDates delinqRates ppyRates rates + (defaultPct,defaultLag,recoveryRate,recoveryLag,p,prinType,ot) + (newDefaultVec,newRecoveryVec,newLossVec) + where + remainTerms = succ $ max 0 (length pDates - recoveryLag - defaultLag) + delinqBal = mulBR beginBal delinqRate + + defaultBal = mulBR delinqBal defaultPct + recBal = mulBR defaultBal recoveryRate + lossBal = mulBR defaultBal (1 - recoveryRate) + + newDefaultVec = replace defaultVec (pred defaultLag) defaultBal + newRecoveryVec = replace recoveryVec (pred recoveryLag + defaultLag) recBal + newLossVec = replace lossVec (pred recoveryLag + defaultLag) lossBal + + backToPerfBal = mulBR delinqBal (1 - defaultPct) + + restPerfVector = replicate (succ (length delinqRates)) 0 + restPerfBal = fromRational <$> restPerfVector + newPerfCfs = if backToPerfBal > 0.0 then + projectDelinqMortgageFlow ([],[]) backToPerfBal Nothing (pDates!!defaultLag) (drop defaultLag (pDate:pDates)) + restPerfVector restPerfVector + (drop defaultLag (rate:rates)) + (0,0,0,0,p,prinType,ot) + (restPerfBal,restPerfBal,restPerfBal) + else + [] + + balAfterDelinq = beginBal - delinqBal + ppyAmt = mulBR balAfterDelinq ppyRate + balAfterPpy = balAfterDelinq - ppyAmt + periodRate = periodRateFromAnnualRate p rate + amortTerm = case prinType of + Balloon aTerm -> aTerm + _ -> ot + (intAmt, prinAmt) = calcAssetPrinInt prinType balAfterPpy periodRate ot remainTerms (0,amortTerm) + + endingBal = beginBal - prinAmt - ppyAmt - delinqBal + downFactor = divideBB beginBal endingBal + newMbn = decreaseBorrowerNum beginBal endingBal mbn + tr = CF.MortgageDelinqFlow pDate endingBal prinAmt intAmt ppyAmt delinqBal dBal rAmt lAmt rate newMbn Nothing Nothing projectScheduleFlow :: [CF.TsRow] -> Rate -> Balance -> [CF.TsRow] -> [DefaultRate] -> [PrepaymentRate] -> [Amount] -> [Amount] -> (Int, Rate) -> [CF.TsRow] -projectScheduleFlow trs _ last_bal [] _ _ [] [] (_,_) = trs -projectScheduleFlow trs bal_factor last_bal (flow:flows) (defRate:defRates) (ppyRate:ppyRates) recV lossV (recoveryLag,recoveryRate) - = projectScheduleFlow (trs++[tr]) surviveRate endBal flows defRates ppyRates (tail recVector) (tail lossVector) (recoveryLag,recoveryRate) -- `debug` ("===>C") - where - startBal = last_bal - defAmt = mulBR startBal defRate - ppyAmt = mulBR (startBal - defAmt) ppyRate - afterBal = startBal - defAmt - ppyAmt - - surviveRate = (1 - defRate) * (1 - ppyRate) * bal_factor - schedulePrin = mulBR (CF.mflowPrincipal flow) surviveRate --TODO round trip -- `debug` ("Schedule Principal"++(printf "%.2f" (CF.mflowPrincipal flow))++" Rate"++show(_schedule_rate)) - scheduleInt = mulBR (CF.mflowInterest flow) surviveRate - - newRec = mulBR defAmt recoveryRate - newLoss = mulBR defAmt (1 - recoveryRate) - - recVector = replace recV recoveryLag newRec - lossVector = replace lossV recoveryLag newLoss - - endBal = max 0 $ afterBal - schedulePrin - - tr = CF.MortgageFlow (CF.getDate flow) endBal schedulePrin scheduleInt ppyAmt defAmt (head recVector) (head lossVector) 0.0 Nothing Nothing Nothing--TODO missing ppy-penalty here - -projectScheduleFlow trs b_factor lastBal [] _ _ (r:rs) (l:ls) (recovery_lag,recovery_rate) - = projectScheduleFlow (trs++[tr]) b_factor lastBal [] [] [] rs ls (recovery_lag - 1,recovery_rate) - where - remain_length = length rs - lastDate = CF.getDate (last trs) - flowDate = nextDate lastDate Lib.Monthly - tr = CF.MortgageFlow flowDate lastBal 0 0 0 0 r l 0.0 Nothing Nothing Nothing +projectScheduleFlow trs bal_factor last_bal flows defRates ppyRates recV lossV params = + DL.toList (go (DL.fromList trs) (lastMaybe trs) bal_factor last_bal flows defRates ppyRates recV lossV params) + where + lastMaybe [] = Nothing + lastMaybe xs = Just (last xs) + + go acc _ _ last_bal [] _ _ [] [] (_,_) = acc + go acc _ bal_factor last_bal (flow:flows) (defRate:defRates) (ppyRate:ppyRates) recV lossV (recoveryLag,recoveryRate) + = let + startBal = last_bal + defAmt = mulBR startBal defRate + ppyAmt = mulBR (startBal - defAmt) ppyRate + afterBal = startBal - defAmt - ppyAmt + + surviveRate = (1 - defRate) * (1 - ppyRate) * bal_factor + schedulePrin = mulBR (CF.mflowPrincipal flow) surviveRate + scheduleInt = mulBR (CF.mflowInterest flow) surviveRate + + newRec = mulBR defAmt recoveryRate + newLoss = mulBR defAmt (1 - recoveryRate) + + recVector = replace recV recoveryLag newRec + lossVector = replace lossV recoveryLag newLoss + + endBal = max 0 $ afterBal - schedulePrin + + tr = CF.MortgageFlow (CF.getDate flow) endBal schedulePrin scheduleInt ppyAmt defAmt (head recVector) (head lossVector) 0.0 Nothing Nothing Nothing + in + go (DL.snoc acc tr) (Just tr) surviveRate endBal flows defRates ppyRates (tail recVector) (tail lossVector) (recoveryLag,recoveryRate) + + go acc mLast b_factor lastBal [] _ _ (r:rs) (l:ls) (recovery_lag,recovery_rate) + = let + lastDate = getDate (fromMaybe (error "Prelude.last: empty list") mLast) + flowDate = nextDate lastDate Lib.Monthly + tr = CF.MortgageFlow flowDate lastBal 0 0 0 0 r l 0.0 Nothing Nothing Nothing + in + go (DL.snoc acc tr) (Just tr) b_factor lastBal [] [] [] rs ls (recovery_lag - 1,recovery_rate) type DelinqRate = Rate projectScheduleDelinqFlow :: ([CF.TsRow],[CF.TsRow]) -> Rate -> Balance -> [CF.TsRow] -> [DelinqRate] -> [PrepaymentRate] -> [Amount] -> [Amount] -> [Amount] -> (Rate,Int,Rate,Int) -> [CF.TsRow] -projectScheduleDelinqFlow (trs,[]) _ begBal flows [] [] defaults recoveries losses _ = - let - patchedFlows = [ CF.MortgageDelinqFlow d begBal prin int prepay delinq defVal recVal lossVal rate mB mPPN Nothing - | (CF.MortgageDelinqFlow d bal prin int prepay delinq _ _ _ rate mB mPPN Nothing,defVal,recVal,lossVal) <- zip4 flows defaults recoveries losses] -- `debug` ("Length of default"++ show defaults++">>recovery>>"++ show recoveries++">>loss>>"++ show losses) - r1 = sort $ trs ++ patchedFlows -- `debug` ("Patched rows\n"++show patchedFlows) - in - r1 - -projectScheduleDelinqFlow (trs,newPerfs) _ begBal flows [] [] defaults recoveries losses _ = - let - patchedFlows = [ CF.MortgageDelinqFlow d begBal prin int prepay delinq defVal recVal lossVal rate mB mPPN Nothing - | (CF.MortgageDelinqFlow d bal prin int prepay delinq _ _ _ rate mB mPPN Nothing,defVal,recVal,lossVal) <- zip4 flows defaults recoveries losses] -- `debug` ("Length of default"++ show defaults++">>recovery>>"++ show recoveries++">>loss>>"++ show losses) - r1 = sort $ trs ++ patchedFlows -- `debug` ("Patched rows\n"++show patchedFlows) - r3 = CF.aggregateTsByDate [] $ sort newPerfs -- `debug` ("New Perfs\n"++ show newPerfs) - (r1keep, r1merge) = splitByDate r1 (getDate (head r3)) EqToRight -- `debug` ("r3 \n"++ show r3) - r4 = CF.combineTss [] r1merge r3 -- `debug` ("r1keep \n"++ show r1keep++"\n r1merge \n"++ show r1merge) - in - r1keep ++ r4 -- `debug` ("r4 \n"++ show r4) - -projectScheduleDelinqFlow (trs,backToPerfCfs) surviveRate begBal (flow:flows) (delinqRate:delinqRates) (ppyRate:ppyRates) (defaultBal:defaultBals) (recoveryBal:recoveryBals) (lossBal:lossBals) (defaultPct,defaultLag,recoveryRate,recoveryLag) - = projectScheduleDelinqFlow (trs++[tr],CF.combineTss [] backToPerfCfs currentBackToPerfCfs) newSurviveRate endBal flows delinqRates ppyRates newDefaultBals newRecoveryBals newLossBals (defaultPct,defaultLag,recoveryRate,recoveryLag) -- `debug` ("new back to perf flow"++ show backToPerfCfs) - where - delinqAmt = mulBR begBal delinqRate -- `debug` ("delinq Rate"++ show delinqRate) - ppyAmt = mulBR (begBal - delinqAmt) ppyRate -- `debug` ("begbal"++ show begBal++">>"++ show delinqAmt) - newSurviveRate = (1-delinqRate) * (1-ppyRate) * surviveRate - - scheduleBal = view CF.tsRowBalance flow - schedulePrin = mulBR (CF.mflowPrincipal flow) surviveRate - scheduleInt = mulBR (CF.mflowInterest flow) surviveRate - - newDefaultBal = mulBR delinqAmt defaultPct - endBal = max 0 $ (begBal - delinqAmt - ppyAmt - schedulePrin) - currentBackToPerfCfs = let - futureDs = drop (defaultLag+recoveryLag) $ getDates (flow:flows) - splitPct = divideBB (mulBR delinqAmt (1-defaultPct)) begBal - perfFlows = take (length flows - defaultLag - recoveryLag + 1) $ CF.splitTrs splitPct (flow:flows) - in - [ set CF.tsDate d f | (d,f) <- zip futureDs perfFlows ] - - newDefaultBals = replace defaultBals (pred defaultLag) newDefaultBal - newRecoveryBals = replace recoveryBals (recoveryLag + pred defaultLag) (mulBR newDefaultBal recoveryRate) - newLossBals = replace lossBals (recoveryLag + pred defaultLag) (mulBR newDefaultBal (1-recoveryRate)) -- `debug` ("new loss def"++ show defaultBal++">>rate"++ show (1-recoveryRate) ) - tr = CF.MortgageDelinqFlow (CF.getDate flow) endBal schedulePrin scheduleInt ppyAmt delinqAmt defaultBal recoveryBal lossBal (CF.mflowRate flow) Nothing - Nothing Nothing -- `debug` ("|||>>> proj at date"++ show (CF.getDate flow)) +projectScheduleDelinqFlow (trs, backToPerfCfs) surviveRate begBal flows delinqRates ppyRates defaultBals recoveryBals lossBals params = + DL.toList (go (DL.fromList trs) backToPerfCfs surviveRate begBal flows delinqRates ppyRates defaultBals recoveryBals lossBals params) + where + go acc [] _ begBal flows [] [] defaults recoveries losses _ = + let + trsList = DL.toList acc + patchedFlows = [ CF.MortgageDelinqFlow d begBal prin int prepay delinq defVal recVal lossVal rate mB mPPN Nothing + | (CF.MortgageDelinqFlow d bal prin int prepay delinq _ _ _ rate mB mPPN Nothing,defVal,recVal,lossVal) <- zip4 flows defaults recoveries losses] + r1 = sort $ trsList ++ patchedFlows + in + DL.fromList r1 + + go acc newPerfs _ begBal flows [] [] defaults recoveries losses _ = + let + trsList = DL.toList acc + patchedFlows = [ CF.MortgageDelinqFlow d begBal prin int prepay delinq defVal recVal lossVal rate mB mPPN Nothing + | (CF.MortgageDelinqFlow d bal prin int prepay delinq _ _ _ rate mB mPPN Nothing,defVal,recVal,lossVal) <- zip4 flows defaults recoveries losses] + r1 = sort $ trsList ++ patchedFlows + r3 = CF.aggregateTsByDate [] $ sort newPerfs + (r1keep, r1merge) = splitByDate r1 (getDate (head r3)) EqToRight + r4 = CF.combineTss [] r1merge r3 + in + DL.fromList (r1keep ++ r4) + + go acc backToPerfCfs surviveRate begBal (flow:flows) (delinqRate:delinqRates) (ppyRate:ppyRates) (defaultBal:defaultBals) (recoveryBal:recoveryBals) (lossBal:lossBals) (defaultPct,defaultLag,recoveryRate,recoveryLag) + = go (DL.snoc acc tr) (CF.combineTss [] backToPerfCfs currentBackToPerfCfs) newSurviveRate endBal flows delinqRates ppyRates newDefaultBals newRecoveryBals newLossBals (defaultPct,defaultLag,recoveryRate,recoveryLag) + where + delinqAmt = mulBR begBal delinqRate + ppyAmt = mulBR (begBal - delinqAmt) ppyRate + newSurviveRate = (1-delinqRate) * (1-ppyRate) * surviveRate + + scheduleBal = view CF.tsRowBalance flow + schedulePrin = mulBR (CF.mflowPrincipal flow) surviveRate + scheduleInt = mulBR (CF.mflowInterest flow) surviveRate + + newDefaultBal = mulBR delinqAmt defaultPct + endBal = max 0 $ (begBal - delinqAmt - ppyAmt - schedulePrin) + currentBackToPerfCfs = let + futureDs = drop (defaultLag+recoveryLag) $ getDates (flow:flows) + splitPct = divideBB (mulBR delinqAmt (1-defaultPct)) begBal + perfFlows = take (length flows - defaultLag - recoveryLag + 1) $ CF.splitTrs splitPct (flow:flows) + in + [ set CF.tsDate d f | (d,f) <- zip futureDs perfFlows ] + + newDefaultBals = replace defaultBals (pred defaultLag) newDefaultBal + newRecoveryBals = replace recoveryBals (recoveryLag + pred defaultLag) (mulBR newDefaultBal recoveryRate) + newLossBals = replace lossBals (recoveryLag + pred defaultLag) (mulBR newDefaultBal (1-recoveryRate)) + tr = CF.MortgageDelinqFlow (CF.getDate flow) endBal schedulePrin scheduleInt ppyAmt delinqAmt defaultBal recoveryBal lossBal (CF.mflowRate flow) Nothing + Nothing Nothing -- | implementation on projection via default balance amount projCashflowByDefaultAmt :: (Balance, Date, AmortPlan, Period,IRate,Maybe BorrowerNum) -> (Dates, ([Balance],[Balance]), [Rate], [IRate], [Int]) -> [CF.TsRow] projCashflowByDefaultAmt (cb,lastPayDate,pt,p,cr,mbn) (cfDates,(expectedDefaultBals,unAppliedDefaultBals), ppyRates, rateVector, remainTerms) = - let + go (DL.singleton initRow) cb mbn (zip5 cfDates (zip expectedDefaultBals unAppliedDefaultBals) ppyRates rateVector remainTerms) + where initRow = CF.MortgageFlow lastPayDate cb 0.0 0.0 0.0 0.0 0.0 0.0 cr mbn Nothing Nothing - in - foldl - (\acc (pDate, (defaultBal,futureDefualtBal), ppyRate, rate, rt) - -> let - begBal = view CF.tsRowBalance (last acc) - mBorrower = CF.mflowBorrowerNum (last acc) - newDefault = if begBal <= (defaultBal+futureDefualtBal) then - begBal - else - defaultBal - newPrepay = mulBR (max 0 (begBal - newDefault)) ppyRate -- `debug` ("mb from last"++ show mBorrower) - newInt = mulBI (max 0 (begBal - newDefault - newPrepay)) (periodRateFromAnnualRate p rate) - intBal = max 0 $ begBal - newDefault - newPrepay -- `debug` ("using rt"++ show rt) - newPrin = case (rt,pt) of - (0,_) -> intBal - (_,Level) -> let - pmt = calcPmt intBal (periodRateFromAnnualRate p rate) rt -- `debug` ("PMT with rt"++ show rt) - in - pmt - newInt - (_,Even) -> intBal / fromIntegral rt - _ -> error ("Unsupport Prin type for mortgage"++ show pt) - endBal = intBal - newPrin - newMbn = decreaseBorrowerNum begBal endBal mBorrower -- `debug` (">>> pdate"++ show pDate) - in - acc ++ [CF.MortgageFlow pDate endBal newPrin newInt newPrepay newDefault 0.0 0.0 rate newMbn Nothing Nothing] - ) - [initRow] - (zip5 cfDates (zip expectedDefaultBals unAppliedDefaultBals) ppyRates rateVector remainTerms) + + go acc _ _ [] = DL.toList acc + go acc !begBal !mBorrower ((pDate, (defaultBal,futureDefualtBal), ppyRate, rate, rt):rest) = + let + newDefault = if begBal <= (defaultBal+futureDefualtBal) then + begBal + else + defaultBal + newPrepay = mulBR (max 0 (begBal - newDefault)) ppyRate + newInt = mulBI (max 0 (begBal - newDefault - newPrepay)) (periodRateFromAnnualRate p rate) + intBal = max 0 $ begBal - newDefault - newPrepay + newPrin = case (rt,pt) of + (0,_) -> intBal + (_,Level) -> let + pmt = calcPmt intBal (periodRateFromAnnualRate p rate) rt + in + pmt - newInt + (_,Even) -> intBal / fromIntegral rt + _ -> error ("Unsupport Prin type for mortgage"++ show pt) + endBal = intBal - newPrin + newMbn = decreaseBorrowerNum begBal endBal mBorrower + in + go (DL.snoc acc (CF.MortgageFlow pDate endBal newPrin newInt newPrepay newDefault 0.0 0.0 rate newMbn Nothing Nothing)) + endBal newMbn rest -- TODO to fix here , hard code on Left calcScheduleBalaceToday :: Mortgage -> Maybe [RateAssumption] -> Date -> Balance @@ -256,41 +266,35 @@ calcScheduleBalaceToday m mRates asOfDay -- | implementation on projection via default balance amount projScheduleCashflowByDefaultAmt :: (Balance, Date,IRate,Maybe BorrowerNum) -> ([CF.TsRow], ([Balance],[Balance]), [Rate] ) -> ([CF.TsRow], Rate) projScheduleCashflowByDefaultAmt (cb,lastPayDate,cr,mbn) (scheduleFlows,(expectedDefaultBals,unAppliedDefaultBals), ppyRates) = - let + go (DL.singleton initRow) 1.0 cb mbn (zip3 scheduleFlows (zip expectedDefaultBals unAppliedDefaultBals) ppyRates) + where initRow = CF.MortgageFlow lastPayDate cb 0.0 0.0 0.0 0.0 0.0 0.0 cr mbn Nothing Nothing - in - foldl - (\(acc,factor) (cflow, (defaultBal,futureDefualtBal), ppyRate) - -> let - pDate = getDate cflow - - begBal = view CF.tsRowBalance (last acc) - mBorrower = CF.mflowBorrowerNum (last acc) - - newDefault = if begBal <= (defaultBal+futureDefualtBal) then - begBal - else - defaultBal - newPrepay = mulBR (max 0 (begBal - newDefault)) ppyRate -- `debug` ("mb from last"++ show mBorrower) - - intBal = max 0 $ begBal - newDefault - newPrepay - defRate = if (begBal - newPrepay) /= 0 then - divideBB newDefault (begBal - newPrepay) - else - 0 - newFactor = (1 - ppyRate) * (1 - defRate) * factor - newInt = mulBR (CF.mflowInterest cflow) newFactor - newPrin = mulBR (CF.mflowPrincipal cflow) newFactor - - endBal = intBal - newPrin - newMbn = decreaseBorrowerNum begBal endBal mBorrower - in - (acc ++ [CF.MortgageFlow pDate endBal newPrin newInt newPrepay newDefault 0.0 0.0 - cr newMbn Nothing Nothing] - ,newFactor) - ) - ([initRow],1.0) - (zip3 scheduleFlows (zip expectedDefaultBals unAppliedDefaultBals) ppyRates) + + go acc !factor _ _ [] = (DL.toList acc, factor) + go acc !factor !begBal !mBorrower ((cflow, (defaultBal,futureDefualtBal), ppyRate):rest) = + let + pDate = getDate cflow + newDefault = if begBal <= (defaultBal+futureDefualtBal) then + begBal + else + defaultBal + newPrepay = mulBR (max 0 (begBal - newDefault)) ppyRate + + intBal = max 0 $ begBal - newDefault - newPrepay + defRate = if (begBal - newPrepay) /= 0 then + divideBB newDefault (begBal - newPrepay) + else + 0 + newFactor = (1 - ppyRate) * (1 - defRate) * factor + newInt = mulBR (CF.mflowInterest cflow) newFactor + newPrin = mulBR (CF.mflowPrincipal cflow) newFactor + + endBal = intBal - newPrin + newMbn = decreaseBorrowerNum begBal endBal mBorrower + in + go (DL.snoc acc (CF.MortgageFlow pDate endBal newPrin newInt newPrepay newDefault 0.0 0.0 + cr newMbn Nothing Nothing)) + newFactor endBal newMbn rest buildARMrates :: IR.RateType -> (ARM,Date,Date,Date,IRate) -> Maybe [RateAssumption] -> Ts buildARMrates (IR.Fix _ _ ) _ _ = error "ARM should have floater rate" diff --git a/src/AssetClass/ProjectedCashFlow.hs b/src/AssetClass/ProjectedCashFlow.hs index 742952bd..cc2f9e87 100644 --- a/src/AssetClass/ProjectedCashFlow.hs +++ b/src/AssetClass/ProjectedCashFlow.hs @@ -6,7 +6,7 @@ module AssetClass.ProjectedCashFlow (ProjectedCashFlow(..),projFixCfwithAssumption) where -import qualified Data.Time as T +import qualified Data.Time as T () import qualified Assumptions as A import Asset as Ast import Types @@ -17,25 +17,23 @@ import InterestRate as IR import qualified Data.Map as Map import Data.List -import Data.Ratio +import Data.Ratio () import Data.Maybe -import GHC.Generics -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types +import GHC.Generics () +import Data.Aeson () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () import qualified Data.DList as DL import qualified Cashflow as CF import AssetClass.AssetBase import AssetClass.AssetCashflow -import Cashflow (extendTxns,TsRow(..)) +import Cashflow () -import Debug.Trace import Control.Lens hiding (element,Index) -import Control.Lens.TH -debug = flip trace +import Control.Lens.TH () data IntCalcType = ByRate IRate @@ -231,10 +229,7 @@ instance Ast.Asset ProjectedCashFlow where = do (fixedCashFlow, floatedCashFlow) <- seperateCashflows f (Just pAssump) mRates return (foldl CF.combine fixedCashFlow floatedCashFlow, Map.empty) - - projCashflow a b c d = Left $ "Failed to match when proj projected flow with assumption >>" ++ show a ++ show b ++ show c ++ show d - getBorrowerNum f = 0 splitWith f rs = [f] diff --git a/src/AssetClass/Receivable.hs b/src/AssetClass/Receivable.hs index 359cd52d..ad52fd6c 100644 --- a/src/AssetClass/Receivable.hs +++ b/src/AssetClass/Receivable.hs @@ -14,27 +14,25 @@ import Types import Lib import Util import DateUtil -import InterestRate as IR - -import qualified Data.Map as Map -import Data.List -import Data.Ratio -import Data.Maybe -import GHC.Generics -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types +import InterestRate as IR () + +import qualified Data.Map as Map () +import Data.List () +import Data.Ratio () +import Data.Maybe () +import GHC.Generics () +import Data.Aeson () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () import AssetClass.AssetBase import AssetClass.AssetCashflow -import Debug.Trace -import Assumptions (AssetPerfAssumption(ReceivableAssump)) -import GHC.Float.RealFracMethods (truncateFloatInteger) -import Cashflow (extendTxns) +import Assumptions () +import GHC.Float.RealFracMethods () +import Cashflow () import qualified Asset as A -debug = flip trace -- project recovery cashflow from recovery assumption and defaulted balance buildRecoveryCfs :: StartDate -> Balance -> Maybe A.RecoveryAssumption -> Either String [CF.TsRow] @@ -79,6 +77,8 @@ instance Asset Receivable where getPaymentDates r@(Invoice (ReceivableInfo sd ob oa dd ft _) st) _ = [dd] + getOriginBal r@(Invoice (ReceivableInfo _ ob _ _ _ _) _) = ob + calcCashflow r@(Invoice (ReceivableInfo sd ob oa dd ft _) st) asOfDay _ = Right $ CF.CashFlowFrame (ob,asOfDay,Nothing) $ cutBy Inc Future asOfDay txns where diff --git a/src/Assumptions.hs b/src/Assumptions.hs index 93ebb95c..c6b08d5e 100644 --- a/src/Assumptions.hs +++ b/src/Assumptions.hs @@ -29,29 +29,27 @@ module Assumptions (BondPricingInput(..),IrrType(..) where import Call as C -import Lib (Ts(..),TsPoint(..),toDate,mkRateTs) +import Lib (mkRateTs) import Liability (Bond,InterestInfo(..)) import Util import DateUtil import qualified Data.Map as Map import Data.List import qualified Data.Set as Set -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Data.Aeson +import Language.Haskell.TH () import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () import Types -import qualified Data.Time as T -import Data.Fixed -import Data.Ratio +import qualified Data.Time as T () +import Data.Fixed () +import Data.Ratio () import Revolving import GHC.Generics -import AssetClass.AssetBase -import Debug.Trace +import AssetClass.AssetBase () import qualified InterestRate as IR import Control.Lens hiding (Index) -debug = flip trace type AssetPerf = (AssetPerfAssumption,AssetDelinqPerfAssumption,AssetDefaultedPerfAssumption) type StratPerfByIdx = ([Int],AssetPerf) @@ -129,9 +127,9 @@ data CallOpt = LegacyOpts [C.CallOption] -- ^ legacy support | CallOnDates DatePattern [Pre] -- ^ test call at end of day deriving (Show, Generic, Read, Ord, Eq) -data StopBy = StopByDate Date -- ^ stop by date - | StopByPre DatePattern [Pre] -- ^ stop by precondition - deriving (Show, Generic, Read) +data StopBy = StopByDate Date -- ^ stop by date + | StopByPre DatePattern [Pre] -- ^ stop by precondition + deriving (Show, Generic, Read) data NonPerfAssumption = NonPerfAssumption { @@ -258,7 +256,6 @@ data ExtraStress = ExtraStress { ,poolHairCut :: Maybe [(PoolSource, Rate)] -- ^ haircut on pool income source } deriving (Show,Generic,Read) -type ExtendCashflowDates = DatePattern data AssetDefaultedPerfAssumption = DefaultedRecovery Rate Int [Rate] | DummyDefaultAssump @@ -286,7 +283,6 @@ data RevolvingAssumption = AvailableAssets RevolvingPool ApplyAssumptionType type HistoryCash = [(Date,Amount)] type CurrentHolding = Balance -- as of the deal date type PricingDate = Date -type AmountToBuy = Balance data TradeType = ByCash Balance @@ -334,8 +330,7 @@ getRateAssumption :: [RateAssumption] -> Index -> Maybe RateAssumption getRateAssumption assumps idx = find (\case (RateCurve _idx _) -> idx == _idx - (RateFlat _idx _) -> idx == _idx - _ -> False) + (RateFlat _idx _) -> idx == _idx) assumps -- | project rates used by rate type ,with interest rate assumptions and observation dates @@ -364,8 +359,6 @@ projRates sr (IR.Floater _ idx spd r dp rfloor rcap mr) (Just assumps) ds (Just fv, Nothing) -> floorWith fv $ fromRational <$> ratesUsedByDates (Nothing, Just cv) -> capWith cv $ fromRational <$> ratesUsedByDates -projRates _ rt rassump ds = Left ("Invalid rate type: "++ show rt++" assump: "++ show rassump) - -- ^ split call option assumption , -- lefts are for waterfall payment days -- rights are for date-based calls diff --git a/src/Call.hs b/src/Call.hs index 21fbe017..a5a71070 100644 --- a/src/Call.hs +++ b/src/Call.hs @@ -5,13 +5,13 @@ module Call(CallOption(..)) where -import qualified Data.Time as T +import qualified Data.Time as T () import Lib import Types -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Data.Aeson +import Language.Haskell.TH () import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () import GHC.Generics data CallOption diff --git a/src/Cashflow.hs b/src/Cashflow.hs index 4da8147b..ae0c2388 100644 --- a/src/Cashflow.hs +++ b/src/Cashflow.hs @@ -31,50 +31,46 @@ module Cashflow (CashFlowFrame(..),Principals,Interests,Amount ,emptyCashflow,isEmptyRow2,appendMCashFlow,getIntFlow ) where -import Data.Time (Day) -import Data.Fixed -import Lib (weightedBy,toDate,getIntervalFactors,daysBetween,paySeqLiabilitiesAmt) -import Util (mulBR,mulBInt,mulIR,lastOf) +import Data.Time () +import Data.Fixed () +import Lib (weightedBy, getIntervalFactors, daysBetween, paySeqLiabilitiesAmt) +import Util (mulBR, lastOf) import DateUtil ( splitByDate ,yearCountFraction ) import Types import qualified Data.Map as Map +import qualified Data.DList as DL import qualified Data.Time as T import qualified Data.List as L import Data.Maybe import Data.List.NonEmpty (NonEmpty(..), nonEmpty) -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Data.Aeson +import Language.Haskell.TH () import GHC.Generics import Data.Aeson.TH -import Data.Aeson.Types -import Text.Printf +import Data.Aeson.Types () +import Text.Printf () -import Debug.Trace -import qualified Control.Lens as Map -import Control.Applicative (liftA2) -import Data.OpenApi (HasPatch(patch), HasXml (xml)) +import qualified Control.Lens as Map () +import Control.Applicative () +import Data.OpenApi () import Control.DeepSeq (NFData,rnf) -import Data.Text.Internal.Encoding.Fusion (streamUtf16BE) +import Data.Text.Internal.Encoding.Fusion () import qualified Text.Tabular as TT import qualified Text.Tabular.AsciiArt as A import Control.Lens hiding (element) -import Control.Lens.TH -import Control.Monad -debug = flip trace +import Control.Lens.TH () +import Control.Monad () type Delinquent = Balance -type Amounts = [Float] type Principals = [Principal] type Interests = [Interest] -type Prepayments = [Prepayment] -type Recoveries = [Recovery] -type Rates = [Rate] type CumulativeStat = (CumPrincipal,CumPrepay,CumDelinq,CumDefault,CumRecovery,CumLoss) type AssetCashflow = CashFlowFrame type PoolCashflow = (AssetCashflow, Maybe [AssetCashflow]) +emptyCashflow :: CashFlowFrame emptyCashflow = CashFlowFrame (0,epocDate,Nothing) [] @@ -97,9 +93,6 @@ sumStats :: Maybe CumulativeStat -> Maybe CumulativeStat -> Maybe CumulativeStat -- sumStats (a1,b1,c1,d1,e1,f1) (a2,b2,c3,d2,e2,f2) = (a1+a2,b1+b2,c1+c3,d1+d2,e1+e2,f1+f2) sumStats s1 s2 = opStats (+) s1 s2 -subStats :: Maybe CumulativeStat -> Maybe CumulativeStat -> Maybe CumulativeStat --- subStats (a1,b1,c1,d1,e1,f1) (a2,b2,c3,d2,e2,f2) = (a1-a2,b1-b2,c1-c3,d1-d2,e1-e2,f1-f2) -subStats s1 s2 = opStats (-) s1 s2 maxStats :: Maybe CumulativeStat -> Maybe CumulativeStat -> Maybe CumulativeStat -- maxStats (a1,b1,c1,d1,e1,f1) (a2,b2,c3,d2,e2,f2) = (max a1 a2,max b1 b2,max c1 c3,max d1 d2,max e1 e2,max f1 f2) @@ -592,21 +585,20 @@ combine cf1@(CashFlowFrame st1@(begBal1,begDate1,acc1) txn1) cf2@(CashFlowFrame CashFlowFrame (begBal1,begDate1,acc1) txns buildCollectedCF :: [[TsRow]] -> [Date] -> [TsRow] -> [[TsRow]] -buildCollectedCF [] [] [] = [] -buildCollectedCF trs [] _trs = trs -buildCollectedCF trs ds [] = - case Util.lastOf trs (not . null) of - Just lastTr -> trs ++ [ [viewTsRow _d (last lastTr)] | _d <- ds ] - Nothing -> trs ++ replicate (length ds) [] -buildCollectedCF trs (d:ds) _trs = - case newFlow of - [] -> case Util.lastOf trs (not . null) of - Nothing -> buildCollectedCF (trs++[[]]) ds _trs -- `debug` ("empty trs"++ show d) - Just lastTr -> buildCollectedCF (trs++[[viewTsRow d (last lastTr)]]) ds _trs -- `debug` ("non empty last tr "++ show lastTr ++ "for date"++ show d++"insert with "++show (viewTsRow d (last lastTr))) - newFlow -> buildCollectedCF (trs++[newFlow]) ds remains - where - (newFlow, remains) = splitBy d Inc _trs - +buildCollectedCF trs ds rows = + DL.toList (go (DL.fromList trs) (Util.lastOf trs (not . null)) ds rows) + where + go acc _ [] _ = acc + go acc mLast (d:ds) rows = + case newFlow of + [] -> case mLast of + Nothing -> go (DL.snoc acc []) Nothing ds rows + Just lastTr -> + let g = [viewTsRow d (last lastTr)] + in go (DL.snoc acc g) (Just g) ds rows + newFlow -> go (DL.snoc acc newFlow) (Just newFlow) ds remains + where + (newFlow, remains) = splitBy d Inc rows aggTsByDates :: [TsRow] -> [Date] -> [TsRow] aggTsByDates [] ds = [] @@ -981,7 +973,6 @@ lookupSource tr NewDefaults = mflowDefault tr lookupSource tr NewLosses = mflowLoss tr lookupSource tr CurBalance = view tsRowBalance tr lookupSource tr CurBegBalance = mflowBegBalance tr -lookupSource tr x = error ("Failed to lookup source"++ show x) lookupSourceM :: Balance -> Maybe TsRow -> PoolSource -> Balance lookupSourceM bal Nothing CurBegBalance = bal @@ -1033,14 +1024,6 @@ currentCumulativeStat trs = fromMaybe (0,0,0,0,0,0) $ view txnCumulativeStats tr -cashFlowInitCumulativeStats :: Lens' CashFlowFrame (Maybe CumulativeStat) -cashFlowInitCumulativeStats = lens getter setter - where - getter (CashFlowFrame _ []) = Nothing - getter (CashFlowFrame _ (tr:trs)) = view txnCumulativeStats tr - - setter (CashFlowFrame st []) mStat = CashFlowFrame st [] - setter (CashFlowFrame st (tr:trs)) mStat = CashFlowFrame st $ (set txnCumulativeStats mStat tr):trs patchCumulativeAtInit :: Maybe CumulativeStat -> [TsRow] -> [TsRow] diff --git a/src/CreditEnhancement.hs b/src/CreditEnhancement.hs index c3d5f4ef..54535416 100644 --- a/src/CreditEnhancement.hs +++ b/src/CreditEnhancement.hs @@ -11,17 +11,17 @@ module CreditEnhancement ) where -import qualified Data.Text as T -import qualified Data.Time as Time -import qualified Data.Map as Map +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 Interface -import Language.Haskell.TH -import Data.Aeson hiding (json) +import Language.Haskell.TH () +import Data.Aeson import Data.Aeson.TH -import Data.Aeson.Types -import Data.Fixed +import Data.Aeson.Types () +import Data.Fixed () import Data.Maybe import Types import Util @@ -31,10 +31,8 @@ import qualified InterestRate as IR import qualified Stmt as S -import Debug.Trace -import Lib (paySeqLiabilities) -import Data.Decimal -debug = flip trace +import Lib () +import Data.Decimal () type LiquidityProviderName = String @@ -144,10 +142,11 @@ buildLiqRateResetAction (liq:liqProviders) ed r = liqProviders ed [(ln,IR.getRateResetDates sd ed rt ++ IR.getRateResetDates sd ed prt)]++r - _ -> buildLiqRateResetAction liqProviders ed r instance Drawable LiqFacility where + -- ^ available to support: the facility's own credit (ByAvailAmount balance / Unlimit) + availForDraw _ liq@LiqFacility{liqCredit = c} = c draw d amt txn liq@LiqFacility{ liqBalance = liqBal ,liqStmt = mStmt ,liqCredit = mCredit ,liqDueInt = dueInt ,liqDuePremium = duePremium} @@ -269,6 +268,20 @@ instance Liable LiqFacility where getOriginBalance LiqFacility{liqBalance = bal} = 0 + -- ^ the facility's current accrual interest rate on the outstanding balance + getCurRate LiqFacility{liqRate = r} = fromMaybe 0 r + + getOriginDate LiqFacility{liqStart = d} = d + + getAccrueBegDate liq@LiqFacility{liqDueIntDate = lastCalcDate} + = fromMaybe (liqStart liq) lastCalcDate + + -- ^ the liquidity facility has no interest-over-interest + getDueIntOverInt _ = 0 + + -- ^ total due = interest due + usage premium due + getTotalDueInt LiqFacility{liqDueInt = dueInt,liqDuePremium = duePremium} = dueInt + duePremium + instance IR.UseRate LiqFacility where getIndexes liq@LiqFacility{liqRateType = mRt,liqPremiumRateType = mPrt} = case (mRt,mPrt) of @@ -284,7 +297,19 @@ instance IR.UseRate LiqFacility where (_, Just (IR.Floater {})) -> True _ -> False - getIndex liq = head <$> IR.getIndexes liq + getIndex liq = case IR.getIndexes liq of + Just (idx:_) -> Just idx + _ -> Nothing + + -- ^ reset dates of both rate types over the facility's life + -- (same derivation as the deal-run `buildLiqRateResetAction`) + getResetDates liq@LiqFacility{liqRateType = mRt,liqPremiumRateType = mPrt,liqStart = sd,liqEnds = mEd} + = case mEd of + Nothing -> [] + Just ed -> IR.getRateResetDates sd ed mRt ++ IR.getRateResetDates sd ed mPrt + + -- ^ spread of the (interest) rate type + getSpread LiqFacility{liqRateType = mRt} = maybe Nothing IR._getSpread mRt data CreditDefaultSwap = CDS { cdsName :: String @@ -316,6 +341,22 @@ instance IR.UseRate CreditDefaultSwap where (IR.Floater _ idx _ _ _ _ _ _) -> Just [idx] (IR.Fix _ _) -> Nothing + getIndex cds = case IR.getIndexes cds of + Just (idx:_) -> Just idx + _ -> Nothing + + isAdjustableRate cds@CDS{cdsRateType = rt} + = case rt of + (IR.Floater {}) -> True + (IR.Fix {}) -> False + + getResetDates cds@CDS{cdsRateType = rt,cdsStart = sd,cdsEnds = mEd} + = case mEd of + Nothing -> [] + Just ed -> IR.getRateResetDates sd ed (Just rt) + + getSpread cds@CDS{cdsRateType = rt} = IR._getSpread rt + $(deriveJSON defaultOptions ''LiqRepayType) $(deriveJSON defaultOptions ''LiqDrawType) diff --git a/src/DateUtil.hs b/src/DateUtil.hs index 1fa4fce1..cf806bf1 100644 --- a/src/DateUtil.hs +++ b/src/DateUtil.hs @@ -11,19 +11,17 @@ module DateUtil( import qualified Data.Time as T import Data.List -import Data.Maybe -import qualified Data.Map as M +import Data.Maybe () +import qualified Data.Map as M () import qualified Data.Set as S import Data.Ratio ((%)) -import Debug.Trace -import Data.Time (addDays) +import Data.Time () import Types import Data.Ix import Lib -import Control.Exception +import Control.Exception () -debug = flip trace -- http://www.deltaquants.com/day-count-conventions -- https://www.iso20022.org/15022/uhb/mt565-16-field-22f.htm diff --git a/src/Deal.hs b/src/Deal.hs index 781fb9f6..72a28ffb 100644 --- a/src/Deal.hs +++ b/src/Deal.hs @@ -18,32 +18,32 @@ module Deal (run,getInits,runDeal,ExpectReturn(..) ,changeDealStatus ) where -import Control.Parallel.Strategies +import Control.Parallel.Strategies () import qualified Accounts as A -import qualified Ledger as LD +import qualified Ledger as LD () import qualified Asset as Ast import qualified Pool as P import qualified Expense as F import qualified Liability as L import qualified CreditEnhancement as CE import qualified Analytics -import qualified Waterfall as W +import qualified Waterfall as W () import qualified Cashflow as CF import qualified Assumptions as AP -import qualified Reports as Rpt -import qualified AssetClass.AssetBase as ACM -import AssetClass.Mortgage -import AssetClass.Lease -import AssetClass.Loan -import AssetClass.Installment +import qualified Reports as Rpt () +import qualified AssetClass.AssetBase as ACM () +import AssetClass.Mortgage () +import AssetClass.Lease () +import AssetClass.Loan () +import AssetClass.Installment () import AssetClass.MixedAsset -import qualified Call as C -import qualified InterestRate as IR +import qualified Call as C () +import qualified InterestRate as IR () import Deal.DealBase import Deal.DealQuery import Deal.DealAction -import Deal.DealCollection +import Deal.DealCollection () import Deal.DealRun import qualified Deal.DealValidation as V import Stmt @@ -51,60 +51,44 @@ import Lib import Util import DateUtil import Types -import Revolving -import Triggers +import Revolving () +import Triggers () import qualified Data.Map as Map hiding (mapEither) -import qualified Data.Time as T +import qualified Data.Time as T () import qualified Data.Set as S -import qualified Control.Lens as LS +import qualified Control.Lens as LS () import Data.List import qualified Data.DList as DL -import Data.Fixed -import Data.Time.Clock +import Data.Fixed () +import Data.Time.Clock () import Data.Maybe -import Data.Either -import Data.Bifunctor (bimap) -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Data.Either () +import Data.Bifunctor () +import Data.Aeson +import Language.Haskell.TH () import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () import GHC.Generics -import Control.Monad -import Control.Monad.Writer -import Control.Monad.Loops (allM,anyM) -import Control.Applicative (liftA2) - -import Debug.Trace -import Cashflow (buildBegTsRow) -import Assumptions (NonPerfAssumption(NonPerfAssumption),lookupRate0) +import Control.Monad () +import Control.Monad.Writer () +import Control.Monad.Loops () +import Control.Applicative () + +import Cashflow () +import Assumptions () import Asset () -import Pool (issuanceStat) -import qualified Types as P +import Pool () +import qualified Types as P () import Control.Lens hiding (element) -import Control.Lens.TH -import Data.Either.Utils +import Control.Lens.TH () +import Data.Either.Utils () import InterestRate (calcInt) -import Liability (getDayCountFromInfo,getTxnRate) -import Hedge (RateCap(..),RateSwapBase(..),RateSwap(rsRefBalance)) +import Liability (getTxnRate) +import Hedge () import qualified Hedge as HE -debug = flip trace - - -updateSrtRate :: Ast.Asset a => TestDeal a -> Date -> [RateAssumption] -> HE.SRT -> Either String HE.SRT -updateSrtRate t d ras srt@HE.SRT{HE.srtPremiumType = rt} - = do - r <- AP.applyFloatRate2 rt d ras - return srt { HE.srtPremiumRate = r } - - -queryTrigger :: Ast.Asset a => TestDeal a -> DealCycle -> [Trigger] -queryTrigger t@TestDeal{ triggers = trgs } wt - = case trgs of - Nothing -> [] - Just _trgs -> maybe [] Map.elems $ Map.lookup wt _trgs -- ^ test triggers in the deal and add a log if deal status changed changeDealStatus:: Ast.Asset a => (Date,String)-> DealStatus -> TestDeal a -> (Maybe ResultComponent, TestDeal a) @@ -448,8 +432,8 @@ getInits er t@TestDeal{accounts = accMap, fees=feeMap,pool=thePool,status=status let financialRptDates = case mNonPerfAssump of Just AP.NonPerfAssumption{AP.buildFinancialReport= Just dp } -> case genSerialDatesTill2 II startDate dp endDate of - (s:_ds) -> [ BuildReport _sd _ed | (_sd,_ed) <- zip (s:_ds) _ds ] - [] -> [] + (s:_ds) -> [ BuildReport _sd _ed | (_sd,_ed) <- zip (s:_ds) _ds ] + [] -> [] _ -> [] let irUpdateSwapDates = case rateSwap t of diff --git a/src/Deal/DealAction.hs b/src/Deal/DealAction.hs index 2be13e8c..81b45ca2 100644 --- a/src/Deal/DealAction.hs +++ b/src/Deal/DealAction.hs @@ -20,14 +20,14 @@ import qualified Cashflow as CF import qualified Assumptions as AP import qualified AssetClass.AssetBase as ACM import AssetClass.Mortgage -import AssetClass.Lease -import AssetClass.Loan -import AssetClass.Installment +import AssetClass.Lease () +import AssetClass.Loan () +import AssetClass.Installment () import AssetClass.MixedAsset -import qualified Call as C +import qualified Call as C () import qualified InterestRate as IR -import qualified Analytics as AN +import qualified Analytics as AN () import Deal.DealBase import Deal.DealQuery @@ -45,28 +45,27 @@ import Interface import qualified Data.Map as Map import qualified Data.Time as T import qualified Data.Set as S -import qualified Control.Lens as LS +import qualified Control.Lens as LS () import Data.List import qualified Data.DList as DL -import Data.Fixed -import Data.Time.Clock +import Data.Fixed () +import Data.Time.Clock () import Data.Maybe -import Data.Either -import Data.Either.Utils -import Data.Aeson hiding (json) -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types -import GHC.Generics -import Control.Applicative -import Debug.Trace -import Cashflow (CashFlowFrame(CashFlowFrame)) +import Data.Either () +import Data.Either.Utils () +import Data.Bifunctor (first) +import Data.Aeson () +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () +import GHC.Generics () +import Control.Applicative () +import Cashflow () import Control.Lens hiding (element) -import Control.Lens.TH +import Control.Lens.TH () import Control.Lens.Extras (is) import Control.Monad -debug = flip trace -- ^ Test triggers testTrigger :: Ast.Asset a => TestDeal a -> RunContext -> Date -> Trigger -> Either ErrorRep Trigger @@ -136,11 +135,10 @@ calcDueFee t rc calcDay f@(F.Fee fn (F.PctFee ds _r ) fs fd fdDay fa lpd _) -- ^ time series based fee, can be accrued multiple times calcDueFee t rc calcDay f@(F.Fee fn (F.FeeFlow ts) fs fd _ fa mflpd _) - = let - (currentNewDue,futureDue) = splitTsByDate ts calcDay - cumulativeDue = sumValTs currentNewDue - newFeeDue = cumulativeDue + fd - in + = do + (currentNewDue,futureDue) <- first (("Fee " ++ fn ++ " FeeFlow: ") ++) (trySplitTsByDate ts calcDay) + cumulativeDue <- first (("Fee " ++ fn ++ " FeeFlow: ") ++) (trySumValTs currentNewDue) + let newFeeDue = cumulativeDue + fd return f{ F.feeDue = newFeeDue ,F.feeDueDate = Just calcDay ,F.feeType = F.FeeFlow futureDue} -- ^ fee based on a recurring date pattern, exempt by reAccruableFeeType check @@ -286,7 +284,9 @@ calcDueInt t rc d b@(L.Bond bn bt bo (L.WithIoI intInfo ioiIntInfo) _ bond_bal b in do newBondWithIntInfo <- calcDueInt t rc d newBond - return newBondWithIntInfo { L.bndInterestInfo = L.WithIoI intInfo ioiIntInfo} + case newBondWithIntInfo of + b'@(L.Bond {}) -> return b' { L.bndInterestInfo = L.WithIoI intInfo ioiIntInfo} + _ -> Left "calcDueInt: WithIoI bond accrued to an unexpected constructor" -- TODO: to enable override rate & balance -- accure interest by rate @@ -530,9 +530,6 @@ showInspection (InspectBal d ds r) = show r showInspection x = error $ "not implemented for showing ResultComponent " ++ show x -calcAvailFund :: Ast.Asset a => TestDeal a -> RunContext -> Date -> A.Account -> Maybe W.ExtraSupport -> Either ErrorRep SupportAvailType -calcAvailFund t rc d acc Nothing = return $ ByAvailAmount $ A.accBalance acc -calcAvailFund t rc d acc (Just support) = (\x -> sumSupport ((ByAvailAmount (A.accBalance acc)):[x]) ) <$> evalExtraSupportBalance d t rc support -- ^ Deal, Date , cap balance, due balance applyLimit :: Ast.Asset a => TestDeal a -> RunContext -> Date -> Balance -> Balance -> Maybe Limit -> Either ErrorRep Balance @@ -675,7 +672,7 @@ performActionWrap d mergedCf = CF.mergePoolCf2 cfOrigin cfBought in ((over CF.cashflowTxn (`CF.aggTsByDates` (dsInterval ++ newAggDates)) mergedCf), (++ [cfBought]) <$> mAflow) - ) + ) pIdToChange pFlowMap @@ -683,23 +680,6 @@ performActionWrap d ,revolvingAssump = Just (Map.insert revolvingPoolName (poolAfterBought, perfAssumps) rMap)} return (t { accounts = newAccMap , pool = newPt}, newRc, logs) -performActionWrap d - (t - ,rc@RunContext{runPoolFlow=pcf - ,revolvingAssump=Nothing - ,revolvingInterestRateAssump=mRates} - ,logs) - (W.BuyAsset ml pricingMethod accName _) - = Left $ "Date:"++ show d ++"Missing revolving Assumption(asset assumption & asset to buy)" ++ name t - -performActionWrap d - (t - ,rc@RunContext{runPoolFlow=pcf - ,revolvingAssump=Nothing - ,revolvingInterestRateAssump=mRates} - ,logs) - (W.BuyAssetFrom {}) - = Left $ "Date:"++ show d ++"Missing revolving Assumption(asset assumption & asset to buy)" ++ name t -- TODO need to set a limit to sell performActionWrap d (t@TestDeal{accounts = accMap, pool = pt} @@ -786,6 +766,19 @@ performActionWrap d (t, rc, logs) a dealAfterExe <- performAction d t rc a return (dealAfterExe, rc, logs) +-- | Reject a 'BondGroup' where a single bond is required. Group-level +-- principal is handled by the group-specific waterfall actions. +requireSingleBond :: L.Bond -> Either ErrorRep L.Bond +requireSingleBond b@(L.Bond {}) = Right b +requireSingleBond b@(L.MultiIntBond {}) = Right b +requireSingleBond (L.BondGroup {}) = Left "Bond group is not supported by this action; use the group-specific waterfall action" + +-- | Set the due principal on a single bond, rejecting bond groups. +setBondDuePrin :: Balance -> L.Bond -> Either ErrorRep L.Bond +setBondDuePrin amt b@(L.Bond {}) = Right b { L.bndDuePrin = amt } +setBondDuePrin amt b@(L.MultiIntBond {}) = Right b { L.bndDuePrin = amt } +setBondDuePrin _ (L.BondGroup {}) = Left "Cannot set due principal on a bond group" + performAction :: Ast.Asset a => Date -> TestDeal a -> RunContext -> W.Action -> Either ErrorRep (TestDeal a) performAction d t@TestDeal{accounts=accMap, ledgers = Nothing} _ (W.TransferAndBook _ _ _ _ _) = Left $ "Date:"++ show d ++" Missing ledger map to book " ++ name t @@ -1163,20 +1156,22 @@ performAction d t@TestDeal{bonds=bndMap,accounts=accMap} rc (W.PayPrin mLimit an -- ^ pay principal without any limit performAction d t@TestDeal{accounts=accMap, bonds=bndMap} rc (W.PayPrinResidual an bnds) = - let - bndsToPay = [ b { L.bndDuePrin = L.bndBalance b} | b <- getActiveBonds t bnds ] - bndsToPayNames = L.bndName <$> bndsToPay - bndsDueAmts = map L.getCurBalance bndsToPay - in - do - acc <- lookupM an accMap - let availBal = A.accBalance acc - let actualPaidOut = min availBal $ sum bndsDueAmts -- `debug` ("bonds totoal due ->"++show(bndsDueAmts)) - let bndsAmountToBePaid = zip bndsToPay (prorataFactors bndsDueAmts actualPaidOut) - bndsPaid <- sequenceA $ map (\(l,amt) -> pay d DuePrincipal amt l) bndsAmountToBePaid - let bndMapUpdated = (Map.fromList $ zip bndsToPayNames bndsPaid) <> bndMap - accMapAfterPay <- adjustM (A.draw d actualPaidOut (PayPrin bnds)) an accMap - return $ t {accounts = accMapAfterPay, bonds = bndMapUpdated} -- `debug` ("Bond Prin Pay Result"++show(bndMapUpdated)) + do + bndsToPay <- traverse duePrinToCurBal (getActiveBonds t bnds) + acc <- lookupM an accMap + let bndsToPayNames = L.bndName <$> bndsToPay + let bndsDueAmts = map L.getCurBalance bndsToPay + let availBal = A.accBalance acc + let actualPaidOut = min availBal $ sum bndsDueAmts -- `debug` ("bonds totoal due ->"++show(bndsDueAmts)) + let bndsAmountToBePaid = zip bndsToPay (prorataFactors bndsDueAmts actualPaidOut) + bndsPaid <- sequenceA $ map (\(l,amt) -> pay d DuePrincipal amt l) bndsAmountToBePaid + let bndMapUpdated = (Map.fromList $ zip bndsToPayNames bndsPaid) <> bndMap + accMapAfterPay <- adjustM (A.draw d actualPaidOut (PayPrin bnds)) an accMap + return $ t {accounts = accMapAfterPay, bonds = bndMapUpdated} -- `debug` ("Bond Prin Pay Result"++show(bndMapUpdated)) + where + duePrinToCurBal b = do + b' <- requireSingleBond b + setBondDuePrin (L.bndBalance b') b' performAction d t@TestDeal{accounts=accMap, bonds=bndMap} rc (W.FundWith mlimit an bnd) = do @@ -1256,31 +1251,37 @@ performAction d t@TestDeal{bonds=bndMap} rc (W.CalcBondInt bns) -- ^ set due prin mannually performAction d t@TestDeal{bonds=bndMap} rc (W.CalcBondPrin2 mLimit bnds) = do - bndsToPay <- lookupVs bnds bndMap + bndsToPay <- traverse requireSingleBond =<< lookupVs bnds bndMap let bndsToPayNames = L.bndName <$> bndsToPay bndsDueAmts <- traverse (L.bndDuePrin <$>) $ (calcDuePrin t rc d) <$> bndsToPay let totalDue = sum bndsDueAmts bookCap <- applyLimit t rc d totalDue totalDue mLimit let bndsAmountToBook = zip bndsToPayNames $ prorataFactors bndsDueAmts bookCap - let newBndMap = foldr - (\(bn,amt) acc -> Map.adjust (\b -> b {L.bndDuePrin = amt}) bn acc) - bndMap - bndsAmountToBook -- `debug` ("Calc Bond Prin"++ show bndsAmountToBePaid) + newBndMap <- foldM + (\acc (bn,amt) -> do + b <- lookupM bn acc + b' <- setBondDuePrin amt b + return (Map.insert bn b' acc)) + bndMap + bndsAmountToBook -- `debug` ("Calc Bond Prin"++ show bndsAmountToBePaid) return $ t {bonds = newBndMap} performAction d t@TestDeal{bonds=bndMap, accounts = accMap} rc (W.CalcBondPrin mLimit accName bnds mSupport) = do - bndsToPay <- lookupVs bnds bndMap + bndsToPay <- traverse requireSingleBond =<< lookupVs bnds bndMap let bndsToPayNames = L.bndName <$> bndsToPay acc <- lookupM accName accMap let accBal = A.accBalance acc bndsDueAmts <- traverse (L.bndDuePrin <$>) $ (calcDuePrin t rc d) <$> bndsToPay (payAmount,_,_) <- calcAvailAfterLimit t rc d acc mSupport (sum bndsDueAmts) mLimit let bndsAmountToBePaid = zip bndsToPayNames $ prorataFactors bndsDueAmts payAmount - let newBndMap = foldr - (\(bn,amt) acc -> Map.adjust (\b -> b {L.bndDuePrin = amt}) bn acc) - bndMap - bndsAmountToBePaid + newBndMap <- foldM + (\acc (bn,amt) -> do + b <- lookupM bn acc + b' <- setBondDuePrin amt b + return (Map.insert bn b' acc)) + bndMap + bndsAmountToBePaid return $ t {bonds = newBndMap} @@ -1301,7 +1302,7 @@ performAction d t@TestDeal{accounts=accs, liqProvider = Just _liqProvider} rc (W (ByAvailAmount av, Just (DS ds)) -> (min (toRational av)) <$> queryCompound t rc d (patchDateToStats d ds) (_ , Just _x) -> Left $ "Date:"++show d ++"Not support limit in LiqSupport(Account)"++ show _x let dAmt = fromRational transferAmt - newLiqMap <- adjustM (draw d dAmt LiquidationDraw) pName _liqProvider + newLiqMap <- adjustM (draw d dAmt LiquidationDraw) pName _liqProvider return t { accounts = Map.adjust (A.deposit dAmt d (LiquidationSupport pName)) an accs , liqProvider = Just newLiqMap } | otherwise = Left $ "Date:"++show d ++"There should only one account for LiqToAcc of LiqSupport" diff --git a/src/Deal/DealBase.hs b/src/Deal/DealBase.hs index 8e3470a1..6955f69b 100644 --- a/src/Deal/DealBase.hs +++ b/src/Deal/DealBase.hs @@ -29,9 +29,9 @@ import qualified Hedge as HE import qualified Waterfall as W import qualified Cashflow as CF import qualified Assumptions as AP -import qualified AssetClass.AssetBase as ACM -import qualified Call as C -import qualified InterestRate as IR +import qualified AssetClass.AssetBase as ACM () +import qualified Call as C () +import qualified InterestRate as IR () import Interface import Stmt import Lib @@ -44,30 +44,28 @@ import Triggers import Deal.DealCollection (CollectionRule(..)) import qualified Data.Map as Map -import qualified Data.Time as T +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.Fixed () import Data.Maybe -import Data.Ratio -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Data.Ratio () +import Data.Aeson +import Language.Haskell.TH () import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () import GHC.Generics import Control.Lens hiding (element) -import Control.Lens.TH +import Control.Lens.TH () import Control.Monad (foldM) -import Data.IntMap (filterWithKey) -import qualified Data.Text as T -import Text.Read (readMaybe) +import Data.IntMap () +import qualified Data.Text as T () +import Text.Read () import qualified Pool as P -import qualified Types as CF +import qualified Types as CF () -import Debug.Trace -import qualified Control.Lens as P -debug = flip trace +import qualified Control.Lens as P () data DealComp = CompBond @@ -82,9 +80,6 @@ data DealComp = CompBond | CompLiqProvider deriving (Show,Eq,Ord,Generic,Read) -data ActionTypeOnDate = DoSettle - | DoAccrue - | DoUpdateRate data ActionOnDate = EarnAccInt Date AccName -- ^ sweep bank account interest | ChangeDealStatusTo Date DealStatus -- ^ change deal status @@ -601,11 +596,6 @@ poolTypePool = lens getter setter getter = \case MultiPool pm -> pm setter (MultiPool pm) newPm = MultiPool newPm -poolTypeUnderDeal :: Ast.Asset a => Lens' (PoolType a) (Map.Map PoolId (UnderlyingDeal a)) -poolTypeUnderDeal = lens getter setter - where - getter = \case ResecDeal dm -> dm - setter (ResecDeal dm) newDm = ResecDeal newDm getPoolIds :: Ast.Asset a => TestDeal a -> [PoolId] getPoolIds t@TestDeal{pool = pt} @@ -711,7 +701,6 @@ bondTraversal :: Traversal' (TestDeal a) L.Bond bondTraversal f t@TestDeal{bonds = bndMap} = (\newBndMap -> t {bonds = newBndMap}) <$> traverse f bndMap -data UnderBond b = UnderBond BondName Rate (TestDeal b) opts :: JSONKeyOptions opts = defaultJSONKeyOptions diff --git a/src/Deal/DealCollection.hs b/src/Deal/DealCollection.hs index 0e7733a9..ec686789 100644 --- a/src/Deal/DealCollection.hs +++ b/src/Deal/DealCollection.hs @@ -12,18 +12,18 @@ module Deal.DealCollection import GHC.Generics import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () import qualified Accounts as A -import qualified Waterfall as W +import qualified Waterfall as W () import qualified Cashflow as CF import qualified Data.Map as Map hiding (mapEither) -import Data.List +import Data.List () import Control.Monad import Types import Util -import Lib +import Lib () import Control.Lens hiding (element) data CollectionRule diff --git a/src/Deal/DealDate.hs b/src/Deal/DealDate.hs index ccb0718a..94fddada 100644 --- a/src/Deal/DealDate.hs +++ b/src/Deal/DealDate.hs @@ -9,7 +9,7 @@ module Deal.DealDate (DealDates,getClosingDate,getFirstPayDate,getLastPayDate,ge import qualified Data.Map as Map import Deal.DealBase import Types -import Lib +import Lib () class DealDates a where getClosingDate :: a -> Either String Date diff --git a/src/Deal/DealMod.hs b/src/Deal/DealMod.hs index 83d876bf..0bd9c07f 100644 --- a/src/Deal/DealMod.hs +++ b/src/Deal/DealMod.hs @@ -11,59 +11,57 @@ module Deal.DealMod (modDeal, ModifyType(..), AdjStrategy(..) where import Data.Aeson -import Data.Aeson.Types +import Data.Aeson.Types () import Data.Aeson.TH -import Data.Aeson.Encode.Pretty (encodePretty) -import Servant.OpenApi +import Data.Aeson.Encode.Pretty () +import Servant.OpenApi () import Data.OpenApi hiding (Server,contentType,trace) -import qualified Accounts as A -import qualified Ledger as LD +import qualified Accounts as A () +import qualified Ledger as LD () import qualified Asset as Ast -import qualified Expense as F +import qualified Expense as F () import qualified Liability as L -import qualified CreditEnhancement as CE -import qualified Hedge as HE -import qualified Waterfall as W -import qualified Cashflow as CF -import qualified Assumptions as AP -import qualified AssetClass.AssetBase as ACM -import qualified Call as C -import qualified InterestRate as IR +import qualified CreditEnhancement as CE () +import qualified Hedge as HE () +import qualified Waterfall as W () +import qualified Cashflow as CF () +import qualified Assumptions as AP () +import qualified AssetClass.AssetBase as ACM () +import qualified Call as C () +import qualified InterestRate as IR () import qualified Util as U import qualified Deal.DealBase as DB -import Stmt -import Lib +import Stmt () +import Lib () import Util -import DateUtil +import DateUtil () import Types -import Revolving -import Triggers +import Revolving () +import Triggers () -import qualified Data.Map as Map -import qualified Data.Time as T -import qualified Data.Set as S -import Data.List -import Data.Fixed -import Data.Maybe -import Data.Ratio -import Data.Aeson hiding (json) +import qualified Data.Map as Map () +import qualified Data.Time as T () +import qualified Data.Set as S () +import Data.List () +import Data.Fixed () +import Data.Maybe () +import Data.Ratio () +import Data.Aeson () -- import qualified Data.Aeson.Encode.Pretty as Pretty -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () import GHC.Generics import Control.Lens hiding (element) -import Control.Lens.TH -import Data.IntMap (filterWithKey) -import qualified Data.Text as T -import Text.Read (readMaybe) -import qualified Pool as P -import qualified Types as CF +import Control.Lens.TH () +import Data.IntMap () +import qualified Data.Text as T () +import Text.Read () +import qualified Pool as P () +import qualified Types as CF () -import Debug.Trace -import qualified Control.Lens as P -debug = flip trace +import qualified Control.Lens as P () data AdjStrategy = ScaleBySpread @@ -98,8 +96,6 @@ modDeal (SlideBalances bn1 bn2) r d@DB.TestDeal {DB.bonds = bndMap} in d {DB.bonds = bndMap'} -modDeal x _ _ = error $ "modify deal: not implemented"++ show x - $(deriveJSON defaultOptions ''AdjStrategy) instance ToSchema AdjStrategy diff --git a/src/Deal/DealQuery.hs b/src/Deal/DealQuery.hs index 1a295b4c..6edc5b6f 100644 --- a/src/Deal/DealQuery.hs +++ b/src/Deal/DealQuery.hs @@ -12,17 +12,18 @@ module Deal.DealQuery (queryDealBool ,patchDateToStats,patchDatesToStats,testPre where import Deal.DealBase -import Deal.DealDate +import Deal.DealDate () import Types import qualified Asset as P import qualified AssetClass.AssetBase as AB import Data.List -import Data.Fixed +import Data.Fixed () import Data.Maybe -import Data.Text (replace, pack, unpack) -import Numeric.Limits +import Data.Bifunctor (first) +import Data.Text () +import Numeric.Limits () import Control.Monad.Loops -import GHC.Real +import GHC.Real () import qualified Data.Map as Map import qualified Data.Set as S import qualified Liability as L @@ -40,19 +41,17 @@ import qualified Pool as Pl import qualified InterestRate as IR import Stmt import Util -import Errors +import Errors () import Interface import DateUtil import Control.Lens hiding (element) import Control.Lens.Extras (is) -import Control.Lens.TH -import Control.Applicative -import Data.Map.Lens -import Data.List.Lens -import Debug.Trace +import Control.Lens.TH () +import Control.Applicative () +import Data.Map.Lens () +import Data.List.Lens () import Lib -import qualified Cashflow as P -debug = flip trace +import qualified Cashflow as P () -- | calcuate target balance for a reserve account, 0 for a non-reserve account calcTargetAmount :: P.Asset a => TestDeal a -> RunContext -> Date -> A.Account -> Either ErrorRep Balance @@ -84,13 +83,13 @@ calcBondTargetBalance t rc d (L.BondGroup bMap mPt) = vs <- traverse (calcBondTargetBalance t rc d) $ Map.elems bMap return $ sum vs - Just (L.PAC _target) -> return $ getValOnByDate _target d + Just (L.PAC _target) -> first ("Bond group PAC target: " ++) (tryGetValOnByDate _target d) Just (L.PacAnchor _target _bnds) | queryDealBool t rc (IsPaidOff _bnds) d == Right True -> do subBondTargets <- traverse (calcBondTargetBalance t rc d) $ Map.elems bMap return $ sum subBondTargets - | queryDealBool t rc (IsPaidOff _bnds) d == Right False -> return $ getValOnByDate _target d + | queryDealBool t rc (IsPaidOff _bnds) d == Right False -> first ("Bond group PacAnchor target: " ++) (tryGetValOnByDate _target d) | otherwise -> Left $ "Calculate paid off bonds failed"++ show _bnds ++" in calc target balance" Just (L.AmtByPeriod pc) -> case getValFromPerCurve pc Past Inc (fromMaybe 0 (getDealStatInt t BondPaidPeriod)) of Just v -> return v @@ -108,15 +107,14 @@ calcBondTargetBalance t rc d b = | otherwise -> return $ L.bndBalance b L.IO -> return 0 L.Equity -> return 0 - L.PAC _target -> Right $ getValOnByDate _target d + L.PAC _target -> first (("Bond " ++ L.bndName b ++ " PAC target: ") ++) (tryGetValOnByDate _target d) L.PacAnchor _target _bnds | queryDealBool t rc (IsPaidOff _bnds) d == Right True -> return 0 - | queryDealBool t rc (IsPaidOff _bnds) d == Right False -> return $ getValOnByDate _target d + | queryDealBool t rc (IsPaidOff _bnds) d == Right False -> first (("Bond " ++ L.bndName b ++ " PacAnchor target: ") ++) (tryGetValOnByDate _target d) | otherwise -> Left $ "Calculate paid off bonds failed"++ show _bnds ++" in calc target balance" L.AmtByPeriod pc -> case getValFromPerCurve pc Past Inc (fromMaybe 0 (getDealStatInt t BondPaidPeriod)) of Just v -> return v Nothing -> Left "Failed to find value in calcTargetBalance" - _ -> Left $ "Bond "++ L.bndName b ++" is not a bond with target balance setting" patchDateToStats :: Date -> DealStats -> DealStats @@ -200,16 +198,6 @@ poolSourceToIssuanceField NewDelinquencies = HistoryDelinquency poolSourceToIssuanceField a = error ("Failed to match pool source when mapping to issuance field"++show a) -eval :: (P.Asset a, Num b) => TestDeal a -> Date -> EvalExpr b -> Either ErrorRep b -eval t d exp = - let - eval' = eval t d - in - case exp of - (EvalSum xs) -> sum <$> traverse eval' xs - CurrentBondBalance' b -> return b - -- (EvalSubtract x:xs) -> (eval' x) - liftA sum $ sequenceA (eval' <$> xs) --- eval (EvalAvg xs) = (sum (eval <$> xs)) / (length xs) queryCompound :: P.Asset a => TestDeal a -> RunContext -> Date -> DealStats -> Either ErrorRep Rational queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=feeMap, pool=pt} @@ -799,7 +787,7 @@ queryCompound t@TestDeal{accounts=accMap, bonds=bndMap, ledgers=ledgersM, fees=f Just mCustom -> case Map.lookup s mCustom of Just (CustomConstant v) -> Right . toRational $ v - Just (CustomCurve cv) -> Right . toRational $ getValOnByDate cv d + Just (CustomCurve cv) -> first (("Custom curve " ++ show s ++ ": ") ++) (toRational <$> tryGetValOnByDate cv d) Just (CustomDS ds) -> queryCompound t rc d (patchDateToStats d ds ) _ -> Left $ "Date:"++show d++"Unsupported custom data found for key " ++ show s diff --git a/src/Deal/DealRun.hs b/src/Deal/DealRun.hs index 83781dd6..8dee1ce6 100644 --- a/src/Deal/DealRun.hs +++ b/src/Deal/DealRun.hs @@ -2,30 +2,30 @@ module Deal.DealRun ( run ) where -import qualified Data.Set as S +import qualified Data.Set as S () import qualified Data.DList as DL import Data.List import Control.Lens hiding (element) -import Control.Lens.TH +import Control.Lens.TH () import Control.Monad import Data.Maybe -import Data.Either +import Data.Either () import Data.Either.Utils -import Control.Monad.Loops (allM,anyM) +import Control.Monad.Loops (anyM) import qualified Asset as Ast import qualified Cashflow as CF import qualified Accounts as A import qualified Data.Map as Map hiding (mapEither) import qualified Waterfall as W -import qualified Expense as F +import qualified Expense as F () import qualified Liability as L import qualified Reports as Rpt import qualified Pool as P import qualified Assumptions as AP import qualified Hedge as HE import qualified CreditEnhancement as CE -import qualified InterestRate as IR +import qualified InterestRate as IR () import Triggers import Interface @@ -33,16 +33,14 @@ import Deal.DealBase import Deal.DealAction import Deal.DealQuery import Deal.DealCollection -import Revolving -import Hedge +import Revolving () +import Hedge () import Stmt import Types import Util -import Lib +import Lib () -import Debug.Trace -debug = flip trace -- ^ 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 @@ -90,20 +88,22 @@ runEffects (t@TestDeal{accounts = accMap, fees = feeMap ,status=st, bonds = bond setBondStepUpRate :: Date -> [RateAssumption] -> L.Bond -> Either ErrorRep L.Bond setBondStepUpRate d ras b@(L.Bond _ _ _ ii (Just sp) _ _ _ _ _ _ _ _ _) - = return $ - let - newII = L.stepUpInterestInfo sp ii - newRate = AP.applyFloatRate ii d ras - in - (L.accrueInt d b) { L.bndInterestInfo = newII, L.bndRate = newRate } + = let + newII = L.stepUpInterestInfo sp ii + newRate = AP.applyFloatRate ii d ras + in + case L.accrueInt d b of + b'@(L.Bond {}) -> return $ b' { L.bndInterestInfo = newII, L.bndRate = newRate } + _ -> Left "setBondStepUpRate: accrueInt changed the bond constructor" setBondStepUpRate d ras b@(L.MultiIntBond bn _ _ iis (Just sps) _ _ _ _ _ _ _ _ _) - = return $ - let - newIIs = zipWith L.stepUpInterestInfo sps iis - newRates = (\x -> AP.applyFloatRate x d ras) <$> newIIs - in - (L.accrueInt d b) { L.bndInterestInfos = newIIs, L.bndRates = newRates } -- `debug` (show d ++ ">> accure due to step up rate "++ bn) + = let + newIIs = zipWith L.stepUpInterestInfo sps iis + newRates = (\x -> AP.applyFloatRate x d ras) <$> newIIs + in + case L.accrueInt d b of + b'@(L.MultiIntBond {}) -> return $ b' { L.bndInterestInfos = newIIs, L.bndRates = newRates } -- `debug` (show d ++ ">> accure due to step up rate "++ bn) + _ -> Left "setBondStepUpRate: accrueInt changed the bond constructor" setBondStepUpRate d ras bg@(L.BondGroup bMap pt) = do @@ -117,7 +117,9 @@ setBondNewRate t rc d ras b@(L.Bond _ _ L.OriginalInfo{ L.originDate = od} ii _ -- ^ Floater rate setBondNewRate t rc d ras b@(L.Bond _ _ _ ii@(L.Floater br idx _spd rset dc mf mc) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) - = return $ (L.accrueInt d b){ L.bndRate = AP.applyFloatRate ii d ras } + = case L.accrueInt d b of + b'@(L.Bond {}) -> return $ b' { L.bndRate = AP.applyFloatRate ii d ras } + _ -> Left "setBondNewRate: accrueInt changed the bond constructor" -- ^ Fix rate, do nothing setBondNewRate t rc d ras b@(L.Bond _ _ _ L.Fix {} _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) @@ -126,13 +128,16 @@ setBondNewRate t rc d ras b@(L.Bond _ _ _ L.Fix {} _ bal currentRate _ dueInt _ -- ^ Ref rate setBondNewRate t rc d ras b@(L.Bond _ _ _ (L.RefRate sr ds factor _) _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) = do - let b' = L.accrueInt d b rate <- queryCompound t rc d (patchDateToStats d ds) - return b' {L.bndRate = fromRational (rate * toRational factor) } + case L.accrueInt d b of + b'@(L.Bond {}) -> return b' {L.bndRate = fromRational (rate * toRational factor) } + _ -> Left "setBondNewRate: accrueInt changed the bond constructor" -- ^ cap & floor & IoI setBondNewRate t rc d ras b@(L.Bond _ _ _ ii _ bal currentRate _ dueInt _ (Just dueIntDate) _ _ _) - = return $ (L.accrueInt d b) { L.bndRate = AP.applyFloatRate ii d ras} + = case L.accrueInt d b of + b'@(L.Bond {}) -> return $ b' { L.bndRate = AP.applyFloatRate ii d ras} + _ -> Left "setBondNewRate: accrueInt changed the bond constructor" -- ^ bond group setBondNewRate t rc d ras bg@(L.BondGroup bMap pt) @@ -144,9 +149,10 @@ setBondNewRate t rc d ras bg@(L.BondGroup bMap pt) setBondNewRate t rc d ras b@(L.MultiIntBond bn _ _ iis _ bal currentRates _ dueInts dueIoIs _ _ _ _) = let newRates = AP.applyFloatRate <$> iis <*> pure d <*> pure ras - b' = L.accrueInt d b -- `debug` ("accrue due to new rate "++ bn) in - return $ b' { L.bndRates = newRates } + case L.accrueInt d b of + b'@(L.MultiIntBond {}) -> return $ b' { L.bndRates = newRates } + _ -> Left "setBondNewRate: accrueInt changed the bond constructor" updateRateSwapBal :: Ast.Asset a => TestDeal a -> RunContext -> Date -> HE.RateSwap -> Either String HE.RateSwap updateRateSwapBal t rc d rs@HE.RateSwap{ HE.rsNotional = base } @@ -240,25 +246,25 @@ appendCollectedCF d t@TestDeal { pool = MultiPool poolM } poolInflowMap Nothing -> set P.poolFutureCf (Just (CF.CashFlowFrame st txnCollected , Nothing)) _v Just _ -> over (P.poolFutureCf . _Just . _1 . CF.cashflowTxn) (++ txnToAppend) _v ) - k - acc - -- insert breakdown asset flow - accUpdated' = case mAssetFlow of - Nothing -> accUpdated - Just collectedAssetFlow -> - let - appendFn Nothing = Just collectedAssetFlow - appendFn (Just cfs) - | length cfs == length collectedAssetFlow - = Just $ [ origin & over CF.cashflowTxn (++ (view CF.cashflowTxn new)) | (origin,new) <- zip cfs collectedAssetFlow ] - | length collectedAssetFlow > length cfs + k + acc + -- insert breakdown asset flow + accUpdated' = case mAssetFlow of + Nothing -> accUpdated + Just collectedAssetFlow -> + let + appendFn Nothing = Just collectedAssetFlow + appendFn (Just cfs) + | length cfs == length collectedAssetFlow + = Just $ [ origin & over CF.cashflowTxn (++ (view CF.cashflowTxn new)) | (origin,new) <- zip cfs collectedAssetFlow ] + | length collectedAssetFlow > length cfs = let dummyCashFrames = replicate (length collectedAssetFlow - length cfs) CF.emptyCashflow - in - Just $ [ origin & over (CF.cashflowTxn) (++ (view CF.cashflowTxn new)) | (origin,new) <- zip (cfs++dummyCashFrames) collectedAssetFlow ] - | otherwise = error "incomping cashflow number shall greater than existing cashflow number" - in - accUpdated & ix k %~ (over (P.poolFutureCf . _Just . _2) appendFn) + in + Just $ [ origin & over (CF.cashflowTxn) (++ (view CF.cashflowTxn new)) | (origin,new) <- zip (cfs++dummyCashFrames) collectedAssetFlow ] + | otherwise = error "incomping cashflow number shall greater than existing cashflow number" + in + accUpdated & ix k %~ (over (P.poolFutureCf . _Just . _2) appendFn) in Map.adjust (over P.poolIssuanceStat (Map.insert RuntimeCurrentPoolBalance balInCollected)) @@ -274,7 +280,7 @@ appendCollectedCF d t@TestDeal { pool = ResecDeal uds } poolInflowMap Map.foldrWithKey (\k (CF.CashFlowFrame _ newTxns, _) acc-> Map.adjust (over uDealFutureCf (`CF.appendMCashFlow` newTxns)) k acc) uds - poolInflowMap + poolInflowMap in t {pool = newPt} @@ -631,38 +637,44 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= flag <- testPre d t rc p case flag of False -> run t rc (Just ads) calls log - True -> let - newBndName = L.bndName bnd - in - do - newBalance <- case mBal of - Just _q -> queryCompound t rc d (patchDateToStats d _q) - Nothing -> Right . toRational $ L.originBalance (L.bndOriginInfo bnd) - newRate <- case mRate of - Just _q -> queryCompound t rc d (patchDateToStats d _q) - Nothing -> return $ L.originRate (L.bndOriginInfo bnd) - let newBonds = case Map.lookup bGroupName bndMap of - Nothing -> bndMap - Just L.Bond {} -> bndMap - Just (L.BondGroup bndGrpMap pt) -> let - bndOInfo = (L.bndOriginInfo bnd) {L.originDate = d, L.originRate = newRate, L.originBalance = fromRational newBalance } - bndToInsert = bnd {L.bndOriginInfo = bndOInfo, - L.bndDueIntDate = Just d, - L.bndLastIntPay = Just d, - L.bndLastPrinPay = Just d, - L.bndRate = fromRational newRate, - L.bndBalance = fromRational newBalance} - in - Map.insert bGroupName - (L.BondGroup (Map.insert newBndName bndToInsert bndGrpMap) pt) - bndMap - - let issuanceProceeds = fromRational newBalance - let newAcc = Map.adjust - (A.deposit issuanceProceeds d (IssuanceProceeds newBndName)) - accName - accMap - run t{bonds = newBonds, accounts = newAcc} rc (Just ads) calls log + True -> case bnd of + L.BondGroup {} -> Left "IssueBond: cannot issue a bond group" + _ -> let + newBndName = L.bndName bnd + in + do + newBalance <- case mBal of + Just _q -> queryCompound t rc d (patchDateToStats d _q) + Nothing -> Right . toRational $ L.originBalance (L.bndOriginInfo bnd) + newRate <- case mRate of + Just _q -> queryCompound t rc d (patchDateToStats d _q) + Nothing -> return $ L.originRate (L.bndOriginInfo bnd) + newBonds <- case Map.lookup bGroupName bndMap of + Nothing -> Right bndMap + Just L.Bond {} -> Right bndMap + Just (L.MultiIntBond {}) -> Right bndMap + Just (L.BondGroup bndGrpMap pt) -> + case bnd of + bnd'@(L.Bond {}) -> + let bndOInfo = (L.bndOriginInfo bnd') {L.originDate = d, L.originRate = newRate, L.originBalance = fromRational newBalance } + bndToInsert = bnd' {L.bndOriginInfo = bndOInfo, + L.bndDueIntDate = Just d, + L.bndLastIntPay = Just d, + L.bndLastPrinPay = Just d, + L.bndRate = fromRational newRate, + L.bndBalance = fromRational newBalance} + in + Right $ Map.insert bGroupName + (L.BondGroup (Map.insert newBndName bndToInsert bndGrpMap) pt) + bndMap + _ -> Left $ "IssueBond: only plain bonds can be issued into a bond group: " ++ newBndName + + let issuanceProceeds = fromRational newBalance + let newAcc = Map.adjust + (A.deposit issuanceProceeds d (IssuanceProceeds newBndName)) + accName + accMap + run t{bonds = newBonds, accounts = newAcc} rc (Just ads) calls log RefiBondRate d accName bName iInfo -> let lstDate = case ads of [] -> d; as -> getDate (last as) @@ -678,11 +690,14 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= acc <- lookupM accName accMap let actualPayout = min (A.accBalance acc) dueIntToPay bnd1 <- pay d (DueTotalOf [DueInterest Nothing, DueArrears]) actualPayout nBnd - let newBnd = set L.bndIntLens iInfo bnd1 - let resetDates = L.buildRateResetDates newBnd d lstDate - let bResetActions = [ ResetBondRate d' bName | d' <- resetDates ] + (newBndMap, bResetActions) <- case bnd1 of + b@(L.Bond {}) -> + let newBnd = set L.bndIntLens iInfo + (b {L.bndRate = newRate, L.bndDueIntDate = Just d ,L.bndLastIntPay = Just d}) + resetDates = L.buildRateResetDates newBnd d lstDate + in return (Map.insert bName newBnd bndMap, [ ResetBondRate d' bName | d' <- resetDates ]) + _ -> Left $ "RefiBondRate: only plain bonds are supported: " ++ bName newAccMap <- adjustM (draw d actualPayout (PayInt [bName])) accName accMap - let newBndMap = Map.insert bName (newBnd {L.bndRate = newRate, L.bndDueIntDate = Just d ,L.bndLastIntPay = Just d}) bndMap let newAds = sortBy sortActionOnDate $ filteredAds ++ bResetActions run t{bonds = newBndMap, accounts = newAccMap} rc (Just newAds) calls log @@ -698,7 +713,7 @@ run t@TestDeal{accounts=accMap,fees=feeMap,triggers=mTrgMap,bonds=bndMap,status= True -> let newStLogs - | null cleanUpActions = DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call"] + | null cleanUpActions = DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call"] | otherwise = DL.fromList [DealStatusChangeTo d dStatus Called "by Date-Based Call", RunningWaterfall d W.CleanUp] in do diff --git a/src/Deal/DealValidation.hs b/src/Deal/DealValidation.hs index 68f6ac56..7a35a9ad 100644 --- a/src/Deal/DealValidation.hs +++ b/src/Deal/DealValidation.hs @@ -27,7 +27,7 @@ import Interface import Deal.DealCollection (CollectionRule(..)) import Control.Lens hiding (element) -import Control.Lens.TH +import Control.Lens.TH () extractRequiredRates :: (P.Asset a,IR.UseRate a) => TestDeal a -> Set.Set Types.Index extractRequiredRates t@TestDeal{accounts = accM diff --git a/src/Expense.hs b/src/Expense.hs index c41dd057..e6b29f19 100644 --- a/src/Expense.hs +++ b/src/Expense.hs @@ -7,31 +7,29 @@ module Expense (Fee(..),FeeType(..) ,buildFeeAccrueAction ,feeNameLens,feeDueLens,feeTypeLens,feeStmtLens,reAccruableFeeType) where -import Lib(Period,paySeqLiabilities,Dates - ,Amount,Balance,Date,Rate,Ts(..)) -import Stmt(appendStmt,Statement,TxnComment(..)) -import Data.Traversable -import Control.Monad -import Language.Haskell.TH - -import qualified Data.Text -import Data.Aeson hiding (json) +import Lib () +import Stmt(appendStmt, Statement) +import Data.Traversable () +import Control.Monad () +import Language.Haskell.TH () + +import qualified Data.Text () +import Data.Aeson import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () import qualified Data.DList as DL import GHC.Generics -import Data.Fixed +import Data.Fixed () import Types import Util import DateUtil import Interface import qualified Stmt as S import qualified InterestRate as IR +import Data.Maybe (fromMaybe) import Control.Lens -import Debug.Trace -debug = flip trace type FormulaRate = DealStats @@ -172,6 +170,17 @@ instance Liable Fee where getOutstandingAmount Fee{feeDue=bal,feeArrears=fa} = bal + fa + -- ^ a fee carries no principal balance / rate; its amount is model-based + -- (deal-stats formulas, tables, ts curves), so due amounts are the whole picture + getCurBalance _ = 0 + getCurRate _ = 0 + getOriginBalance _ = 0 + getOriginDate Fee{feeStart = d} = d + getAccrueBegDate f@Fee{feeLastPaidDay = mPaid} = fromMaybe (feeStart f) mPaid + getDueInt Fee{feeDue = due} = due + getDueIntOverInt _ = 0 + getTotalDueInt Fee{feeDue = due, feeArrears = fa} = due + fa + instance Accruable Fee where getAccrualDates ed Fee{feeStart=fs,feeDueDate=fdDay,feeType=RecurFee dp _} = projDatesByPattern dp fs ed @@ -186,12 +195,24 @@ instance Accruable Fee where getAccrualDates ed Fee{} = [] + -- ^ book an additional due amount directly (ledger-free; see `pay`/`writeOff` + -- for booking transactions via the statement) + bookAccrual d amt f@Fee{feeDue = due} = f { feeDue = due + amt, feeDueDate = Just d } + + -- ^ fee due computation depends on deal context (DealStats-formula based fee types, + -- cf. the commented-out `accrueWithDeal` in Interface.hs); with no context, no accrual + accrueTo _ f = f + instance IR.UseRate Fee where isAdjustableRate x = False getIndex x = Nothing + getIndexes x = Nothing + getResetDates x = [] + getSpread x = Nothing + makeLensesFor [("feeName","feeNameLens"),("feeType","feeTypeLens") ,("feeDue","feeDueLens") - ,("feeDueDate","feeDueDateLens") ,("feeStmt","feeStmtLens")] ''Fee + ,("feeStmt","feeStmtLens")] ''Fee $(deriveJSON defaultOptions ''FeeType) $(deriveJSON defaultOptions ''Fee) diff --git a/src/Hedge.hs b/src/Hedge.hs index aa3b9982..efd28f69 100644 --- a/src/Hedge.hs +++ b/src/Hedge.hs @@ -11,15 +11,15 @@ module Hedge ) where -import qualified Data.Text as T -import qualified Data.Time as Time -import qualified Data.Map as Map +import qualified Data.Text as T () +import qualified Data.Time as Time () +import qualified Data.Map as Map () import GHC.Generics -import Language.Haskell.TH -import Data.Aeson hiding (json) +import Language.Haskell.TH () +import Data.Aeson import Data.Aeson.TH -import Data.Aeson.Types -import Data.Fixed +import Data.Aeson.Types () +import Data.Fixed () import Data.Maybe import qualified Data.DList as DL import Types @@ -28,16 +28,12 @@ import Stmt import DateUtil import Interface -import qualified Assumptions as A +import qualified Assumptions as A () import qualified InterestRate as IR import Control.Lens -import Debug.Trace -debug = flip trace type SettleDates = DatePattern -- ^ dates when rates/ex-rates are reseted -type ReceiveAmount = Balance -- ^ cash to be collect in instrutment -type PayoutAmount = Balance -- ^ cash to be paid in instrutment data RateSwapBase = Fixed Balance -- ^ a fixed balance as notional base | Base DealStats -- ^ a referece as notional base @@ -120,6 +116,20 @@ instance Liable RateSwap where | bal < 0 = negate bal | otherwise = 0 + -- ^ a swap is a net-settlement instrument: no principal balance, no interest accrual — + -- the only balance is the net amount owed to/from the counterparty; + -- the accrual rate is the current paying-leg rate + getCurBalance rs = getOutstandingAmount rs + getCurRate rs@RateSwap{rsPayingRate = r} = r + getOriginBalance _ = 0 + getOriginDate rs@RateSwap{rsStartDate = d} = d + getAccrueBegDate rs = case rsLastStlDate rs of + Just lsd -> lsd + Nothing -> rsStartDate rs + getDueInt _ = 0 + getDueIntOverInt _ = 0 + getTotalDueInt _ = 0 + data RateCap = RateCap { rcIndex :: Types.Index ,rcStrikeRate :: Ts @@ -143,6 +153,14 @@ receiveRC d rc@RateCap{rcNetCash = receiveAmt, rcStmt = stmt} instance IR.UseRate RateCap where getIndexes rc@RateCap{rcIndex = idx} = Just [idx] + -- ^ a rate cap is always indexed to a rate index + isAdjustableRate _ = True + getIndex rc@RateCap{rcIndex = idx} = Just idx + -- ^ reset/settle dates over the cap's life + getResetDates rc@RateCap{rcStartDate = sd,rcSettleDates = dp,rcEndDate = ed} + = genSerialDatesTill2 NO_IE sd dp ed + getSpread _ = Nothing -- ^ the index carries no spread + instance QueryByComment RateCap where queryStmt RateCap{rcStmt = Nothing} tc = [] queryStmt RateCap{rcStmt = Just (Statement txns)} tc @@ -161,7 +179,29 @@ instance IR.UseRate RateSwap where FixedToFloating _ (idx1,_) -> Just [idx1] _ -> Nothing -makeLensesFor [("rsType","rsTypeLens"),("rsRefBalance","rsRefBalLens")] ''RateSwap + -- ^ each swap type has at least one floating leg + isAdjustableRate rs = case rsType rs of + FloatingToFloating _ _ -> True + FloatingToFixed _ _ -> True + FixedToFloating _ _ -> True + FormulaToFloating _ _ -> True + FloatingToFormula _ _ -> True + + getIndex rs = case IR.getIndexes rs of + Just (idx:_) -> Just idx + _ -> Nothing + + -- ^ the floating leg's spread (the only leg that carries one) + getSpread rs = case rsType rs of + FloatingToFloating (_,spr) _ -> Just spr + FloatingToFixed (_,spr) _ -> Just spr + FixedToFloating _ (_,spr) -> Just spr + FormulaToFloating _ (_,spr) -> Just spr + FloatingToFormula (_,spr) _ -> Just spr + + getResetDates _ = [] -- ^ settle/reset dates are computed by the deal run from `rsSettleDates` with deal dates + +makeLensesFor [("rsRefBalance","rsRefBalLens")] ''RateSwap data SrtType = SrtByEndDay DealStats DatePattern -- ^ autu accrue by end of day deriving(Show,Generic,Eq,Ord) @@ -190,39 +230,41 @@ instance Liable SRT where | bal==0 && duePremium==0 = True | otherwise = False + -- ^ the SRT facility: open balance is the drawn/outstanding amount, premium accrues on + -- the reference balance, the current rate is the premium rate + getCurBalance srt@SRT{srtOpenBalance = bal} = bal + getCurRate srt@SRT{srtPremiumRate = r} = r + getOriginBalance srt@SRT{srtOpenBalance = bal} = bal + getOriginDate srt@SRT{srtStart = d} = d + getAccrueBegDate srt@SRT{srtDuePremiumDate = mLastCalcDate} + = fromMaybe (srtStart srt) mLastCalcDate + getDueInt srt@SRT{srtDuePremium = amt} = amt + getDueIntOverInt _ = 0 + getTotalDueInt srt@SRT{srtDuePremium = amt} = amt + getOutstandingAmount srt@SRT{srtOpenBalance = bal,srtDuePremium = duePremium} = bal + duePremium + instance IR.UseRate SRT where getIndexes srt@SRT{srtPremiumType = rt} = case rt of (IR.Floater _ idx _ _ _ _ _ _ ) -> Just [idx] _ -> Nothing + + isAdjustableRate srt@SRT{srtPremiumType = rt} + = case rt of + (IR.Floater {}) -> True + _ -> False + + getIndex srt = case IR.getIndexes srt of + Just (idx:_) -> Just idx + _ -> Nothing + + getSpread srt@SRT{srtPremiumType = rt} = IR._getSpread rt getResetDates srt@SRT{srtPremiumType = rt , srtStart = sd, srtEnds = Just ed} = case rt of (IR.Floater _ _ _ _ dp _ _ _ ) -> genSerialDatesTill2 EI sd dp ed _ -> [] --- | update the reset events of liquidity provider -buildSrtAccrueAction :: [SRT] -> Date -> [(String, Dates)] -> [(String, Dates)] -buildSrtAccrueAction [] ed r = r -buildSrtAccrueAction (srt:srts) ed r = - case srt of - (SRT srtName (SrtByEndDay _ dp ) _ _ _ _ _ _ ss _ _ ) - -> buildSrtAccrueAction - srts - ed - [(srtName, projDatesByPattern dp ss ed)]++r - _ -> buildSrtAccrueAction srts ed r - -buildSrtResetAction :: [SRT] -> Date -> [(String, Dates)] -> [(String, Dates)] -buildSrtResetAction [] ed r = r -buildSrtResetAction (srt:srts) ed r = - case srt of - srt@SRT{srtPremiumType = rt, srtName = ln , srtStart = sd} -> - buildSrtResetAction - srts - ed - [(ln,IR.getRateResetDates sd ed (Just rt))]++r - _ -> buildSrtResetAction srts ed r diff --git a/src/InterestRate.hs b/src/InterestRate.hs index 26bd6d04..d24b8b18 100644 --- a/src/InterestRate.hs +++ b/src/InterestRate.hs @@ -6,30 +6,27 @@ module InterestRate (ARM(..),RateType(..),runInterestRate2,runInterestRate,UseRate(..) ,getRateResetDates,getDayCount,calcInt, calcIntRate,calcIntRateCurve - ,getSpread,_getSpread,calcIntRates) + ,_getSpread,calcIntRates) where -import Language.Haskell.TH -import Data.Aeson hiding (json) +import Language.Haskell.TH () +import Data.Aeson import Data.Aeson.TH import Data.Maybe -import Data.Fixed +import Data.Fixed () import GHC.Generics import DateUtil -import Data.Decimal +import Data.Decimal () import Types import Util import Lib -import Debug.Trace -debug = flip trace type InitPeriod = Int type PeriodicCap = Maybe Spread type LifetimeCap = Maybe IRate -type PaymentCap = Maybe Balance type RateFloor = Maybe IRate type RateCap = Maybe IRate type InitCap = Maybe IRate diff --git a/src/Interface.hs b/src/Interface.hs index 35bbe794..2dc0a263 100644 --- a/src/Interface.hs +++ b/src/Interface.hs @@ -1,16 +1,16 @@ {-# LANGUAGE DeriveGeneric #-} -module Interface(Liable(..),Accruable(..),Payable(..),RateResettable(..),Drawable(..),Collectable(..) +module Interface(Liable(..),MultiIntLiable(..),Accruable(..),Payable(..),RateResettable(..),Drawable(..),Collectable(..) ,DueType(..) ) where -import GHC.Generics +import GHC.Generics () import Types class Liable lb where -- bond / expense / liquidity facility / hedges - + -- single-interest liabilities -- must implement isPaidOff :: lb -> Bool getCurBalance :: lb -> Balance @@ -19,14 +19,18 @@ class Liable lb where getOriginDate :: lb -> Date getAccrueBegDate :: lb -> Date getDueInt :: lb -> Balance - getDueIntAt :: lb -> Int -> Balance getDueIntOverInt :: lb -> Balance - getDueIntOverIntAt :: lb -> Int -> Balance getTotalDueInt :: lb -> Balance - getTotalDueIntAt :: lb -> Int -> Balance getOutstandingAmount :: lb -> Balance +class Liable lb => MultiIntLiable lb where + -- ^ accrual specifics for multi-interest bonds (bond with multiple interest tranches) + getDueIntAt :: lb -> Int -> Balance + getDueIntOverIntAt :: lb -> Int -> Balance + getTotalDueIntAt :: lb -> Int -> Balance + + class Accruable ac where -- diff --git a/src/Ledger.hs b/src/Ledger.hs index c06e07a3..788f2ab3 100644 --- a/src/Ledger.hs +++ b/src/Ledger.hs @@ -5,23 +5,18 @@ module Ledger (Ledger(..),LedgerName,queryGap,clearLedgersBySeq ,entryLogByDr,bookToTarget,bookToClear) where -import qualified Data.Time as T +import qualified Data.Time as T () import Stmt import Types -import Lib -import Util -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Lib () +import Util () +import Data.Aeson +import Language.Haskell.TH () import Data.Aeson.TH -import Data.Aeson.Types +import Data.Aeson.Types () import qualified Data.DList as DL import GHC.Generics -import Control.Lens hiding (element) - -import Control.Lens.TH -import Debug.Trace -debug = flip trace type LedgerName = String @@ -114,7 +109,6 @@ instance QueryByComment Ledger where queryTxnAmt a tc = sum $ map getTxnAmt $ queryStmt a tc -makeLensesFor [("ledgName","ledgNameLens"),("ledgBalance","ledgBalLens"),("ledgStmt","ledgStmtLens")] ''Ledger $(deriveJSON defaultOptions ''Ledger) \ No newline at end of file diff --git a/src/Liability.hs b/src/Liability.hs index 51a35d2b..1a0df0d9 100644 --- a/src/Liability.hs +++ b/src/Liability.hs @@ -10,7 +10,7 @@ module Liability (Bond(..),BondType(..),OriginalInfo(..) ,isPaidOff - ,priceBond,pv,InterestInfo(..),RateReset(..) + ,priceBond,pv,InterestInfo(..),RateReset ,getDueInt,weightAverageBalance,calcZspread,getTotalDueInt ,buildRateResetDates,isAdjustable,StepUp(..),isStepUp,getDayCountFromInfo ,calcWalBond,patchBondFactor,InterestOverInterestType(..) @@ -23,42 +23,39 @@ module Liability ,getAccrueBegDate,getTxnInt,adjInterestInfoByRate,adjInterestInfoBySpread ,interestInfoTraversal,getOriginBalance,curRatesTraversal ,backoutAccruedInt,extractIrrResult,adjustBalance - ,_Bond,_MultiIntBond,_BondGroup ) where -import Data.Aeson hiding (json) +import Data.Aeson import Data.Aeson.TH -import Data.Fixed -import qualified Data.Time as T -import Lib (Period(..),Ts(..) ,TsPoint(..) ,daysBetween, weightedBy,paySeqLiabResi) +import Data.Fixed () +import qualified Data.Time as T () +import Lib (daysBetween, weightedBy) import Util import DateUtil import Types import Analytics -import Data.Ratio +import Data.Ratio () import Data.Maybe import Data.List import Interface import qualified Data.Set as Set import qualified Data.DList as DL import qualified Stmt as S -import qualified Cashflow as CF +import qualified Cashflow as CF () import qualified InterestRate as IR import qualified Lib import GHC.Generics import qualified Data.Map as Map -import Debug.Trace -import InterestRate (UseRate(getIndexes)) -import Language.Haskell.TH +import InterestRate (UseRate(getIndexes,getSpread,getResetDates)) +import Language.Haskell.TH () import Control.Lens hiding (Index) -import Control.Lens.TH -import Language.Haskell.TH.Lens +import Control.Lens.TH () +import Language.Haskell.TH.Lens () import Stmt (getTxnAmt) import Numeric.RootFinding -debug = flip trace -- | test if a bond may changes its interest rate isAdjustable :: InterestInfo -> Bool @@ -92,7 +89,6 @@ getDayCountFromInfo (RefBal ds info) = getDayCountFromInfo info getDayCountFromInfo (CapRate info _) = getDayCountFromInfo info getDayCountFromInfo (FloorRate info _) = getDayCountFromInfo info getDayCountFromInfo (WithIoI info _) = getDayCountFromInfo info -getDayCountFromInfo _ = Nothing type RateReset = DatePattern @@ -159,6 +155,16 @@ getDpFromIntInfo (WithIoI ii _) = getDpFromIntInfo ii getDpFromIntInfo _ = Nothing +-- ^ get spread from interest info +getSpreadFromIntInfo :: InterestInfo -> Maybe Spread +getSpreadFromIntInfo (Floater _ _ s _ _ _ _) = Just s +getSpreadFromIntInfo (RefBal _ ii) = getSpreadFromIntInfo ii +getSpreadFromIntInfo (CapRate ii _) = getSpreadFromIntInfo ii +getSpreadFromIntInfo (FloorRate ii _) = getSpreadFromIntInfo ii +getSpreadFromIntInfo (WithIoI ii _) = getSpreadFromIntInfo ii +getSpreadFromIntInfo _ = Nothing -- ^ Fix / RefRate carry no spread + + getBeginRate :: InterestInfo -> IRate getBeginRate (Floater a _ _ _ _ _ _ ) = a getBeginRate (Fix a _ ) = a @@ -296,7 +302,6 @@ instance S.HasStmt Bond where hasEmptyTxn MultiIntBond{bndStmt = Nothing} = True hasEmptyTxn MultiIntBond{bndStmt = Just (S.Statement txn)} = txn == DL.empty hasEmptyTxn (BondGroup bMap _) = all S.hasEmptyTxn $ Map.elems bMap - hasEmptyTxn _ = False setBondOrigDate :: Date -> Bond -> Bond @@ -321,6 +326,26 @@ patchBondFactor bnd in newBnd +-- | Update principal/balance/statement fields shared by 'Bond' and +-- 'MultiIntBond'. Bond groups are rejected by the callers; the final clause +-- is a defensive no-op. +setBndPrinBalStmt :: Balance -> Balance -> Maybe S.Statement -> Bond -> Bond +setBndPrinBalStmt newDue newBal newStmt b@Bond{} = b {bndDuePrin = newDue, bndBalance = newBal, bndStmt = newStmt} +setBndPrinBalStmt newDue newBal newStmt b@MultiIntBond{} = b {bndDuePrin = newDue, bndBalance = newBal, bndStmt = newStmt} +setBndPrinBalStmt _ _ _ b = b + +-- | Update balance/statement fields shared by 'Bond' and 'MultiIntBond'. +setBndBalStmt :: Balance -> Maybe S.Statement -> Bond -> Bond +setBndBalStmt newBal newStmt b@Bond{} = b {bndBalance = newBal, bndStmt = newStmt} +setBndBalStmt newBal newStmt b@MultiIntBond{} = b {bndBalance = newBal, bndStmt = newStmt} +setBndBalStmt _ _ b = b + +-- | Update the statement field shared by 'Bond' and 'MultiIntBond'. +setBndStmtOnly :: Maybe S.Statement -> Bond -> Bond +setBndStmtOnly newStmt b@Bond{} = b {bndStmt = newStmt} +setBndStmtOnly newStmt b@MultiIntBond{} = b {bndStmt = newStmt} +setBndStmtOnly _ b = b + instance Payable Bond where @@ -335,6 +360,7 @@ instance Payable Bond where pay d DuePrincipal 0 b = return b pay d DuePrincipal _ bnd@(Bond {bndBalance = 0}) = return bnd pay d DuePrincipal _ bnd@(MultiIntBond {bndBalance = 0}) = return bnd + pay _ DuePrincipal _ (BondGroup {}) = Left "Cannot pay principal on a bond group" pay d DuePrincipal amt bnd | amt > (bndBalance bnd) = Left $ "Payment amount is greater than bond balance "++ show (bndBalance bnd) ++ " bond name "++ show (bndName bnd) | otherwise @@ -348,7 +374,8 @@ instance Payable Bond where r = getCurRate bnd newStmt = S.appendStmt (BondTxn d newBal 0 amt r amt dueInt dueIoI Nothing (S.PayPrin [bn] )) stmt in - return $ bnd {bndDuePrin = newDue, bndBalance = newBal , bndStmt = newStmt} + return $ setBndPrinBalStmt newDue newBal newStmt bnd + pay _ DueResidual _ (BondGroup {}) = Left "Cannot pay residual on a bond group" pay d DueResidual amt bnd = let bal = bndBalance bnd @@ -359,7 +386,7 @@ instance Payable Bond where stmt = bndStmt bnd newStmt = S.appendStmt (BondTxn d bal amt 0 r amt dueInt dueIoI Nothing (S.PayYield bn)) stmt in - return bnd { bndStmt = newStmt} + return $ setBndStmtOnly newStmt bnd pay d (DueInterest _) 0 b = return b pay d (DueInterest Nothing) amt bnd@(Bond bn bt oi iinfo _ bal r duePrin dueInt dueIoI dueIntDate lpayInt lpayPrin stmt) @@ -497,6 +524,7 @@ instance Payable Bond where -- TODO: should increase the original balance of the bond? instance Drawable Bond where + draw _ _ _ bond@(BondGroup {}) = Left "Cannot draw on a bond group" draw d amt txn bond | amt < 0 = Left $ "Cannot draw negative amount "++ show amt ++ " from bond "++ show (bndName bond) | amt == 0 = return bond @@ -508,7 +536,7 @@ instance Drawable Bond where newBal = bndBalance bond' + amt newStmt = S.appendStmt (BondTxn d newBal 0 (negate amt) (getCurRate bond') 0 dueInt dueIoI Nothing txn) stmt in - return $ bond' {bndBalance = newBal, bndStmt=newStmt } + return $ setBndBalStmt newBal newStmt bond' availForDraw d bond = Unlimit @@ -801,10 +829,6 @@ instance Liable Bond where getDueInt MultiIntBond{bndDueInts=dis} = sum dis getDueInt (BondGroup bMap _) = sum $ getDueInt <$> Map.elems bMap - getDueIntAt MultiIntBond{bndDueInts=dis} idx = dis !! idx - getDueIntOverIntAt MultiIntBond{bndDueIntOverInts=diois} idx = diois !! idx - getTotalDueIntAt b idx = getDueIntAt b idx + getDueIntOverIntAt b idx - -- ^ get due IoI of a bond getDueIntOverInt b@Bond{bndDueIntOverInt=dioi} = dioi getDueIntOverInt MultiIntBond{bndDueIntOverInts=diois} = sum diois @@ -817,6 +841,24 @@ instance Liable Bond where getOutstandingAmount b = getTotalDueInt b + getCurBalance b + +-- ^ the `Int`-indexed accruals for multi-interest bonds; a plain `Bond` has a single +-- interest tranche (index 0), a `BondGroup` aggregates the per-bond tranches. +instance MultiIntLiable Bond where + getDueIntAt (BondGroup bMap _) idx = sum $ (\b -> getDueIntAt b idx) <$> Map.elems bMap + getDueIntAt MultiIntBond{bndDueInts=dis} idx = dis !! idx + getDueIntAt Bond{bndDueInt=di} idx + | idx == 0 = di + | otherwise = 0 + + getDueIntOverIntAt (BondGroup bMap _) idx = sum $ (\b -> getDueIntOverIntAt b idx) <$> Map.elems bMap + getDueIntOverIntAt MultiIntBond{bndDueIntOverInts=diois} idx = diois !! idx + getDueIntOverIntAt Bond{bndDueIntOverInt=dioi} idx + | idx == 0 = dioi + | otherwise = 0 + + getTotalDueIntAt b idx = getDueIntAt b idx + getDueIntOverIntAt b idx + instance IR.UseRate Bond where isAdjustableRate :: Bond -> Bool isAdjustableRate Bond{bndInterestInfo = iinfo} = isAdjustable iinfo @@ -827,9 +869,34 @@ instance IR.UseRate Bond where getIndexes MultiIntBond{bndInterestInfos = iis} = Just $ concat $ concat <$> getIndexFromInfo <$> iis + getIndex b = case getIndexes b of + Just (idx:_) -> Just idx + _ -> Nothing + + -- ^ reset dates of a floater interest schedule, derived from its own reset pattern + -- (same derivation as `buildRateResetDates`; `[]` when no maturity is modeled on the bond) + getResetDates Bond{bndInterestInfo = iinfo, bndOriginInfo = oi} + = case (getDpFromIntInfo iinfo, maturityDate oi) of + (Just dp, Just ed) -> genSerialDatesTill2 NO_IE (originDate oi) dp ed + _ -> [] + getResetDates MultiIntBond{bndInterestInfos = iis, bndOriginInfo = oi} + = case maturityDate oi of + Nothing -> [] + Just ed -> concat $ (\dp -> genSerialDatesTill2 NO_IE (originDate oi) dp ed) + <$> mapMaybe getDpFromIntInfo iis + getResetDates (BondGroup bMap _) = concat $ IR.getResetDates <$> Map.elems bMap + + getSpread (Bond{bndInterestInfo = iinfo}) = getSpreadFromIntInfo iinfo + getSpread MultiIntBond{bndInterestInfos = iis} = case (getSpreadFromIntInfo <$> iis) of + (Just sp:_) -> Just sp + _ -> Nothing + getSpread (BondGroup bMap _) = case catMaybes (IR.getSpread <$> Map.elems bMap) of + (sp:_) -> Just sp + _ -> Nothing + -makeLensesFor [("bndType","bndTypeLens"),("bndOriginInfo","bndOriginInfoLens"),("bndInterestInfo","bndIntLens"),("bndStmt","bndStmtLens")] ''Bond +makeLensesFor [("bndOriginInfo","bndOriginInfoLens"),("bndInterestInfo","bndIntLens")] ''Bond makeLensesFor [("bndOriginDate","bndOriginDateLens"),("bndOriginBalance","bndOriginBalanceLens"),("bndOriginRate","bndOriginRateLens")] ''OriginalInfo makePrisms ''Bond diff --git a/src/Lib.hs b/src/Lib.hs index 86e2ed2e..3c8b5dfd 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -12,6 +12,7 @@ module Lib ,Floor,Cap,TsPoint(..) ,toDate,toDates,genDates,nextDate ,getValOnByDate,getIntValOnByDate,sumValTs,subTsBetweenDates,splitTsByDate + ,tryGetValOnByDate,tryGetIntValOnByDate,trySumValTs,trySubTsBetweenDates,trySplitTsByDate ,paySeqLiabilitiesAmt,getIntervalDays,getIntervalFactors ,zipWith8,zipWith9,zipWith10,zipWith11,zipWith12 ,weightedBy, mkTs ,mkRateTs,paySeqLiabResi ,centiToDecimal @@ -21,18 +22,17 @@ import qualified Data.Time as T import qualified Data.Time.Format as TF import Data.List -- import qualified Data.Scientific as SCI -import qualified Data.Map as M -import Language.Haskell.TH -import Data.Aeson.TH -import Data.Aeson.Types -import Data.Aeson hiding (json) +import qualified Data.Map as M () +import qualified Data.IntSet as IntSet +import Language.Haskell.TH () +import Data.Aeson.TH () +import Data.Aeson.Types () +import Data.Aeson () -- import Text.Regex.TDFA -import Data.Fixed (Fixed(..), HasResolution,Centi, resolution) -import Data.Ratio +import Data.Fixed (Centi) +import Data.Ratio () import Types import Data.Decimal -import Debug.Trace -debug = flip trace periodRateFromAnnualRate :: Period -> IRate -> IRate @@ -44,8 +44,6 @@ periodRateFromAnnualRate Daily annual_rate = annual_rate / 365 periodRateFromAnnualRate Weekly annual_rate = annual_rate / 52.143 periodRateFromAnnualRate BiWeekly annual_rate = annual_rate / 26.0715 -addD :: Date -> T.CalendarDiffDays -> Date -addD d calendarMonth = T.addGregorianDurationClip T.calendarMonth d getIntervalDays :: [Date] -> [Int] getIntervalDays [] = [] @@ -68,17 +66,18 @@ centiToDecimal c = Decimal 2 (round c * 100) -- negative allocations (#322 review L3). prorataFactors :: [Balance] -> Balance -> [Balance] prorataFactors bals amt - | totalCents <= 0 = replicate (length bals) 0 + | totalCents <= 0 = replicate n 0 | otherwise = map (toEnum . fromInteger) $ zipWith (+) baseAdds extraCents where + n = length bals centList = max 0 . 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 (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] ] + extraIdx = IntSet.fromList $ fst <$> take (fromInteger residual) order + extraCents = [ if IntSet.member i extraIdx then 1 else 0 | i <- [0 .. n - 1] ] -- @@ -139,37 +138,69 @@ mkRateTs :: [(Date,IRate)] -> Ts mkRateTs ps = IRateCurve [ TsPoint d v | (d,v) <- ps] +tsTypeName :: Ts -> String +tsTypeName (FloatCurve _) = "FloatCurve" +tsTypeName (BoolCurve _) = "BoolCurve" +tsTypeName (BalanceCurve _) = "BalanceCurve" +tsTypeName (LeftBalanceCurve _) = "LeftBalanceCurve" +tsTypeName (RatioCurve _) = "RatioCurve" +tsTypeName (ThresholdCurve _) = "ThresholdCurve" +tsTypeName (IRateCurve _) = "IRateCurve" +tsTypeName (FactorCurveClosed _ _) = "FactorCurveClosed" +tsTypeName (PricingCurve _) = "PricingCurve" +tsTypeName (PeriodCurve _) = "PeriodCurve" +tsTypeName (IntCurve _) = "IntCurve" + +unsupportedCurve :: String -> String -> Ts -> Either ErrorRep a +unsupportedCurve fn expected ts + = Left $ fn ++ ": expected " ++ expected ++ " but got " ++ tsTypeName ts + +tryGetValOnByDate :: Ts -> Date -> Either ErrorRep Balance +tryGetValOnByDate (BalanceCurve dps) d + = Right $ case find (\(TsPoint _d _) -> ( d >= _d )) (reverse dps) of + Just (TsPoint _d v) -> v + Nothing -> 0 +tryGetValOnByDate ts _ = unsupportedCurve "getValOnByDate" "BalanceCurve" ts + getValOnByDate :: Ts -> Date -> Balance -getValOnByDate (BalanceCurve dps) d - = case find (\(TsPoint _d _) -> ( d >= _d )) (reverse dps) of - Just (TsPoint _d v) -> v - Nothing -> 0 +getValOnByDate ts d = either error id (tryGetValOnByDate ts d) + +tryGetIntValOnByDate :: Ts -> Date -> Either ErrorRep Int +tryGetIntValOnByDate (IntCurve dps) d + = Right $ case find (\(TsPoint _d _) -> ( d >= _d )) (reverse dps) of + Just (TsPoint _d v) -> v + Nothing -> 0 +tryGetIntValOnByDate ts _ = unsupportedCurve "getIntValOnByDate" "IntCurve" ts getIntValOnByDate :: Ts -> Date -> Int -getIntValOnByDate (IntCurve dps) d - = case find (\(TsPoint _d _) -> ( d >= _d )) (reverse dps) of - Just (TsPoint _d v) -> v - Nothing -> 0 +getIntValOnByDate ts d = either error id (tryGetIntValOnByDate ts d) +trySplitTsByDate :: Ts -> T.Day -> Either ErrorRep (Ts, Ts) +trySplitTsByDate (BalanceCurve ds) d + = Right $ case (findIndex (\(TsPoint _d _) -> _d > d ) ds) of + Nothing -> (BalanceCurve ds, BalanceCurve []) + Just idx -> let (l,r) = splitAt idx ds in (BalanceCurve l, BalanceCurve r) +trySplitTsByDate ts _ = unsupportedCurve "splitTsByDate" "BalanceCurve" ts splitTsByDate :: Ts -> T.Day -> (Ts, Ts) -splitTsByDate (BalanceCurve ds) d - = case (findIndex (\(TsPoint _d _) -> _d > d ) ds) of - Nothing -> (BalanceCurve ds, BalanceCurve []) - Just idx -> (BalanceCurve l, BalanceCurve r) - where - (l,r) = splitAt idx ds +splitTsByDate ts d = either error id (trySplitTsByDate ts d) + +trySubTsBetweenDates :: Ts -> Maybe Date -> Maybe Date -> Either ErrorRep Ts +trySubTsBetweenDates (BalanceCurve vs) msd med + = Right $ BalanceCurve $ filter (\(TsPoint x _) -> inRange x) vs + where + inRange x = maybe True (x >) msd && maybe True (x <) med +trySubTsBetweenDates ts _ _ = unsupportedCurve "subTsBetweenDates" "BalanceCurve" ts subTsBetweenDates :: Ts -> Maybe Date -> Maybe Date -> Ts -subTsBetweenDates (BalanceCurve vs) (Just sd) (Just ed) - = BalanceCurve $ filter(\(TsPoint x _) -> (x > sd) && (x < ed) ) vs -subTsBetweenDates (BalanceCurve vs) Nothing (Just ed) - = BalanceCurve $ filter(\(TsPoint x _) -> x < ed ) vs -subTsBetweenDates (BalanceCurve vs) (Just sd) Nothing - = BalanceCurve $ filter(\(TsPoint x _) -> x > sd ) vs +subTsBetweenDates ts msd med = either error id (trySubTsBetweenDates ts msd med) + +trySumValTs :: Ts -> Either ErrorRep Amount +trySumValTs (BalanceCurve ds) = Right $ foldr (\(TsPoint _ v) acc -> acc+v ) 0 ds +trySumValTs ts = unsupportedCurve "sumValTs" "BalanceCurve" ts sumValTs :: Ts -> Amount -sumValTs (BalanceCurve ds) = foldr (\(TsPoint _ v) acc -> acc+v ) 0 ds +sumValTs ts = either error id (trySumValTs ts) toDate :: String -> Date @@ -204,9 +235,6 @@ zipWith12 z (a:as) (b:bs) (c:cs) (d:ds) (e:es) (f:fs) (g:gs) (h:hs) (j:js) (k:ks zipWith12 _ _ _ _ _ _ _ _ _ _ _ _ _ = [] -floatToFixed :: HasResolution a => Float -> Fixed a -floatToFixed x = y where - y = MkFixed (round (fromInteger (resolution y) * x)) -- | given balances and weight, get sum weighted balance weightedBy :: [Rational] -> [Rational] -> Rational diff --git a/src/Pool.hs b/src/Pool.hs index d4f36d90..d45dd1d5 100644 --- a/src/Pool.hs +++ b/src/Pool.hs @@ -11,42 +11,37 @@ module Pool (Pool(..),aggPool ) where -import Lib (Period(..) - ,Ts(..),periodRateFromAnnualRate,toDate - ,getIntervalDays,zipWith9,mkTs,monthsBetween - ,mkRateTs,daysBetween, prorataFactors) +import Lib (prorataFactors) import Control.Parallel.Strategies import qualified Cashflow as CF -- (Cashflow,Amount,Interests,Principals) import qualified Assumptions as A import qualified Analytics as AN -import qualified AssetClass.AssetBase as ACM -import AssetClass.Mortgage -import AssetClass.AssetCashflow +import qualified AssetClass.AssetBase as ACM () +import AssetClass.Mortgage () +import AssetClass.AssetCashflow () import Asset (Asset(..)) import qualified Data.Map as Map -import Data.Ratio +import Data.Ratio () import qualified Data.Set as S import Data.List -import Data.Aeson hiding (json) -import Language.Haskell.TH +import Data.Aeson +import Language.Haskell.TH () import GHC.Generics import Data.Aeson.TH -import Data.Aeson.Types -import Types hiding (Current) +import Data.Aeson.Types () +import Types import Data.Maybe import Control.Lens -import Control.Lens.TH -import Assumptions (ApplyAssumptionType) +import Control.Lens.TH () +import Assumptions () import Util -import Cashflow (CashFlowFrame) -import qualified Stmt as CF +import Cashflow () +import qualified Stmt as CF () import Stmt -import Debug.Trace -debug = flip trace data Pool a = Pool {assets :: [a] -- ^ a list of assets in the pool diff --git a/src/Reports.hs b/src/Reports.hs index 0a31416f..6e97e286 100644 --- a/src/Reports.hs +++ b/src/Reports.hs @@ -12,23 +12,23 @@ 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 +import qualified Cashflow as CF () import qualified Accounts as A import qualified CreditEnhancement as CE import qualified Hedge as HE import qualified Expense as F import qualified Liability as L -import Control.Applicative (liftA3) +import Control.Applicative () import Types import Deal.DealBase - ( TestDeal(TestDeal, pool, fees, bonds, accounts,liqProvider,rateSwap), getIssuanceStatsConsol ,poolTypePool, dealPool,RunContext) + ( TestDeal(TestDeal, pool, fees, bonds, accounts,liqProvider,rateSwap), poolTypePool, dealPool,RunContext) import Deal.DealQuery ( queryCompound ) import Deal.DealAction ( calcDueFee, calcDueInt ) import Data.Maybe (fromMaybe) import Control.Lens hiding (element) -import Control.Lens.TH -import Control.Lens +import Control.Lens.TH () +import Control.Lens () import Stmt ( aggByTxnComment, getFlow, @@ -69,7 +69,6 @@ getPoolBalanceStats t rc d mPid poolStats2::[Rational] <- sequenceA poolStats return $ fromRational <$> poolStats2 -type PoolBalanceSnapshot = (Balance, Balance, Balance) buildBalanceSheet :: P.Asset a => TestDeal a -> RunContext-> Date -> Either String BalanceSheetReport buildBalanceSheet t@TestDeal{ pool = pool, bonds = bndMap , fees = feeMap , liqProvider = liqMap, rateSwap = rsMap ,accounts = accMap} diff --git a/src/Revolving.hs b/src/Revolving.hs index 80c53da0..5b000676 100644 --- a/src/Revolving.hs +++ b/src/Revolving.hs @@ -12,14 +12,14 @@ module Revolving where import GHC.Generics -import Language.Haskell.TH -import Data.Aeson hiding (json) -import qualified Data.Text as T -import qualified Cashflow as CF +import Language.Haskell.TH () +import Data.Aeson +import qualified Data.Text as T () +import qualified Cashflow as CF () import Data.Aeson.TH -import Data.Aeson.Types -import Data.Hashable -import Data.Fixed +import Data.Aeson.Types () +import Data.Hashable () +import Data.Fixed () import Data.List import Types diff --git a/src/Stmt.hs b/src/Stmt.hs index 0402bf38..e72689d9 100644 --- a/src/Stmt.hs +++ b/src/Stmt.hs @@ -17,30 +17,28 @@ module Stmt where import Lib (toDate,getIntervalFactors) -import Util (mulBR, mulBInt) +import Util (mulBR) import Types -import Language.Haskell.TH +import Language.Haskell.TH () import Data.Aeson.TH -import Data.Aeson.Types -import Data.Aeson hiding (json) -import Text.Regex.Base -import Text.Regex.PCRE -import Data.Fixed +import Data.Aeson.Types () +import Data.Aeson () +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 -import qualified Data.Vector as V -import qualified Data.Text as T +import qualified Data.Set as Set () +import qualified Data.Vector as V () +import qualified Data.Text as T () import qualified Data.Map as M -import Control.Applicative (liftA2) +import Control.Applicative () import Control.Lens hiding (element,Empty) -import Control.Lens.TH +import Control.Lens.TH () -import Debug.Trace -debug = flip trace aggByTxnComment :: [Txn] -> M.Map TxnComment [Txn] -> M.Map TxnComment Balance @@ -113,14 +111,6 @@ getTxnAmt TrgTxn {} = 0.0 getTxnAsOf :: [Txn] -> Date -> Maybe Txn getTxnAsOf txns d = find (\x -> getDate x <= d) $ reverse txns -emptyTxn :: Txn -> Date -> Txn -emptyTxn BondTxn {} d = BondTxn d 0 0 0 0 0 0 0 Nothing Empty -emptyTxn AccTxn {} d = AccTxn d 0 0 Empty -emptyTxn ExpTxn {} d = ExpTxn d 0 0 0 Empty -emptyTxn SupportTxn {} d = SupportTxn d Unlimit 0 0 0 0 Empty -emptyTxn IrsTxn {} d = IrsTxn d 0 0 0 0 0 Empty -emptyTxn EntryTxn {} d = EntryTxn d (Credit,0) (Credit,0) Empty -emptyTxn TrgTxn {} d = TrgTxn d False Empty isEmptyTxn :: Txn -> Bool isEmptyTxn (BondTxn _ 0 0 0 _ 0 0 0 _ Empty) = True @@ -263,7 +253,6 @@ getFlow comment = Inflow else Noneflow - _ -> error ("Missing in GetFlow >> "++ show comment) -- ^ filter transaction by apply a filter function on txn comment filterTxn :: (TxnComment -> Bool) -> [Txn] -> [Txn] diff --git a/src/Triggers.hs b/src/Triggers.hs index 74e13c1b..4fe2a976 100644 --- a/src/Triggers.hs +++ b/src/Triggers.hs @@ -7,21 +7,21 @@ module Triggers( ) where -import qualified Data.Text as T +import qualified Data.Text as T () import qualified Stmt as S import qualified Liability as L -import Text.Read (readMaybe) -import Lib +import Text.Read () +import Lib () import Types import Accounts (ReserveAmount) import Waterfall (Action) -import Data.Aeson ( defaultOptions ) -import Language.Haskell.TH +import Data.Aeson () +import Language.Haskell.TH () import Data.Aeson.TH -import Data.Aeson.Types -import Data.Fixed -import Data.Maybe -import Data.Map +import Data.Aeson.Types () +import Data.Fixed () +import Data.Maybe () +import Data.Map () import GHC.Generics import Control.Lens import Deal.DealCollection (CollectionRule(..)) @@ -50,9 +50,6 @@ data Trigger = Trigger { ,trgStmt :: Maybe S.Statement -- ^ Transaction stmt } deriving (Show, Eq, Generic,Ord) -makeLensesFor [("trgStatus","trgStatusLens") - ,("trgEffects","trgEffectsLens") - ,("trgCondition","trgConditionLens") - ,("trgCurable","trgCurableLens")] ''Trigger +makeLensesFor [("trgStatus","trgStatusLens")] ''Trigger $(concat <$> traverse (deriveJSON defaultOptions) [''TriggerEffect, ''Trigger]) diff --git a/src/Types.hs b/src/Types.hs index fc5aa4ad..4cbc5e45 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -35,7 +35,7 @@ module Types ,Table(..),lookupTable,Direction(..),epocDate,BorrowerNum ,Txn(..),TxnComment(..) ,RoundingBy(..),DateDirection(..) - ,BookDirection(..),IRR(..),DealCycle(..),Limit(..),Pre(..) + ,BookDirection(..),IRR,DealCycle(..),Limit(..),Pre(..) ,CumPrepay,CumDefault,CumDelinq,CumPrincipal,CumLoss,CumRecovery,PoolId(..) ,DealName,lookupIntervalTable,CutoffFields(..),PriceResult(..) ,DueInt,DuePremium, DueIoI,DateVector,DealStats(..) @@ -55,35 +55,32 @@ import qualified Data.Text as T import qualified Data.Vector as V import qualified Data.Time as Time import qualified Data.Time.Format as TF -import qualified Data.Map as Map import qualified Data.List.Split import GHC.Generics -import Language.Haskell.TH +import Language.Haskell.TH () import Control.Lens hiding (element,Index,Empty) -import Control.Lens.TH +import Control.Lens.TH () -import Text.Read (readMaybe, get) -import Data.Aeson (ToJSON, toJSON, Value(String)) +import Text.Read (readMaybe) +import Data.Aeson () -import Data.Ratio (Ratio, numerator, denominator) -import Data.Text (pack) -import Control.DeepSeq (NFData,rnf) -import Control.Monad (foldM) +import Data.Ratio (Ratio) +import Data.Text () +import Control.DeepSeq (NFData) +import Control.Monad () -import Data.Scientific (fromRationalRepetend,formatScientific, Scientific,FPFormat(Fixed)) +import Data.Scientific (fromRationalRepetend, formatScientific, FPFormat(Fixed)) -import Data.Aeson hiding (json) +import Data.Aeson import Data.Aeson.TH import Data.Aeson.Types -import Data.Fixed hiding (Ratio) +import Data.Fixed import Data.Decimal -import Data.Ix -import Data.List (intercalate, findIndex, find) -import Debug.Trace +import Data.Ix () +import Data.List (findIndex, find) import Data.Scientific (scientific) import Data.Text (unpack) -debug = flip trace @@ -95,13 +92,11 @@ type AccName = String type AccountName = String type AccNames = [String] type CeName = String -type Comment = String type Date = Time.Day type Dates = [Time.Day] type StartDate = Date type EndDate = Date -type LastIntPayDate = Date type Balance = Centi type Amount = Balance @@ -128,7 +123,6 @@ type WAL = Balance type PerFace = Micro type Duration = Micro type Convexity = Micro -type Yield = Micro type IRR = Micro type AccrueAmt = Micro @@ -182,6 +176,7 @@ data Index = LPR5Y type Floater = (Index,Spread) +epocDate :: Date epocDate = Time.fromGregorian 1970 1 1 -- http://www.deltaquants.com/day-count-conventions data DayCount = DC_30E_360 -- ^ ISMA European 30S/360 Special German Eurobond Basis @@ -1166,8 +1161,6 @@ parseTxn t = ++ " (expected canonical form '')") -mapKVTraversal :: Traversal' (Map.Map k a) (k, a) -mapKVTraversal = itraversed . withIndex data DealStatType = RtnBalance | RtnRate @@ -1264,7 +1257,6 @@ getDealStatType (Min (d:_)) = getDealStatType d getDealStatType (Min []) = RtnBalance getDealStatType _ = RtnBalance -dealStatType _ = RtnBalance data CustomDataType = CustomConstant Rational | CustomCurve Ts diff --git a/src/Util.hs b/src/Util.hs index f9182f15..ead025e7 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -1,5 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} module Util (mulBR,mulBIR,mulBI,mulBInt,mulBInteger,lastN @@ -20,12 +21,12 @@ module Util ,debugOnDate,paySeqM,payProM,splitByLengths,showLength ) where -import qualified Data.Time as T +import qualified Data.Time as T () import qualified Data.Map as Map import Data.List import Data.Fixed -import Data.Ratio ((%)) -import Data.Ix +import Data.Ratio ((%), numerator, denominator) +import Data.Ix () import Data.Maybe import qualified Data.Map as M import qualified Data.Set as S @@ -34,19 +35,29 @@ import Types import DateUtil import Numeric.Limits (infinity) -import Text.Printf +import Text.Printf () import Control.Exception import Control.Parallel.Strategies (parBuffer, rseq, using) -import Data.Time (addDays) -import Debug.Trace -debug = flip trace - +import Data.Time () + +-- | Resolution of 'IRate'/'Balance'. Kept internal: 'Micro' is 1,000,000 and +-- 'Centi' is 100. Using 'resolution' keeps this correct if the aliases change. +-- NB: the fast paths below pattern-match on 'Data.Fixed.MkFixed'; if +-- 'Balance'/'IRate' ever move away from 'Data.Fixed', update them together. +microScale, balanceScale :: Integer +microScale = resolution (0 :: IRate) +balanceScale = resolution (0 :: Balance) + +-- | The old implementation went through 'Rational' and 'fromRational'. +-- 'Data.Fixed''s 'fromRational' rounds down (floor, including for negatives), +-- so for a rate @n/d@ the result is exactly @(cents * n) `div` d@. 'div' +-- (not 'quot') preserves that behaviour for negative balances as well. mulBR :: Balance -> Rate -> Balance -mulBR b r = fromRational $ toRational b * r +mulBR (MkFixed b) r = MkFixed ((b * numerator r) `div` denominator r) mulBIR :: Balance -> IRate -> Balance -mulBIR b r = fromRational $ toRational b * toRational r +mulBIR (MkFixed b) (MkFixed r) = MkFixed ((b * r) `div` microScale) mulIR :: Int -> Rational -> Rational mulIR i r = toRational i * r @@ -54,23 +65,23 @@ mulIR i r = toRational i * r splitBal :: Rate -> Balance -> (Balance,Balance) splitBal r b = (mulBR b r, mulBR b (1-r)) -mulIntegerR :: Integer -> Rational -> Rational -mulIntegerR i r = toRational i * r mulBInt :: Balance -> Int -> Rational -mulBInt b i = toRational b * toRational i +mulBInt (MkFixed b) i = (b * toInteger i) % balanceScale mulBInteger :: Balance -> Integer -> Rational mulBInteger b i = mulBInt b (fromInteger i) mulBI :: Balance -> IRate -> Amount -mulBI bal r = fromRational $ toRational bal * toRational r +mulBI = mulBIR divideBI :: Balance -> Int -> Balance -divideBI b i = fromRational $ toRational b / toRational i +divideBI (MkFixed b) i + | i == 0 = throw RatioZeroDenominator + | otherwise = MkFixed (b `div` toInteger i) divideBB :: Balance -> Balance -> Rational -divideBB b1 b2 = toRational b1 / toRational b2 +divideBB (MkFixed b1) (MkFixed b2) = b1 % b2 safeDivide :: RealFloat a => a -> a -> a safeDivide _ 0 = Numeric.Limits.infinity @@ -169,7 +180,7 @@ getValByDate (PricingCurve dps) _ d (True,_) -> tsPointVal $ last dps (_,True) -> tsPointVal $ head dps _ -> let - rindex = fromMaybe 0 $findIndex (\(TsPoint _dl _) -> ( _dl > d )) dps + rindex = fromMaybe 0 $ findIndex (\(TsPoint _dl _) -> ( _dl > d )) dps rdp@(TsPoint _dr _rv) = dps!!rindex ldp@(TsPoint _dl _lv) = dps!!(pred rindex) leftDistance = toRational $ daysBetween _dl d -- `debug` ("LEFT"++show d) @@ -185,12 +196,71 @@ getValByDate (PricingCurve dps) _ d getValByDate a b c = error $ "Not match for curve type"++show a++" > "++show b++" > " ++show c -getIndexRateByDates :: RateAssumption -> [Date] -> [IRate] -getIndexRateByDates (RateCurve idx rc) ds = fromRational <$> getValByDates rc Inc ds -getIndexRateByDates (RateFlat idx r) ds = replicate (length ds) r +-- | Curve points are traversed with a single forward cursor when the input +-- dates are ascending. This avoids reversing the curve for every date, which +-- is what the per-date 'getValByDate' path does. Unsorted dates (or unsorted +-- points) fall back to the legacy implementation, so results are unchanged. getValByDates :: Ts -> CutoffType -> [Date] -> [Rational] -getValByDates rc ct = map (getValByDate rc ct) +getValByDates _ _ [] = [] +getValByDates rc@(LeftBalanceCurve pts) ct ds + | isAscendingPoints pts = mergeLastBy toRational (getValByDate rc ct) ct pts ds +getValByDates rc@(BalanceCurve pts) ct ds + | isAscendingPoints pts = mergeLastBy toRational (getValByDate rc ct) ct pts ds +getValByDates rc@(FloatCurve pts) ct ds + | isAscendingPoints pts = mergeLastBy id (getValByDate rc ct) ct pts ds +getValByDates rc@(IRateCurve pts) ct ds + | isAscendingPoints pts = mergeLastBy toRational (getValByDate rc ct) ct pts ds +getValByDates rc@(RatioCurve pts) ct ds + | isAscendingPoints pts = mergeLastBy id (getValByDate rc ct) ct pts ds +getValByDates rc@(FactorCurveClosed pts ed) Exc ds + | isAscendingPoints pts = mergeFactorClosed ed (getValByDate rc Exc) pts ds +getValByDates rc ct ds = map (getValByDate rc ct) ds + +isAscendingPoints :: [TsPoint a] -> Bool +isAscendingPoints (TsPoint d1 _ : rest@(TsPoint d2 _ : _)) = d1 <= d2 && isAscendingPoints rest +isAscendingPoints _ = True + +mergeLastBy :: (a -> Rational) -> (Date -> Rational) -> CutoffType + -> [TsPoint a] -> [Date] -> [Rational] +mergeLastBy valOf fallback ct pts0 ds = go pts0 0 ds + where + go _ !prev [] = [] + go pts !prev (d:ds) = + let (pts', prev') = advance pts prev d + rest = case ds of + (d2:_) | d2 < d -> map fallback ds + _ -> go pts' prev' ds + in prev' : rest + + advance [] prev _ = ([], prev) + advance allPts@(TsPoint pd pv : rest) prev d + | within pd d = advance rest (valOf pv) d + | otherwise = (allPts, prev) + + within pd d = case ct of + Inc -> pd <= d + Exc -> pd < d + +mergeFactorClosed :: Date -> (Date -> Rational) -> [TsPoint Rational] + -> [Date] -> [Rational] +mergeFactorClosed ed fallback pts0 ds = go pts0 Nothing ds + where + go _ _ [] = [] + go pts !prevM (d:ds) = + let (pts', prevM') = advance pts prevM d + value = case prevM' of + Nothing -> 1.0 + Just v -> if d >= ed then 1.0 else v + rest = case ds of + (d2:_) | d2 < d -> map fallback ds + _ -> go pts' prevM' ds + in value : rest + + advance [] prev _ = ([], prev) + advance allPts@(TsPoint pd pv : rest) prev d + | pd < d = advance rest (Just (toRational pv)) d + | otherwise = (allPts, prev) getTsVals :: Ts -> [Rational] getTsVals (FloatCurve ts) = [ v | (TsPoint d v) <- ts ] @@ -259,8 +329,6 @@ scaleByFstElement y (b:xs) = y:[ x * s | x <- xs ] -debugLine :: Show a => [a] -> String -debugLine xs = "" -- | Like 'Map.map' but evaluates the mapped values in parallel, keeping at most -- @n@ computations in flight at once. Bounding the in-flight work avoids spark @@ -321,8 +389,6 @@ calcWeightBalanceByDates dc bals ds ds_length = length ds weights = getIntervalFactorsDc dc ds -testSumToOne :: [Rate] -> Bool -testSumToOne rs = sum rs == 1.0 maximum' :: Ord a => [a] -> a maximum' = foldr1 (\x y ->if x >= y then x else y) diff --git a/src/Waterfall.hs b/src/Waterfall.hs index ae05874b..9a648903 100644 --- a/src/Waterfall.hs +++ b/src/Waterfall.hs @@ -4,27 +4,27 @@ {-# LANGUAGE DeriveGeneric #-} module Waterfall - (PoolSource(..),Action(..),DistributionSeq(..) + (PoolSource(..),Action(..),DistributionSeq ,ActionWhen(..),BookType(..),ExtraSupport(..),PayOrderBy(..)) where -import Language.Haskell.TH -import Data.Aeson hiding (json) -import qualified Data.Text as T -import Text.Read (readMaybe) +import Language.Haskell.TH () +import Data.Aeson +import qualified Data.Text as T () +import Text.Read () import Data.Aeson.TH -import Data.Aeson.Types -import Data.Hashable -import Data.Fixed +import Data.Aeson.Types () +import Data.Hashable () +import Data.Fixed () import GHC.Generics import Types -import Revolving -import Stmt (TxnComment(..)) -import qualified Lib as L -import qualified Call as C +import Revolving () +import Stmt () +import qualified Lib as L () +import qualified Call as C () import qualified CreditEnhancement as CE -import qualified Hedge as HE +import qualified Hedge as HE () import Ledger (LedgerName) @@ -66,7 +66,6 @@ data PayOrderBy deriving (Show,Generic,Eq,Ord) type BookLedger = (BookDirection, LedgerName) -type BookLedgers = (BookDirection, [LedgerName]) data Action -- Accounts diff --git a/test/MainTest.hs b/test/MainTest.hs index ac176f42..b97f2e0f 100644 --- a/test/MainTest.hs +++ b/test/MainTest.hs @@ -70,6 +70,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,BT.accrueTest ,BT.selectorTest ,BT.walSafetyTest + ,BT.bondGroupSafetyTest ,LT.curveTests ,LT.periodCurveTest ,LT.pvTests @@ -99,6 +100,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,UtilT.tsTest ,UtilT.ts2Test ,UtilT.ts3Test + ,UtilT.curveLookupLegacyTest ,UtilT.dateVectorPatternTest ,UtilT.paddingTest ,UtilT.dateSliceTest @@ -117,6 +119,7 @@ tests = testGroup "Tests" [AT.mortgageTests ,UtilT.workerNumTest ,UtilT.serverConfigLimitTest ,UtilT.badRequestJSONTest + ,UtilT.moneyMathLegacyTest ,AccT.intTests ,AccT.investTests ,AccT.reserveAccTest diff --git a/test/UT/AccountTest.hs b/test/UT/AccountTest.hs index 6798e130..2163fde9 100644 --- a/test/UT/AccountTest.hs +++ b/test/UT/AccountTest.hs @@ -5,6 +5,7 @@ import Test.Tasty import Test.Tasty.HUnit import Accounts import Lib +import qualified InterestRate as IR import Stmt import Util import DateUtil @@ -73,6 +74,11 @@ investTests = assertEqual "MonthEnd with txns" 152.40 (accBalance (depositInt (toDate "20221101") acc2 )) + -- regression tests for UseRate class completeness on Account + ,testCase "UseRate on InvestmentAccount" $ + assertEqual "index/spread/reset on investment account" + (Just [SOFR1Y], Just SOFR1Y, True, Nothing, []) + (IR.getIndexes acc1, IR.getIndex acc1, IR.isAdjustableRate acc1, IR.getSpread acc1, IR.getResetDates acc1) ] diff --git a/test/UT/AnalyticsTest.hs b/test/UT/AnalyticsTest.hs index 3131c619..c3d55a3b 100644 --- a/test/UT/AnalyticsTest.hs +++ b/test/UT/AnalyticsTest.hs @@ -5,6 +5,7 @@ import Test.Tasty import Test.Tasty.HUnit import qualified Data.Time as T +import Data.Either (isLeft) import qualified Lib as L import Analytics import Assumptions @@ -13,9 +14,44 @@ import Asset (priceAsset) import AssetClass.AssetBase import AssetClass.Loan import InterestRate +import DateUtil (yearCountFraction) +import Util (getValByDate, getTsDates, getTsVals, divideBB) +import Data.Fixed (Micro) import Data.Ratio +-- Independent oracle helpers for the curve-consistency tests. They evaluate +-- the curve with the public Hermite interpolant and re-derive PV/duration/ +-- convexity from the formulas, without calling the functions under test. +oracleRates ts d dds = + interpolateWithHermite (d, zip (getTsDates ts) (map (fromRational . toRational) (getTsVals ts))) dds + +oraclePvAt :: Double -> T.Day -> T.Day -> Amount -> Amount +oraclePvAt r d dd amt = realToFrac $ (fromRational (toRational amt) :: Double) * (1 / ((1 + r) ** t)) + where + t = fromIntegral (T.diffDays dd d) / 365 :: Double + +oracleDurRates :: [Double] -> T.Day -> [(T.Day, Amount)] -> Double +oracleDurRates zs d ps = + let pvs = zipWith (\z (dd,amt) -> oraclePvAt z d dd amt) zs ps + total = sum pvs + in fromRational (sum [ divideBB pvi total * yearCountFraction DC_ACT_365F d dd | (pvi,(dd,_)) <- zip pvs ps ]) + +oracleConvRates :: [Double] -> T.Day -> [(T.Day, Amount)] -> Double +oracleConvRates zs d ps = + let pvs = zipWith (\z (dd,amt) -> oraclePvAt z d dd amt) zs ps + total = sum pvs + pvD = 1 / (fromRational (toRational total) :: Double) + tms = [ fromRational (yearCountFraction DC_ACT_365F d dd) | (dd,_) <- ps ] + pays = [ toRational a | (_,a) <- ps ] + in pvD * sum [ t*(t+1)*fromRational c / ((1+f)**(t+2)) | (t,c,f) <- zip3 tms pays zs ] + +oracleDur ts d ps = oracleDurRates (oracleRates ts d (map fst ps)) d ps +oracleConv ts d ps = oracleConvRates (oracleRates ts d (map fst ps)) d ps + +near :: Double -> Double -> Bool +near a b = abs (a - b) < 1e-9 + walTest = let _ps = [(50,L.toDate "20230630"),(50,L.toDate "20231231")] @@ -30,6 +66,14 @@ walTest = assertEqual "" 0.74 (calcWAL ByYear 100 (L.toDate "20230101") _ps ) + ,testCase "WAL by Quarter" $ + assertEqual "" + 2.98 + (calcWAL ByQuarter 100 (L.toDate "20230101") _ps ) + ,testCase "WAL by Quarter uses 91-day quarters" $ + assertEqual "a single cashflow 91 days out has WAL 1.0" + 1.00 + (calcWAL ByQuarter 100 (L.toDate "20230101") [(100,T.addDays 91 (L.toDate "20230101"))] ) ] hermiteTest = @@ -37,17 +81,127 @@ hermiteTest = testCase "single yield point does not crash" $ assertEqual "one point returns that yield" [1.0] - (interpolateWithHermite (L.toDate "20230101", [(L.toDate "20230101", 1.0)]) [L.toDate "20230101"]) + (interpolateWithHermite (d0, [(d0, 1.0)]) [d0]) ,testCase "empty yield curve does not crash" $ assertEqual "no points returns zeros" [0.0] - (interpolateWithHermite (L.toDate "20230101", []) [L.toDate "20230101"]) + (interpolateWithHermite (d0, []) [d0]) + ,testCase "short curves work across multiple query dates" $ + assertEqual "singleton is constant and empty is zero" + ([1.0, 1.0, 1.0], [0.0, 0.0, 0.0]) + ( interpolateWithHermite (d0, [(d0, 1.0)]) queryDates + , interpolateWithHermite (d0, []) queryDates ) ,testCase "two yield points still interpolate" $ assertBool "interior point yields a value between the two yields" $ - case interpolateWithHermite (L.toDate "20230101", [(L.toDate "20230101", 1.0),(L.toDate "20240101", 2.0)]) [L.toDate "20230701"] of + case interpolateWithHermite (d0, [(d0, 1.0),(d1, 2.0)]) [L.toDate "20230701"] of + [v] -> v > 1.0 && v < 2.0 + _ -> False + ,testCase "multi-point curve reproduces non-terminal node values" $ + let ds = [d0, d1, d2, L.toDate "20260101"] + ys = [1.0, 2.0, 4.0, 8.0] + got = interpolateWithHermite (d0, zip ds ys) [d0, d1, d2] + in assertBool "each non-terminal node returns its input yield" $ + length got == 3 && and (zipWith (\a b -> abs (a - b) < 1e-9) got [1.0, 2.0, 4.0]) + ,testCase "three yield points interpolate between adjacent nodes" $ + assertBool "interior point stays between adjacent yields" $ + case interpolateWithHermite (d0, [(d0, 1.0), (d1, 2.0), (d2, 4.0)]) [L.toDate "20230701"] of [v] -> v > 1.0 && v < 2.0 _ -> False + ,testCase "pv4 supports a single-point pricing curve" $ + assertEqual "single point behaves like a flat 5% curve" + (Right (pv2 0.05 d0 d1 100)) + (pv4 (d0, L.mkRateTs [(d0, 0.05)]) [(d1, 100)]) + ,testCase "pv4 rejects an empty cashflow list" $ + assertEqual "no cashflows returns Left" + (Left "pv4: No cashflow to get present value") + (pv4 (d0, L.mkRateTs [(d0, 0.05)]) []) + ,testCase "pv4 rejects an empty pricing curve" $ + assertBool "empty curve returns Left instead of throwing" + (isLeft (pv4 (d0, L.mkRateTs []) [(d1, 100)])) + ,testCase "pv4 rejects a curve starting before the pricing date" $ + assertEqual "Left names the first curve date" + (Left "pv4: cashflow date 2023-01-01 is before pricing date 2023-06-01") + (pv4 (L.toDate "20230601", L.mkRateTs [(d0, 0.05)]) [(d1, 100)]) + ,testCase "pv4 rejects a cashflow before the pricing date" $ + assertEqual "Left names the cashflow date" + (Left "pv4: cashflow date 2023-01-01 is before pricing date 2023-06-01") + (pv4 (L.toDate "20230601", L.mkRateTs [(L.toDate "20230601", 0.05)]) [(d0, 100)]) + ,testCase "query exactly at the last node returns its yield (issue #359; was: interpolate throws)" $ + assertEqual "terminal node returns the node yield" + [4.0] + (interpolateWithHermite (d0, [(d0, 1.0), (d1, 2.0), (d2, 4.0)]) [d2]) + ,testCase "query beyond the last node holds the last yield (issue #359)" $ + assertEqual "one year past the curve end is flat at the last yield" + [4.0] + (interpolateWithHermite (d0, [(d0, 1.0), (d1, 2.0), (d2, 4.0)]) [T.addDays 365 d2]) + ,testCase "pv4 prices a cashflow dated exactly at the last curve node (issue #359)" $ + assertEqual "3-point curve reaches an exact terminal-node cashflow like a flat 5% curve" + (Right (pv2 0.05 d0 d2 1000)) + (pv4 (d0, L.mkRateTs [(d0, 0.05), (d1, 0.05), (d2, 0.05)]) [(d2, 1000)]) + ,testCase "pv4 prices a cashflow dated beyond the last curve node (issue #359)" $ + assertEqual "cashflow past the curve end discounts off the last yield (flat 5%)" + (Right (pv2 0.05 d0 (T.addDays 365 d2) 1000)) + (pv4 (d0, L.mkRateTs [(d0, 0.05), (d1, 0.05), (d2, 0.05)]) [(T.addDays 365 d2, 1000)]) + ,testCase "pv4 accepts a curve that starts at the first cashflow (issue #359 follow-up #2)" $ + assertEqual "coverage from the first cashflow is enough; the node rate is exact" + (Right (pv2 0.05 (L.toDate "20230601") d1 1000)) + (pv4 (L.toDate "20230601", L.mkRateTs [(d1, 0.05), (d2, 0.06)]) [(d1, 1000)]) + ,testCase "pv4 rejects a cashflow before the pricing-curve start (issue #359 follow-up #2)" $ + assertEqual "Left names the first cashflow and the curve start" + (Left "pv4: first cashflow date 2023-06-01 is before pricing curve start 2024-01-01") + (pv4 (d0, L.mkRateTs [(d1, 0.05), (d2, 0.06)]) [(L.toDate "20230601", 1000)]) + ,testCase "pv4 keeps the single-point flat-rate curve for a pre-node cashflow (issue #359 follow-up #2)" $ + assertEqual "a one-point curve is a flat rate everywhere" + (Right (pv2 0.05 d0 (L.toDate "20230601") 1000)) + (pv4 (d0, L.mkRateTs [(d1, 0.05)]) [(L.toDate "20230601", 1000)]) + ,testCase "pv uses the same curve as pv4 (single-cashflow parity)" $ + let cases = [ (L.mkRateTs [(d0,0.02),(d1,0.04),(d2,0.05)], L.toDate "20240601") + , (L.mkRateTs [(d0,0.02),(d1,0.04),(d2,0.05)], L.toDate "20250101") + , (L.mkRateTs [(d0,0.05),(d2,0.05)], L.toDate "20250601") + , (L.mkRateTs [(d0,0.05)], L.toDate "20230701") ] + in mapM_ (\(c,dd) -> assertEqual ("pv vs pv4 at " ++ show dd) + (pv4 (d0, c) [(dd, 1000)]) (Right (pv c d0 dd 1000))) cases + ,testCase "pv3 equals the sum of pv over its cashflows" $ + let c = L.mkRateTs [(d0,0.02),(d1,0.04),(d2,0.05),(T.addDays 365 d2,0.045)] + ds = [d1,d2,T.addDays 365 d2] + amts = [50,50,1050] + in assertEqual "pv3 = sum of pv" + (sum [pv c d0 dd amt | (dd,amt) <- zip ds amts]) (pv3 c d0 ds amts) + ,testCase "pv matches an independent Hermite oracle" $ + let c = L.mkRateTs [(d0,0.02),(d1,0.04),(d2,0.05),(T.addDays 365 d2,0.045)] + dd = L.toDate "20240601" + in case oracleRates c d0 [dd] of + [z] -> assertEqual "pv uses the Hermite rate" (oraclePvAt z d0 dd 1000) (pv c d0 dd 1000) + _ -> assertFailure "oracle rate lookup" + ,testCase "pv on a single-point curve before the node uses the node rate" $ + let c = L.mkRateTs [(d1,0.05)] + dd = L.toDate "20230601" + in assertEqual "single-point curve extends left" (oraclePvAt 0.05 d0 dd 1000) (pv c d0 dd 1000) + ,testCase "flat curve pv matches the constant-rate pv2" $ + let c = L.mkRateTs [(d0,0.05),(d2,0.05)] + dd = L.toDate "20240601" + in assertEqual "flat curve = constant rate" (pv2 0.05 d0 dd 1000) (pv c d0 dd 1000) + ,testCase "pv4 returns Left for unsupported curve types" $ + do assertEqual "ThresholdCurve" + (Left "pv4: unsupported pricing curve type: ThresholdCurve") + (pv4 (d0, ThresholdCurve [TsPoint d1 0.02, TsPoint d2 0.05]) [(d1, 1000)]) + assertEqual "FactorCurveClosed" + (Left "pv4: unsupported pricing curve type: FactorCurveClosed") + (pv4 (d0, FactorCurveClosed [TsPoint d1 0.9, TsPoint d2 0.8] d2) [(d1, 1000)]) + ,testCase "pv4 accepts every supported Hermite curve type" $ + let expR = Right (pv2 0.05 d0 d1 1000) + cases = [ ("IRateCurve", L.mkRateTs [(d0,0.05),(d2,0.05)]) + , ("RatioCurve", RatioCurve [TsPoint d0 0.05, TsPoint d2 0.05]) + , ("FloatCurve", FloatCurve [TsPoint d0 0.05, TsPoint d2 0.05]) + , ("BalanceCurve", BalanceCurve [TsPoint d0 0.05, TsPoint d2 0.05]) + , ("PricingCurve", PricingCurve [TsPoint d0 0.05, TsPoint d2 0.05]) ] + in mapM_ (\(n,c) -> assertEqual ("supported " ++ n) expR (pv4 (d0,c) [(d1,1000)])) cases ] + where + d0 = L.toDate "20230101" + d1 = L.toDate "20240101" + d2 = L.toDate "20250101" + queryDates = L.toDates ["20230101", "20230701", "20240101"] durationTest = testGroup "Duration Test" @@ -84,7 +238,70 @@ durationTest = (L.toDate "20230101") [(L.toDate "20231231",104)] (L.mkRateTs [(L.toDate "20230101",0.05)])) + , testCase "multi-point curve metrics follow the Hermite PV curve" $ + let c = L.mkRateTs [(d0,0.02),(d1,0.04),(d2,0.05),(T.addDays 365 d2,0.045)] + ps = [(d1,50),(d2,50),(T.addDays 365 d2,1050)] + in do + assertEqual "duration on the PV curve" 2.863001 + (fromRational (calcDuration DC_ACT_365F d0 ps c) :: Micro) + assertEqual "convexity sums all cashflows on the PV curve" 10.323628 + (fromRational (calcConvexity DC_ACT_365F d0 ps c) :: Micro) + , testCase "convexity sums every cashflow (2-CF)" $ + let c = L.mkRateTs [(d0,0.02),(d1,0.04),(d2,0.05),(T.addDays 365 d2,0.045)] + in assertEqual "both cashflow terms are included" 3.599626 + (fromRational (calcConvexity DC_ACT_365F d0 [(d1,50),(d2,50)] c) :: Micro) + , testCase "node-date cashflows use the node rate" $ + let c = L.mkRateTs [(d0,0.02),(d1,0.04),(d2,0.05)] + ps = [(d1,100),(d2,1100)] + in do + assertBool "duration uses the node rate, not the previous node" + (near (fromRational (calcDuration DC_ACT_365F d0 ps c)) (oracleDur c d0 ps)) + assertBool "convexity uses the node rate too" + (near (fromRational (calcConvexity DC_ACT_365F d0 ps c)) (oracleConv c d0 ps)) + , testCase "flat multi-point curve matches a single-point curve" $ + let ps = [(d1,50),(d2,1050)] + cFlat = L.mkRateTs [(d0,0.05),(d2,0.05)] + cOne = L.mkRateTs [(d0,0.05)] + in do + assertEqual "duration parity" (calcDuration DC_ACT_365F d0 ps cOne) (calcDuration DC_ACT_365F d0 ps cFlat) + assertEqual "convexity parity" (calcConvexity DC_ACT_365F d0 ps cOne) (calcConvexity DC_ACT_365F d0 ps cFlat) + , testCase "duplicate-date flat curve behaves like a single point" $ + let ps = [(d1,50),(d2,1050)] + cDup = L.mkRateTs [(d0,0.05),(d0,0.05)] + cOne = L.mkRateTs [(d0,0.05)] + in assertEqual "MakeWhole-style [d,d] curve" + (calcDuration DC_ACT_365F d0 ps cOne) (calcDuration DC_ACT_365F d0 ps cDup) + , testCase "empty curve keeps the zero-rate fallback" $ + let ps = [(d1,50),(d2,1050)] + c = L.mkRateTs [] + in do + assertBool "duration at 0%" (near (fromRational (calcDuration DC_ACT_365F d0 ps c)) (oracleDur c d0 ps)) + assertBool "convexity at 0%" (near (fromRational (calcConvexity DC_ACT_365F d0 ps c)) (oracleConv c d0 ps)) + , testCase "curve starting after the valuation date uses the first node rate" $ + let c = L.mkRateTs [(d1,0.02),(d2,0.05)] + pd = L.toDate "20230601" + ps = [(L.toDate "20231001",100),(L.toDate "20240601",1100)] + in do + assertBool "metrics extend the first node rate to the left" + (near (fromRational (calcDuration DC_ACT_365F pd ps c)) (oracleDur c pd ps)) + assertBool "convexity same" + (near (fromRational (calcConvexity DC_ACT_365F pd ps c)) (oracleConv c pd ps)) + assertBool "pv4 still rejects an under-covered curve" + (isLeft (pv4 (pd, c) ps)) + , testCase "non-rate curve types fall back to getValByDate" $ + let c = ThresholdCurve [TsPoint d0 0.02, TsPoint d2 0.05] + ps = [(L.toDate "20230701",50),(L.toDate "20240601",1050)] + zs = map (fromRational . getValByDate c Exc . fst) ps + in do + assertBool "duration fallback" + (near (fromRational (calcDuration DC_ACT_365F d0 ps c)) (oracleDurRates zs d0 ps)) + assertBool "convexity fallback" + (near (fromRational (calcConvexity DC_ACT_365F d0 ps c)) (oracleConvRates zs d0 ps)) ] + where + d0 = L.toDate "20230101" + d1 = L.toDate "20240101" + d2 = L.toDate "20250101" fvTest = testGroup "FV Test" [ @@ -102,7 +319,7 @@ assetPricingTest = testGroup "Pricing on Asset" [ testCase "Loan Pricing(Inc Int)" $ assertEqual "Loan Pricing" - (Right (AssetPrice 1037.38 0.76 0.726208 0.0005369 0.21)) + (Right (AssetPrice 1037.38 0.76 0.72622 1.189754 0.21)) (priceAsset (PersonalLoan (LoanOriginalInfo 1200 (Fix DC_30_360_US 0.08) 12 Monthly (L.toDate "20240701") I_P Nothing) 1000 0.08 10 Current) (L.toDate "20241002") (PvRate 0.03) @@ -111,13 +328,20 @@ assetPricingTest = Inc) ,testCase "Loan Pricing(Exc Int)" $ assertEqual "Loan Pricing" - (Right (AssetPrice 1037.17 0.76 0.72633840 0.00052012 0.21)) + (Right (AssetPrice 1037.17 0.76 0.72635 1.189978 0.21)) (priceAsset (PersonalLoan (LoanOriginalInfo 1200 (Fix DC_30_360_US 0.08) 12 Monthly (L.toDate "20240701") I_P Nothing) 1000 0.08 10 Current) (L.toDate "20241002") (PvRate 0.03) (LoanAssump Nothing Nothing Nothing Nothing,DummyDelinqAssump,DummyDefaultAssump) Nothing Exc) + ,testCase "PVCurve on a flat curve matches PvRate pricing" $ + let loan = PersonalLoan (LoanOriginalInfo 1200 (Fix DC_30_360_US 0.08) 12 Monthly (L.toDate "20240701") I_P Nothing) 1000 0.08 10 Current + d = L.toDate "20241002" + assumps = (LoanAssump Nothing Nothing Nothing Nothing,DummyDelinqAssump,DummyDefaultAssump) + in assertEqual "asset PV curve path uses the same rates" + (priceAsset loan d (PvRate 0.03) assumps Nothing Inc) + (priceAsset loan d (PVCurve (L.mkRateTs [(d,0.03)])) assumps Nothing Inc) ] irrTest = diff --git a/test/UT/AssetTest.hs b/test/UT/AssetTest.hs index d7998f03..17e8130b 100644 --- a/test/UT/AssetTest.hs +++ b/test/UT/AssetTest.hs @@ -21,7 +21,9 @@ import qualified Assumptions as A import qualified Cashflow as CF import qualified Deal as D import Types +import qualified InterestRate as IR import Data.Either +import Data.List (isInfixOf) import InterestRate import Debug.Trace @@ -362,6 +364,17 @@ leaseTests = -- assertEqual "Month Gap by Table : New Lease at period 1" -- (CF.LeaseFlow (L.toDate "20240229") 306 29) -- ((cf5 ^. CF.cashflowTxn)!!8) + ,testCase "GapDaysByCurve with a non-int curve returns Left" $ + assertBool "error mentions IntCurve" $ + case Ast.projCashflow lease1 asofDate + (A.LeaseAssump Nothing + (A.GapDaysByCurve (L.BalanceCurve [L.TsPoint asofDate 10])) + (A.BaseAnnualRate 0.0) + (A.CutByDate (L.toDate "20240601")) + , A.DummyDelinqAssump, A.DummyDefaultAssump) + Nothing of + Left e -> "IntCurve" `isInfixOf` e + Right _ -> False ] installmentTest = @@ -521,6 +534,12 @@ armTest = assertEqual "life cap" (Just (CF.MortgageFlow (L.toDate "20250401") 91.24 12.65 0.77 0 0 0 0 0.09 Nothing Nothing (Just (148.76,0.00,0.00,0.00,0.00,0.00)))) (CF.cfAt arm1_cf 12) + -- regression tests for UseRate class completeness on an adjustable mortgage + ,testCase "UseRate on AdjustRateMortgage" $ + assertEqual "index/spread/reset on ARM" + (Just [SOFR3M], Just SOFR3M, True, Just 0.01, 8) + (IR.getIndexes arm1, IR.getIndex arm1, IR.isAdjustableRate arm1, IR.getSpread arm1 + ,length (IR.getResetDates arm1)) ] @@ -900,6 +919,11 @@ receivableTest = assertEqual "Defauted invoice " (Right (Just (CF.ReceivableFlow (L.toDate "20240501") 0 0 0 0 1500 0 1500.0 (Just (0.0,0.0,0.0,1500.0,0.0,1500.0))))) ((`CF.cfAt` 0) <$> (fst <$> Ast.projCashflow invoice0 (L.toDate "20240501") invoiceAssump Nothing)) + -- regression tests for Asset class completeness on Receivable + ,testCase "Asset getOriginBal/getOriginRate on Receivable" $ + assertEqual "origin balance / rate of a receivable" + (1500, 0) + (Ast.getOriginBal invoice1, Ast.getOriginRate invoice1) ] fixedAssetTest = @@ -992,6 +1016,11 @@ fixedAssetTest = -- in -- ((`CF.cfAt` 9) <$> (fst <$> (Ast.projCashflow asset2 (L.toDate "20240101") -- ((A.FixedAssetAssump utilCurve priceCurve Nothing) ,A.DummyDelinqAssump ,A.DummyDefaultAssump) Nothing)))) + -- regression tests for Asset class completeness on FixedAsset + ,testCase "Asset getOriginBal/getOriginRate on FixedAsset" $ + assertEqual "origin balance / rate of a fixed asset" + (11000, 0) + (Ast.getOriginBal asset, Ast.getOriginRate asset) ] buildRateSafetyTest = diff --git a/test/UT/BondTest.hs b/test/UT/BondTest.hs index e1acb661..a3482fcb 100644 --- a/test/UT/BondTest.hs +++ b/test/UT/BondTest.hs @@ -1,4 +1,4 @@ -module UT.BondTest(pricingTests,bndConsolTest,writeOffTest,accrueTest,selectorTest,walSafetyTest) +module UT.BondTest(pricingTests,bndConsolTest,writeOffTest,accrueTest,selectorTest,walSafetyTest,bondGroupSafetyTest) where import Test.Tasty @@ -20,6 +20,7 @@ import Util import Types import Data.Ratio import Interface +import qualified InterestRate as IR import Debug.Trace debug = flip trace @@ -94,7 +95,7 @@ pricingTests = testGroup "Pricing Tests" in testCase "flat rate discount " $ assertEqual "Test Pricing on case 01" - (Right (PriceResult 1979.54 65.984666 1.18 1.188138 0.491335 52.60 (DL.toList b1Txn))) + (Right (PriceResult 1979.54 65.984666 1.18 1.188138 2.524282 52.60 (DL.toList b1Txn))) pr , let @@ -114,7 +115,7 @@ pricingTests = testGroup "Pricing Tests" in testCase " discount curve with two rate points " $ assertEqual "Test Pricing on case 01" - (Right (PriceResult 4049.03 134.967666 0.44 0.364542 0.006193 286.42 (DL.toList b2Txn))) + (Right (PriceResult 4049.03 134.967666 0.44 0.364553 0.461079 286.42 (DL.toList b2Txn))) pr --TODO need to confirm in UI , let @@ -143,6 +144,24 @@ pricingTests = testGroup "Pricing Tests" (Right 0.176754) (B.calcZspread (100.0,pday) b6 rateCurve) --(B.calcZspread (500.0,pday) (103.0,1/100) Nothing rateCurve) + , + let + rateCurve5 = IRateCurve [ TsPoint (L.toDate "20220201") 0.02 + , TsPoint (L.toDate "20220315") 0.04 + , TsPoint (L.toDate "20220601") 0.05 + , TsPoint (L.toDate "20220815") 0.03 ] + pd5 = L.toDate "20220201" + s0 = 0.005 :: Double + shifted = shiftTsByAmt rateCurve5 (toRational s0) + in + testCase "Z spread round-trips the pricing curve" $ + case B.priceBond pd5 shifted b1 of + Left e -> assertFailure e + Right (PriceResult _ perFace _ _ _ _ _) -> + case B.calcZspread (toRational perFace, pd5) b1 rateCurve5 of + Left e -> assertFailure e + Right s -> assertBool ("solved spread " ++ show s ++ " should match " ++ show s0) + (abs (fromRational (toRational s) - s0) < 1e-4) ] @@ -255,6 +274,40 @@ accrueTest = -- assertEqual "accrue int on bond multiple times on diff dates" -- (B.bndDueInt (B.accrueInt (L.toDate "20210103") b1)) -- (B.bndDueInt (B.accrueInt (L.toDate "20210103") (B.accrueInt (L.toDate "20210102") b1))) + -- regression tests for UseRate/MultiIntLiable class completeness on bonds + ,testCase "UseRate on floating bond" $ + assertEqual "UseRate on floating bond" + (Just 0.015, Just LPR5Y, True, []) + (IR.getSpread bfloat, IR.getIndex bfloat, IR.isAdjustableRate bfloat, IR.getResetDates bfloat) + ,testCase "MultiIntLiable on bond" $ + let mIiB = B.MultiIntBond{B.bndName="M" + ,B.bndType=B.Sequential + ,B.bndOriginInfo=B.OriginalInfo{B.originBalance=3000 + ,B.originDate=L.toDate "20220101" + ,B.originRate=0.08 + ,B.maturityDate=Nothing} + ,B.bndInterestInfos=[B.Floater 0.02 LPR5Y 0.015 (MonthDayOfYear 1 1) DC_ACT_365F Nothing Nothing + ,B.Fix 0.08 DC_ACT_365F] + ,B.bndStepUps=Nothing + ,B.bndBalance=3000 + ,B.bndRates=[0.05,0.08] + ,B.bndDuePrin=0.0 + ,B.bndDueInts=[10,5] + ,B.bndDueIntOverInts=[1,0] + ,B.bndDueIntDate=Nothing + ,B.bndLastIntPays=Nothing + ,B.bndLastPrinPay=Nothing + ,B.bndStmt=Nothing} + in assertEqual "interest due by tranche index" + (0.0, 0, 10, 5, 1, 0, 11, 5) + (getDueIntAt bfloat 0 + ,getDueIntAt bfloat 1 + ,getDueIntAt mIiB 0 + ,getDueIntAt mIiB 1 + ,getDueIntOverIntAt mIiB 0 + ,getDueIntOverIntAt mIiB 1 + ,getTotalDueIntAt mIiB 0 + ,getTotalDueIntAt mIiB 1) ] selectorTest = @@ -326,3 +379,16 @@ walSafetyTest = testGroup "Bond WAL safety" ] +bondGroupSafetyTest = + let + d = L.toDate "20200101" + bg = B.BondGroup (Map.fromList [("A1",b1)]) Nothing + in + testGroup "bond group safety" [ + testCase "pay principal on a bond group returns Left" $ + assertBool "expected Left" (isLeft (pay d DuePrincipal 10 bg)) + , testCase "pay residual on a bond group returns Left" $ + assertBool "expected Left" (isLeft (pay d DueResidual 10 bg)) + , testCase "draw on a bond group returns Left" $ + assertBool "expected Left" (isLeft (draw d 10 S.Empty bg)) + ] diff --git a/test/UT/CeTest.hs b/test/UT/CeTest.hs index 128e226d..6f9e2bc7 100644 --- a/test/UT/CeTest.hs +++ b/test/UT/CeTest.hs @@ -13,6 +13,7 @@ import qualified Data.DList as DL import Types import CreditEnhancement import qualified InterestRate as IR +import qualified Interface as I @@ -66,4 +67,58 @@ liqTest = testGroup "Pricing Tests" ,SupportTxn (toDate "20220401") (ByAvailAmount 1000) 100 0.99 18.49 0 (LiquidationSupportInt 0.74 15.10) ]))) (liqStmt (accrueLiqProvider (toDate "20220401") liq1 )) + -- regression tests for Liable/Drawable/UseRate class completeness on LiqFacility + ,let + liqCeMethod = LiqFacility "LiqCeMethod" (FixSupport 1000) 100 (ByAvailAmount 800) Nothing (Just (IR.Fix DC_ACT_365 0.03)) (Just (IR.Fix DC_ACT_365 0.08)) + (Just 0.03) (Just 0.08) Nothing 0.25 3.39 (toDate "20220201") + Nothing Nothing + liqFloat = LiqFacility "LiqFloat" (FixSupport 1000) 100 (ByAvailAmount 500) Nothing + (Just (IR.Floater DC_ACT_365F LIBOR6M 0.01 0.03 MonthEnd Nothing Nothing Nothing)) Nothing + (Just 0.03) Nothing (Just (toDate "20220131")) 0 0 (toDate "20220101") + (Just (toDate "20221231")) Nothing + in + testGroup "Class-method completeness on LiqFacility" + [ + testCase "Liable & Drawable on LiqFacility" $ + assertEqual "class methods on liquidity facility" + (False, 100, 0.25, 0, (0.25+3.39), 0.03, (100+0.25+3.39) + ,(toDate "20220201"), (toDate "20220201"), (ByAvailAmount 800)) + (I.isPaidOff liqCeMethod + ,I.getCurBalance liqCeMethod + ,I.getDueInt liqCeMethod + ,I.getDueIntOverInt liqCeMethod + ,I.getTotalDueInt liqCeMethod + ,I.getCurRate liqCeMethod + ,I.getOutstandingAmount liqCeMethod + ,I.getOriginDate liqCeMethod + ,I.getAccrueBegDate liqCeMethod + ,I.availForDraw (toDate "20220301") liqCeMethod) + ,testCase "UseRate on LiqFacility" $ + assertEqual "UseRate on liquidity facility" + (Nothing, Nothing, False, [], Just 0.01, Just [LIBOR6M], Just LIBOR6M, True, 12) + (IR.getIndexes liqCeMethod + ,IR.getSpread liqCeMethod + ,IR.isAdjustableRate liqCeMethod + ,IR.getResetDates liqCeMethod + ,IR.getSpread liqFloat + ,IR.getIndexes liqFloat + ,IR.getIndex liqFloat + ,IR.isAdjustableRate liqFloat + ,length (IR.getResetDates liqFloat)) + ] + -- regression tests for UseRate class completeness on CreditDefaultSwap + ,let + cds = CDS "Cds0" (Just QuarterEnd) CurrentBondBalance 0 Nothing + CurrentBondBalance 0.03 + (IR.Floater DC_ACT_365F LIBOR6M 0.01 0.03 MonthEnd Nothing Nothing Nothing) + 0 Nothing Nothing Nothing (-10) (toDate "20220101") (Just (toDate "20221231")) Nothing + in + testGroup "Class-method completeness on CreditDefaultSwap" + [ + testCase "UseRate on CreditDefaultSwap" $ + assertEqual "UseRate on CDS" + (Just LIBOR6M, Just [LIBOR6M], True, Just 0.01, 12) + (IR.getIndex cds, IR.getIndexes cds, IR.isAdjustableRate cds, IR.getSpread cds + ,length (IR.getResetDates cds)) + ] ] diff --git a/test/UT/DealTest.hs b/test/UT/DealTest.hs index 16201267..32b33ec4 100644 --- a/test/UT/DealTest.hs +++ b/test/UT/DealTest.hs @@ -6,7 +6,7 @@ where import Test.Tasty import Test.Tasty.HUnit import Deal -import Deal.DealQuery (queryCompound) +import Deal.DealQuery (queryCompound, calcBondTargetBalance) import Deal.DealValidation (validatePreRun) import qualified Accounts as A @@ -306,6 +306,16 @@ queryTests = testGroup "deal stat query Tests" in testCase "query current assets in defaulted status" $ assertEqual "should be 200" (Right 200) currentDefBal + ,let + bA = fromJust (Map.lookup "A" (D.bonds td2)) + badBond = bA { L.bndType = L.PAC (IRateCurve [TsPoint (toDate "20220101") 0.05]) } + badDeal = td2 { D.bonds = Map.insert "A" badBond (D.bonds td2) } + in + testCase "PAC target with a non-balance curve returns Left" $ + assertBool "error mentions BalanceCurve" $ + case calcBondTargetBalance badDeal D.defaultRunContext (toDate "20220101") badBond of + Left e -> "BalanceCurve" `isInfixOf` e + Right _ -> False ] triggerTests = testGroup "Trigger Tests" diff --git a/test/UT/ExpTest.hs b/test/UT/ExpTest.hs index dccae3ba..b4721d7d 100644 --- a/test/UT/ExpTest.hs +++ b/test/UT/ExpTest.hs @@ -15,8 +15,10 @@ import qualified UT.DealTest as DT import Expense import Types import Interface +import qualified InterestRate as IR import Deal.DealBase import qualified Cashflow as CF +import Data.List (isInfixOf) import Debug.Trace debug = flip trace @@ -61,7 +63,16 @@ expTests = testGroup "Expense Tests" in testCase "test on Custom Fee Type" $ assertEqual "calc Due Fee" (Right [f1_ , f2_ , f3_ , _f1WithDue]) feesCalc - + , + let + fBad = Fee "FeeNameBad" (FeeFlow (L.IRateCurve [L.TsPoint (L.toDate "20220101") 0.05])) (L.toDate "20210101") 0 Nothing 0 Nothing Nothing + ctx = defaultRunContext + in + testCase "FeeFlow with a non-balance curve returns Left" $ + assertBool "error mentions BalanceCurve" $ + case DA.calcDueFee DT.td2 ctx (L.toDate "20220321") fBad of + Left e -> "BalanceCurve" `isInfixOf` e + Right _ -> False ] expPayTest = @@ -121,4 +132,32 @@ expPayTest = assertEqual "test query dueBal" (Right 40) (getDueBal epocDate Nothing <$> f3'') + -- regression tests for Liable/Accruable/UseRate class completeness on Fee + ,let + f = Fee "FeeClassMethods" (RecurFee MonthFirst 50) (L.toDate "20220101") 60 (Just (L.toDate "20220310")) 5 Nothing Nothing + fBooked = bookAccrual (L.toDate "20220201") 10.0 f + in + testGroup "Class-method completeness on Fee" + [ + testCase "Liable on Fee" $ + assertEqual "class methods on fee" + (60.0, 65.0, 0, 0, 0 + ,(L.toDate "20220101"), (L.toDate "20220101"), 65.0) + (getDueInt f + ,getTotalDueInt f + ,getCurBalance f + ,getCurRate f + ,getDueIntOverInt f + ,getOriginDate f + ,getAccrueBegDate f + ,getOutstandingAmount f) + ,testCase "Accruable on Fee" $ + assertEqual "accrual bookkeeping on fee" + (70.0, Just (L.toDate "20220201"), f) + (feeDue fBooked, feeDueDate fBooked, accrueTo (L.toDate "20220301") f) + ,testCase "UseRate on Fee" $ + assertEqual "UseRate on fee" + (Nothing, Nothing, False, []) + (IR.getIndexes f, IR.getSpread f, IR.isAdjustableRate f, IR.getResetDates f) + ] ] diff --git a/test/UT/LibTest.hs b/test/UT/LibTest.hs index d85d5116..76b611ac 100644 --- a/test/UT/LibTest.hs +++ b/test/UT/LibTest.hs @@ -19,6 +19,8 @@ import Util import Stmt import DateUtil import Data.Ratio +import Data.List (isInfixOf, sortOn) +import Data.Fixed (Fixed(MkFixed)) curveTests = let @@ -147,6 +149,28 @@ datesTests = testGroup "date related " assertEqual "annual->weekly" 1 (periodRateFromAnnualRate Weekly 52.143) ] +-- | The pre-optimization implementation, kept as an oracle for the IntSet +-- membership change. +legacyProrataFactors :: [Balance] -> Balance -> [Balance] +legacyProrataFactors bals amt + | totalCents <= 0 = replicate (length bals) 0 + | otherwise = map (toEnum . fromInteger) $ zipWith (+) baseAdds extraCents + where + centList = max 0 . 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 (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] ] + +assertProrataGrid :: String -> [[Balance]] -> [Balance] -> IO () +assertProrataGrid label balss amts = + mapM_ (\bs -> mapM_ (\a -> + assertEqual (label ++ ": " ++ show bs ++ " / " ++ show a) + (legacyProrataFactors bs a) (prorataFactors bs a)) amts) balss + prorataTests = testGroup "prorata Test" [ let @@ -200,6 +224,68 @@ prorataTests = testGroup "prorata Test" assertEqual "" [0,0] (prorataFactors [-10, -20] 30) + , + let + curatedBalances :: [[Balance]] + curatedBalances = + [ [] + , [0] + , [1] + , [0.01] + , [100,200,300] + , [100,200,0] + , [100,-50,100] + , [-10,-20] + , [0,0] + , [1,1,1] + , [0.01,0.01,0.01] + , [0.01,0.02,0.03] + , replicate 12 0.01 + , [100,100,100] + ] + curatedAmounts :: [Balance] + curatedAmounts = [0, 0.01, 0.10, 1, 2, 40, 60, 100, 1000, -1] + + generatedBalances :: [[Balance]] + generatedBalances = + [ [ MkFixed (toInteger ((i * 37 + j) `mod` 500)) | i <- [0 .. n - 1] ] + | (j, n) <- [(0,0), (1,1), (2,3), (3,7), (5,13), (11,31)] + ] + generatedAmounts :: [Balance] + generatedAmounts = [ MkFixed (toInteger a) | a <- [0, 1, 2, 7, 50, 123, 1000] ] + in + testGroup "IntSet membership equivalence and edge cases" + [ testCase "matches the legacy elem oracle on a curated grid" $ + assertProrataGrid "curated" curatedBalances curatedAmounts + , testCase "matches the legacy elem oracle on a generated grid" $ + assertProrataGrid "generated" generatedBalances generatedAmounts + , testCase "matches the legacy oracle on a large list" $ + let + balsL = [ MkFixed (toInteger ((i * 17) `mod` 10000 + 1)) | i <- [0..1999] ] :: [Balance] + totalL = sum balsL + amtL = MkFixed (toInteger (fromEnum totalL `div` 3)) + allocL = prorataFactors balsL amtL + in do + assertEqual "legacy match" (legacyProrataFactors balsL amtL) allocL + assertEqual "length" 2000 (length allocL) + assertEqual "sum preserved" amtL (sum allocL) + assertBool "non-negative" (all (>= 0) allocL) + , testCase "empty balances" $ + assertEqual "empty" ([] :: [Balance]) (prorataFactors [] 100) + , testCase "single balance" $ do + assertEqual "exact amount" [40] (prorataFactors [100] 40) + assertEqual "capped amount" [100] (prorataFactors [100] 500) + , testCase "zero amount gives zeros" $ + assertEqual "zeros" [0,0,0] (prorataFactors [1,2,3] 0) + , testCase "negative amount gives zeros" $ + assertEqual "zeros" [0,0] (prorataFactors [1,2] (-1)) + , testCase "amount equal to total is fully allocated" $ + assertEqual "all" [100,200] (prorataFactors [100,200] 300) + , testCase "residual tie goes to first indices" $ + assertEqual "two cents" [0.01,0.01,0.00] (prorataFactors [0.01,0.01,0.01] 0.02) + , testCase "residual goes to the largest remainder" $ + assertEqual "largest" [0.00,0.00,0.01] (prorataFactors [0.01,0.02,0.03] 0.01) + ] ] tsOperationTests = @@ -224,11 +310,41 @@ tsOperationTests = (BalanceCurve [TsPoint (toDate "20221101") 100,TsPoint (toDate "20221201") 50] ,(BalanceCurve [])) $ splitTsByDate bcurve (toDate "20221202") - ,testCase "split ts by date on left 3" $ + ,testCase "split ts by date on left 3" $ assertEqual " split on out of scope" (BalanceCurve [TsPoint (toDate "20221101") 100] ,BalanceCurve [TsPoint (toDate "20221201") 50]) $ splitTsByDate bcurve (toDate "20221101") + ,testCase "getValOnByDate keeps working for a balance curve" $ + assertEqual "value on date" 100 (getValOnByDate bcurve (toDate "20221115")) + ,testCase "tryGetValOnByDate rejects a non-balance curve" $ + assertBool "error names both curves" $ + case tryGetValOnByDate (IRateCurve [TsPoint (toDate "20221101") 0.05]) (toDate "20221115") of + Left e -> "BalanceCurve" `isInfixOf` e && "IRateCurve" `isInfixOf` e + Right _ -> False + ,testCase "tryGetIntValOnByDate reads an int curve" $ + assertEqual "int value" (Right 7) $ + tryGetIntValOnByDate (IntCurve [TsPoint (toDate "20221101") 7]) (toDate "20221115") + ,testCase "tryGetIntValOnByDate rejects a balance curve" $ + assertBool "error mentions IntCurve" $ + either (isInfixOf "IntCurve") (const False) (tryGetIntValOnByDate bcurve (toDate "20221115")) + ,testCase "trySplitTsByDate rejects a non-balance curve" $ + assertBool "error mentions BalanceCurve" $ + either (isInfixOf "BalanceCurve") (const False) (trySplitTsByDate (FloatCurve []) (toDate "20221115")) + ,testCase "trySumValTs sums a balance curve" $ + assertEqual "sum" (Right 150) (trySumValTs bcurve) + ,testCase "trySumValTs rejects a non-balance curve" $ + assertBool "error mentions BalanceCurve" $ + either (isInfixOf "BalanceCurve") (const False) (trySumValTs (IRateCurve [])) + ,testCase "subTsBetweenDates with no bounds returns the curve" $ + assertEqual "unchanged" bcurve (subTsBetweenDates bcurve Nothing Nothing) + ,testCase "subTsBetweenDates filters both bounds" $ + assertEqual "only middle point" + (BalanceCurve [TsPoint (toDate "20221201") 50]) + (subTsBetweenDates bcurve (Just (toDate "20221110")) (Just (toDate "20221202"))) + ,testCase "trySubTsBetweenDates rejects a non-balance curve" $ + assertBool "error mentions BalanceCurve" $ + either (isInfixOf "BalanceCurve") (const False) (trySubTsBetweenDates (BoolCurve []) Nothing Nothing) ] pvTests = diff --git a/test/UT/RateHedgeTest.hs b/test/UT/RateHedgeTest.hs index 67fc0765..778cba92 100644 --- a/test/UT/RateHedgeTest.hs +++ b/test/UT/RateHedgeTest.hs @@ -14,7 +14,9 @@ import Data.Ratio import UT.DealTest (td2) import Deal.DealBase as D -import Hedge (RateSwap(..),RateCap(..),RateSwapBase(..),rcNetCash) +import Hedge (RateSwap(..),RateCap(..),RateSwapType(..),RateSwapBase(..),SRT(..),SrtType(..),rcNetCash) +import qualified InterestRate as IR +import qualified Interface as I capRateTests = let @@ -41,4 +43,68 @@ capRateTests = assertEqual "netCash" (Right 5.0) (rcNetCash <$> rc1) + -- regression tests for Liable/UseRate class completeness on RateSwap/SRT/RateCap + ,let + rs = RateSwap{rsType = FloatingToFixed (LIBOR6M,0.01) 0.05 + ,rsDayCount = DC_ACT_365F + ,rsSettleDates = Nothing + ,rsUpdateDates = MonthEnd + ,rsNotional = Fixed 1000 + ,rsRefBalance = 1000 + ,rsPayingRate = 0.05 + ,rsReceivingRate = 0.03 + ,rsNetCash = -50.0 + ,rsStartDate = Lib.toDate "20220101" + ,rsLastStlDate = Nothing + ,rsStmt = Nothing} + srt = SRT "Srt0" (SrtByEndDay CurrentBondBalance MonthEnd) (IR.Fix DC_ACT_365 0.03) + 80 0.03 100 Nothing 1.5 (Lib.toDate "20220101") Nothing Nothing + in + testGroup "Class-method completeness on hedge instruments" + [ + testCase "Liable on RateSwap" $ + assertEqual "class methods on rate swap" + (False, 50, 50, 0, 0, 0, 0.05, (Lib.toDate "20220101"), (Lib.toDate "20220101")) + (I.isPaidOff rs + ,I.getCurBalance rs + ,I.getOutstandingAmount rs + ,I.getOriginBalance rs + ,I.getDueInt rs + ,I.getDueIntOverInt rs + ,I.getCurRate rs + ,I.getOriginDate rs + ,I.getAccrueBegDate rs) + ,testCase "Liable on SRT" $ + assertEqual "class methods on SRT" + (False, 100, 100, 0.03, 1.5, 0, 1.5, 101.5, (Lib.toDate "20220101"), (Lib.toDate "20220101")) + (I.isPaidOff srt + ,I.getCurBalance srt + ,I.getOriginBalance srt + ,I.getCurRate srt + ,I.getDueInt srt + ,I.getDueIntOverInt srt + ,I.getTotalDueInt srt + ,I.getOutstandingAmount srt + ,I.getOriginDate srt + ,I.getAccrueBegDate srt) + ,testCase "UseRate on RateSwap & SRT & RateCap" $ + assertEqual "UseRate on hedge instruments" + (Just LIBOR6M, Just [LIBOR6M], Just 0.01, True + ,Nothing, Nothing, False + ,Just LIBOR6M, Just [LIBOR6M], True) + (IR.getIndex rs + ,IR.getIndexes rs + ,IR.getSpread rs + ,IR.isAdjustableRate rs + ,IR.getIndex srt + ,IR.getSpread srt + ,IR.isAdjustableRate srt + ,IR.getIndex rc + ,IR.getIndexes rc + ,IR.isAdjustableRate rc) + ,testCase "getSpread of a floating SRT" $ + assertEqual "spread from SRT premium rate type" + (Just 0.01) + (IR.getSpread (srt{srtPremiumType = IR.Floater DC_ACT_365F LIBOR6M 0.01 0.03 MonthEnd Nothing Nothing Nothing})) + ] ] diff --git a/test/UT/UtilTest.hs b/test/UT/UtilTest.hs index ebedd60d..5a5689e0 100644 --- a/test/UT/UtilTest.hs +++ b/test/UT/UtilTest.hs @@ -1,10 +1,11 @@ {-# LANGUAGE ScopedTypeVariables #-} module UT.UtilTest(daycountTests1,daycountTests2,daycountTests3,daycountTests4 - ,tsTest,ts2Test,ts3Test,dateVectorPatternTest,paddingTest,dateSliceTest + ,tsTest,ts2Test,ts3Test,curveLookupLegacyTest,dateVectorPatternTest,paddingTest,dateSliceTest ,capTest,roundingTest,sliceTest,splitTsTest,tableTest,lastOftest,paySeqTest ,scaleListTest,mapUpdateTest,boundedParMapTest,resolveWorkerCapTest,forceMapValuesTest - ,workerNumTest,serverConfigLimitTest,badRequestJSONTest)--,daycountTests3,daycountTests4) + ,workerNumTest,serverConfigLimitTest,badRequestJSONTest + ,moneyMathLegacyTest)--,daycountTests3,daycountTests4) where import Test.Tasty @@ -22,7 +23,7 @@ import Stmt import Data.Fixed import qualified Data.DList as DL import Data.Ratio ((%)) -import Control.Exception (ErrorCall(..), evaluate, try) +import Control.Exception (ArithException(..), ErrorCall(..), evaluate, try) import Network.HTTP.Types (hContentType) import Servant.Server (ServerError(..)) import qualified Data.ByteString.Lazy.Char8 as BL8 @@ -340,6 +341,121 @@ ts2Test = getValByDate testThresholdCurve Inc (toDate "20220310") ] +-- | Legacy reference for the plural lookup. The fast path must match this +-- exactly, including for descending/unsorted dates and unsorted curve points. +legacyGetValByDates :: Ts -> CutoffType -> [Date] -> [Rational] +legacyGetValByDates rc ct = map (getValByDate rc ct) + +assertCurveLookup :: String -> Ts -> CutoffType -> [[Date]] -> IO () +assertCurveLookup label curve ct dss = + mapM_ (\ds -> assertEqual (label ++ " / " ++ show ct ++ " / n=" ++ show (length ds)) + (legacyGetValByDates curve ct ds) + (getValByDates curve ct ds)) dss + +curveLookupLegacyTest :: TestTree +curveLookupLegacyTest = + let + d0 = toDate "20220101" + d1 = T.addDays 30 d0 + d2 = T.addDays 60 d0 + d3 = T.addDays 90 d0 + dBefore = T.addDays (-10) d0 + dAfter = T.addDays 200 d0 + + ratePts :: [TsPoint Rational] + ratePts = [ TsPoint d0 (1 % 100) + , TsPoint d1 (2 % 100) + , TsPoint d1 (25 % 1000) + , TsPoint d2 (3 % 100) + , TsPoint d3 (4 % 100) ] + + iratePts :: [TsPoint IRate] + iratePts = [ TsPoint d0 0.01 + , TsPoint d1 0.02 + , TsPoint d1 0.025 + , TsPoint d2 0.03 + , TsPoint d3 0.04 ] + + balPts :: [TsPoint Balance] + balPts = [ TsPoint d0 100 + , TsPoint d1 200 + , TsPoint d2 300 + , TsPoint d3 400 ] + + unsortedRatePts :: [TsPoint Rational] + unsortedRatePts = [TsPoint d2 (3 % 100), TsPoint d0 (1 % 100), TsPoint d1 (2 % 100)] + + unsortedIratePts :: [TsPoint IRate] + unsortedIratePts = [TsPoint d2 0.03, TsPoint d0 0.01, TsPoint d1 0.02] + + dateSets :: [[Date]] + dateSets = [ [] + , [d0] + , [dBefore] + , [dAfter] + , [d0, d1, d2, d3] + , [d0, d0, d1, d1, d2, d3, d3] + , [d1] + , [d1, d2] + , [d3, d2, d1, d0] + , [d1, d0, d2, d3] + , [dBefore, d0, d1, dAfter] + , [T.addDays (toInteger i) d0 | i <- [0..999]] + ] + + simpleCurves :: [(String, Ts)] + simpleCurves = + [ ("IRateCurve", IRateCurve iratePts) + , ("FloatCurve", FloatCurve ratePts) + , ("RatioCurve", RatioCurve ratePts) + , ("BalanceCurve", BalanceCurve balPts) + , ("LeftBalanceCurve", LeftBalanceCurve balPts) + ] + + emptyCurves :: [Ts] + emptyCurves = + [ IRateCurve [] + , FloatCurve [] + , RatioCurve [] + , BalanceCurve [] + , LeftBalanceCurve [] + , ThresholdCurve [] + ] + in + testGroup "getValByDates legacy compatibility" + [ testCase "ascending, duplicate, descending and unsorted dates" $ + mapM_ (\(name, c) -> do + assertCurveLookup name c Inc dateSets + assertCurveLookup name c Exc dateSets) simpleCurves + , testCase "unsorted curve points fall back exactly" $ + mapM_ (\(name, c) -> do + assertCurveLookup name c Inc dateSets + assertCurveLookup name c Exc dateSets) + [ ("IRateCurve-unsorted", IRateCurve unsortedIratePts) + , ("FloatCurve-unsorted", FloatCurve unsortedRatePts) + ] + , testCase "FactorCurveClosed matches the legacy lookup" $ do + assertCurveLookup "factor" (FactorCurveClosed ratePts d2) Exc dateSets + assertCurveLookup "factor-unsorted" (FactorCurveClosed unsortedRatePts d2) Exc dateSets + , testCase "ThresholdCurve falls back exactly" $ do + assertCurveLookup "threshold" (ThresholdCurve ratePts) Inc dateSets + assertCurveLookup "threshold" (ThresholdCurve ratePts) Exc dateSets + , testCase "PricingCurve falls back exactly" $ do + assertCurveLookup "pricing" (PricingCurve ratePts) Inc dateSets + assertCurveLookup "pricing" (PricingCurve ratePts) Exc dateSets + , testCase "empty curves" $ do + mapM_ (\c -> do + assertCurveLookup "empty" c Inc dateSets + assertCurveLookup "empty" c Exc dateSets) emptyCurves + assertCurveLookup "empty-factor" (FactorCurveClosed [] d2) Exc dateSets + assertCurveLookup "empty-pricing" (PricingCurve []) Inc dateSets + , testCase "empty dates always return []" $ do + mapM_ (\(name, c) -> do + assertEqual (name ++ " Inc") [] (getValByDates c Inc []) + assertEqual (name ++ " Exc") [] (getValByDates c Exc [])) simpleCurves + assertEqual "factor" [] (getValByDates (FactorCurveClosed ratePts d2) Exc []) + ] + -- ^ date pattern test dateVectorPatternTest = let @@ -524,6 +640,158 @@ roundingTest = (roundingBy (RoundFloor 5) 100) ] +-- | Pre-optimization reference implementations. The optimized helpers must +-- stay bit-for-bit identical to these, including the rounding direction of +-- 'Data.Fixed.fromRational' (floor, including for negatives). +legacyMulBR :: Balance -> Rate -> Balance +legacyMulBR b r = fromRational (toRational b * r) + +legacyMulBIR :: Balance -> IRate -> Balance +legacyMulBIR b r = fromRational (toRational b * toRational r) + +legacyDivideBI :: Balance -> Int -> Balance +legacyDivideBI b i = fromRational (toRational b / toRational i) + +legacyDivideBB :: Balance -> Balance -> Rational +legacyDivideBB b1 b2 = toRational b1 / toRational b2 + +legacyMulBInt :: Balance -> Int -> Rational +legacyMulBInt b i = toRational b * toRational i + +assertMoneyGrid :: (Show a, Show b, Eq c, Show c) + => String -> (a -> b -> c) -> (a -> b -> c) -> [a] -> [b] -> IO () +assertMoneyGrid label optimized legacy as bs = + mapM_ (\a -> mapM_ (\b -> + assertEqual (label ++ ": (" ++ show a ++ ", " ++ show b ++ ")") + (legacy a b) (optimized a b)) bs) as + +assertMoneyPairs :: (Show a, Show b, Eq c, Show c) + => String -> (a -> b -> c) -> (a -> b -> c) -> [(a,b)] -> IO () +assertMoneyPairs label optimized legacy pairs = + mapM_ (\(a,b) -> + assertEqual (label ++ ": " ++ show a ++ " / " ++ show b) + (legacy a b) (optimized a b)) pairs + +moneyMathLegacyTest :: TestTree +moneyMathLegacyTest = + let + balances :: [Balance] + balances = [0, 0.01, -0.01, 1, -1, 100, -100, 123.45, -123.45 + ,999999999.99, -999999999.99] + + rates :: [Rate] + rates = [0, 1, -1, 1 % 2, 1 % 3, 2 % 3, 1 % 7 + ,1 % 200, 3 % 200, -1 % 200, -3 % 200 + ,5 % 1000, 15 % 1000, 199 % 200, 17 % 200 + ,1 % 1000000, 123 % 1000, 1000000 % 3 + ,(10 ^ 18 + 1) % 10 ^ 18] + + iRates :: [IRate] + iRates = [0, 0.000001, -0.000001, 0.085, -0.085 + ,1, 1.5, 12.345678] + + divisors :: [Int] + divisors = [1, 2, 3, 7, 12, 365, 1000, -1, -3] + + intFactors :: [Int] + intFactors = [0, 1, -1, 2, 3, 7, 12, 365, -3] + + -- Deterministic sweep over many cents/rate/divisor combinations. This is + -- deliberately larger than the hand-picked edge cases above. + sweepBalances :: [Balance] + sweepBalances = [MkFixed (toInteger i * 37 - 5000) | i <- [0..100]] + + sweepRates :: [Rate] + sweepRates = [(toInteger i * 13 - 50) % (toInteger i * 7 + 1) | i <- [1..50]] + + sweepIRates :: [IRate] + sweepIRates = [MkFixed (toInteger i * 7919 - 100000) | i <- [0..50]] + + sweepDivisors :: [Int] + sweepDivisors = [i | i <- [-50..50], i /= 0] + in + testGroup "Money math legacy compatibility" + [ testGroup "mulBR" + [ testCase "matches the legacy fromRational oracle on a grid" $ + assertMoneyGrid "mulBR" mulBR legacyMulBR balances rates + , testCase "matches the legacy oracle over a deterministic sweep" $ + assertMoneyGrid "mulBR-sweep" mulBR legacyMulBR sweepBalances sweepRates + , testCase "floors half cents for both signs" $ do + assertEqual "positive half cent" 0.00 (mulBR 1.00 (1 % 200)) + assertEqual "positive 1.5 cents" 0.01 (mulBR 1.00 (3 % 200)) + assertEqual "negative half cent" (-0.01) (mulBR (-1.00) (1 % 200)) + assertEqual "negative 1.5 cents" (-0.02) (mulBR (-1.00) (3 % 200)) + assertEqual "positive 99.5 cents" 0.99 (mulBR 1.00 (199 % 200)) + assertEqual "negative 99.5 cents" (-1.00) (mulBR (-1.00) (199 % 200)) + , testCase "zero, identity and negation" $ do + assertEqual "zero rate" 0 (mulBR 123.45 0) + assertEqual "identity rate" 123.45 (mulBR 123.45 1) + assertEqual "negative identity" (-123.45) (mulBR 123.45 (-1)) + ] + , testGroup "mulBIR" + [ testCase "matches the legacy fromRational oracle on a grid" $ + assertMoneyGrid "mulBIR" mulBIR legacyMulBIR balances iRates + , testCase "matches the legacy oracle over a deterministic sweep" $ + assertMoneyGrid "mulBIR-sweep" mulBIR legacyMulBIR sweepBalances sweepIRates + , testCase "floors half cents for both signs" $ do + assertEqual "positive half cent" 0.00 (mulBIR 100.00 0.00005) + assertEqual "positive 1.5 cents" 0.01 (mulBIR 100.00 0.00015) + assertEqual "negative half cent" (-0.01) (mulBIR (-100.00) 0.00005) + assertEqual "negative 1.5 cents" (-0.02) (mulBIR (-100.00) 0.00015) + , testCase "zero and identity" $ do + assertEqual "zero rate" 0 (mulBIR 123.45 0) + assertEqual "identity rate" 123.45 (mulBIR 123.45 1) + ] + , testGroup "mulBI" + [ testCase "is the same operation as mulBIR" $ + assertMoneyGrid "mulBI" mulBI legacyMulBIR balances iRates + ] + , testGroup "divideBI" + [ testCase "matches the legacy fromRational oracle on a grid" $ + assertMoneyGrid "divideBI" divideBI legacyDivideBI balances divisors + , testCase "matches the legacy oracle over a deterministic sweep" $ + assertMoneyGrid "divideBI-sweep" divideBI legacyDivideBI sweepBalances sweepDivisors + , testCase "floors toward negative infinity" $ do + assertEqual "1.00 / 3" 0.33 (divideBI 1.00 3) + assertEqual "-1.00 / 3" (-0.34) (divideBI (-1.00) 3) + assertEqual "identity" 123.45 (divideBI 123.45 1) + , testCase "zero divisor preserves the legacy exception" $ do + r <- try (evaluate (divideBI 1.00 0)) :: IO (Either ArithException Balance) + case r of + Left RatioZeroDenominator -> pure () + Left e -> assertFailure ("unexpected exception: " ++ show e) + Right _ -> assertFailure "expected divideBI by zero to throw" + ] + , testGroup "divideBB" + [ testCase "matches the legacy Rational ratio oracle on a grid" $ + assertMoneyPairs "divideBB" divideBB legacyDivideBB + [(b1, b2) | b1 <- balances, b2 <- balances, b2 /= 0] + , testCase "matches the legacy oracle over a deterministic sweep" $ + assertMoneyPairs "divideBB-sweep" divideBB legacyDivideBB + [(b1, b2) | b1 <- take 31 sweepBalances, b2 <- take 31 sweepBalances, b2 /= 0] + , testCase "exact ratios" $ do + assertEqual "1.00 / 0.03" (100 % 3) (divideBB 1.00 0.03) + assertEqual "-1.00 / 0.03" (-100 % 3) (divideBB (-1.00) 0.03) + assertEqual "same balance" 1 (divideBB 123.45 123.45) + , testCase "zero denominator preserves the legacy exception" $ do + r <- try (evaluate (divideBB 1.00 0.00)) :: IO (Either ArithException Rational) + case r of + Left RatioZeroDenominator -> pure () + Left e -> assertFailure ("unexpected exception: " ++ show e) + Right _ -> assertFailure "expected divideBB by zero to throw" + ] + , testGroup "splitBal" + [ testCase "uses the legacy mulBR for both legs" $ + mapM_ (\b -> mapM_ (\r -> + assertEqual ("splitBal " ++ show b ++ " " ++ show r) + (legacyMulBR b r, legacyMulBR b (1 - r)) (splitBal r b)) rates) balances + ] + , testGroup "mulBInt" + [ testCase "matches the legacy Rational oracle on a grid" $ + assertMoneyGrid "mulBInt" mulBInt legacyMulBInt balances intFactors + ] + ] + sliceTest = testGroup "sliceTest" [ testCase "slice 1" $