From 36cad37423ac3f2e62268fc7ee9cc9f3804c51c2 Mon Sep 17 00:00:00 2001 From: Graeme Geldenhuys Date: Sat, 20 Jun 2026 10:33:35 +0100 Subject: [PATCH] =?UTF-8?q?feat(stdlib):=20add=20Numerics.Money=20?= =?UTF-8?q?=E2=80=94=20currency-aware=20TMoney?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit TMoney is a thin value-type wrapper layering an ISO-4217 currency tag onto an exact TDecimal amount. The numeric core (TDecimal) stays currency- and locale-agnostic; currency policy lives entirely in this wrapper, matching Moneta / money-gem / rusty-money. Design: - Currency is an upper-cased ISO-4217 string code; the set is open (unknown codes are accepted at the fallback minor-unit scale of 2). - A built-in registry gives each currency its default scale (JPY 0, USD 2, KWD 3, fallback 2); every TMoney is normalised to its currency's scale on construction and after every operation, using banker's rounding. - Cross-currency Add/Subtract/Compare raise EMoneyMismatch (no implicit conversion); Equals is total (False, not raise, across currencies). - Immutable value semantics, mirroring TDecimal. API: free-function constructors (MoneyFromStr / MoneyFromDecimal / MoneyFromInt / MoneyZero), record methods (Amount, CurrencyCode, IsZero, Sign, Add, Subtract, Negate, Multiply, MultiplyInt, Compare, Equals, AmountString, ToString), and the CurrencyScale registry function. Tests: - cp.test.numerics.money.pas: 22 IR/semantic tests (resolution, IR shape, type errors) via TUnitLoader. - cp.test.e2e.numerics.money.pas: 24 dual-backend e2e tests (CompileAndRunWithRTL) covering construction + per-currency normalisation, banker's rounding, case-folding, arithmetic, mismatch raising, Compare/Equals/IsZero/Sign, the registry, and a realistic invoice flow. Docs: language-rationale.adoc gains "Currency Amounts — TMoney Wraps TDecimal, Currency Is a String Tag" (decision + alternatives); future-improvements.adoc marks Numerics.Money as implemented. Verified: FIXPOINT_OK, NATIVE_FIXPOINT_OK, NATIVE_INTERNAL_OK; full suite green on both the QBE-built and native-built runners (3671 tests). --- compiler/src/test/pascal/TestRunner.pas | 2 + .../pascal/cp.test.e2e.numerics.money.pas | 514 ++++++++++++++++++ .../test/pascal/cp.test.numerics.money.pas | 352 ++++++++++++ docs/future-improvements.adoc | 20 +- docs/language-rationale.adoc | 80 ++- stdlib/src/main/pascal/numerics.money.pas | 338 ++++++++++++ 6 files changed, 1288 insertions(+), 18 deletions(-) create mode 100644 compiler/src/test/pascal/cp.test.e2e.numerics.money.pas create mode 100644 compiler/src/test/pascal/cp.test.numerics.money.pas create mode 100644 stdlib/src/main/pascal/numerics.money.pas diff --git a/compiler/src/test/pascal/TestRunner.pas b/compiler/src/test/pascal/TestRunner.pas index f5353b1..2899a63 100644 --- a/compiler/src/test/pascal/TestRunner.pas +++ b/compiler/src/test/pascal/TestRunner.pas @@ -135,6 +135,8 @@ uses cp.test.e2e.math, cp.test.numerics.decimal, cp.test.e2e.numerics.decimal, + cp.test.numerics.money, + cp.test.e2e.numerics.money, cp.test.streams, cp.test.e2e.streams, cp.test.e2e.dateutils, diff --git a/compiler/src/test/pascal/cp.test.e2e.numerics.money.pas b/compiler/src/test/pascal/cp.test.e2e.numerics.money.pas new file mode 100644 index 0000000..ede67b7 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.e2e.numerics.money.pas @@ -0,0 +1,514 @@ +{ + Blaise - An Object Pascal Compiler + Copyright (c) 2026 Graeme Geldenhuys + SPDX-License-Identifier: Apache-2.0 WITH Swift-exception + Licensed under the Apache License v2.0 with Runtime Library Exception. + See LICENSE file in the project root for full license terms. +} + +unit cp.test.e2e.numerics.money; + +{ E2E tests for the Numerics.Money stdlib unit (TMoney). + + These compile -> assemble -> link -> run real programs that use TMoney and + assert on stdout/exit code, on BOTH backends (CompileAndRunWithRTL runs QBE + and native and requires parity). TMoney wraps TDecimal, so these also serve + as end-to-end coverage of the nested-managed-record return + interface-param + + record-copy paths that TDecimal exercises. + + Coverage: construction + currency normalisation (per-currency scale, banker's + rounding), case-insensitive currency codes, ToString, arithmetic + (Add/Subtract/Negate/Multiply/MultiplyInt), currency-mismatch raising, + Compare/Equals, IsZero/Sign, and the CurrencyScale registry. } + +interface + +uses + blaise.testing, cp.test.e2e.base; + +type + [Threaded] + TE2EMoneyTests = class(TE2ETestCase) + protected + procedure SetUp; override; + published + { --- Construction + normalisation --- } + procedure TestRun_FromStr_TwoDp; + procedure TestRun_FromStr_BankersRoundsHalfToEven; + procedure TestRun_FromStr_CurrencyCodeUppercased; + procedure TestRun_FromStr_JPY_ZeroScale; + procedure TestRun_FromStr_KWD_ThreeScale; + procedure TestRun_FromStr_UnknownCurrency_DefaultScale; + procedure TestRun_FromInt; + procedure TestRun_Zero; + + { --- ToString / AmountString --- } + procedure TestRun_ToString_WithCode; + procedure TestRun_AmountString_NoCode; + + { --- Arithmetic (same currency) --- } + procedure TestRun_Add_SameCurrency; + procedure TestRun_Subtract_SameCurrency; + procedure TestRun_Negate; + procedure TestRun_MultiplyInt_Quantity; + procedure TestRun_Multiply_TaxRate_BankersRound; + + { --- Currency mismatch raises --- } + procedure TestRun_Add_MismatchRaises; + procedure TestRun_Subtract_MismatchRaises; + procedure TestRun_Compare_MismatchRaises; + + { --- Compare / Equals / IsZero / Sign --- } + procedure TestRun_Compare_OrdersByAmount; + procedure TestRun_Equals_DifferentScaleSameValue; + procedure TestRun_Equals_DifferentCurrency_False; + procedure TestRun_IsZero_And_Sign; + + { --- Registry --- } + procedure TestRun_CurrencyScale_Registry; + + { --- A small realistic flow --- } + procedure TestRun_Invoice_LineItemsAndTax; + end; + +implementation + +procedure TE2EMoneyTests.SetUp; +begin + inherited SetUp(); + SetUpScratch('compiler/target/test-e2e-numerics-money'); +end; + +{ ------------------------------------------------------------------ } +{ Construction + normalisation } +{ ------------------------------------------------------------------ } + +procedure TE2EMoneyTests.TestRun_FromStr_TwoDp; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var M: TMoney; + begin M := MoneyFromStr('19.99', 'USD'); WriteLn(M.ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('19.99 USD', '19.99 USD', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_FromStr_BankersRoundsHalfToEven; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { 1.005 at 2dp, banker's: ties to even -> 1.00 (not 1.01). } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var M: TMoney; + begin M := MoneyFromStr('1.005', 'USD'); WriteLn(M.AmountString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('1.005 -> 1.00', '1.00', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_FromStr_CurrencyCodeUppercased; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var M: TMoney; + begin M := MoneyFromStr('5.00', 'usd'); WriteLn(M.CurrencyCode()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('lowercase -> USD', 'USD', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_FromStr_JPY_ZeroScale; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { JPY has scale 0 — a fractional input rounds to a whole number. } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var M: TMoney; + begin M := MoneyFromStr('199.6', 'JPY'); WriteLn(M.ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('200 JPY', '200 JPY', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_FromStr_KWD_ThreeScale; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { KWD has scale 3 — banker's at the 4th digit: 1.2345 -> 1.234. } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var M: TMoney; + begin M := MoneyFromStr('1.2345', 'KWD'); WriteLn(M.ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('1.234 KWD', '1.234 KWD', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_FromStr_UnknownCurrency_DefaultScale; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { An unknown code is accepted at the fallback scale of 2. } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var M: TMoney; + begin M := MoneyFromStr('3.456', 'ZZZ'); WriteLn(M.ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('3.46 ZZZ', '3.46 ZZZ', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_FromInt; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var M: TMoney; + begin M := MoneyFromInt(5, 'EUR'); WriteLn(M.ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('5.00 EUR', '5.00 EUR', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_Zero; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var M: TMoney; + begin M := MoneyZero('GBP'); WriteLn(M.ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('0.00 GBP', '0.00 GBP', Trim(Output)); +end; + +{ ------------------------------------------------------------------ } +{ ToString / AmountString } +{ ------------------------------------------------------------------ } + +procedure TE2EMoneyTests.TestRun_ToString_WithCode; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + begin WriteLn(MoneyFromStr('-0.5', 'USD').ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('-0.50 USD', '-0.50 USD', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_AmountString_NoCode; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + begin WriteLn(MoneyFromStr('42', 'USD').AmountString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('42.00', '42.00', Trim(Output)); +end; + +{ ------------------------------------------------------------------ } +{ Arithmetic (same currency) } +{ ------------------------------------------------------------------ } + +procedure TE2EMoneyTests.TestRun_Add_SameCurrency; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var A, B, C: TMoney; + begin + A := MoneyFromStr('19.99', 'USD'); + B := MoneyFromStr('0.01', 'USD'); + C := A.Add(B); + WriteLn(C.ToString()) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('20.00 USD', '20.00 USD', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_Subtract_SameCurrency; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var A, B, C: TMoney; + begin + A := MoneyFromStr('5.00', 'USD'); + B := MoneyFromStr('7.25', 'USD'); + C := A.Subtract(B); + WriteLn(C.ToString()) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('-2.25 USD', '-2.25 USD', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_Negate; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + begin WriteLn(MoneyFromStr('3.50', 'USD').Negate().ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('-3.50 USD', '-3.50 USD', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_MultiplyInt_Quantity; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { Unit price * quantity. } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + begin WriteLn(MoneyFromStr('19.99', 'USD').MultiplyInt(3).ToString()) end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('59.97 USD', '59.97 USD', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_Multiply_TaxRate_BankersRound; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { 19.99 * 1.08 = 21.5892 -> 21.59 at 2dp (banker's). } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money, Numerics.Decimal; + var M: TMoney; + begin + M := MoneyFromStr('19.99', 'USD').Multiply(DecFromStr('1.08')); + WriteLn(M.ToString()) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('21.59 USD', '21.59 USD', Trim(Output)); +end; + +{ ------------------------------------------------------------------ } +{ Currency mismatch raises } +{ ------------------------------------------------------------------ } + +procedure TE2EMoneyTests.TestRun_Add_MismatchRaises; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var A, B, C: TMoney; + begin + A := MoneyFromStr('1.00', 'USD'); + B := MoneyFromStr('100', 'JPY'); + try + C := A.Add(B); + WriteLn('no-raise') + except + on E: EMoneyMismatch do WriteLn('mismatch') + end + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('raises', 'mismatch', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_Subtract_MismatchRaises; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var A, B, C: TMoney; + begin + A := MoneyFromStr('5.00', 'EUR'); + B := MoneyFromStr('1.00', 'USD'); + try + C := A.Subtract(B); + WriteLn('no-raise') + except + on E: EMoneyMismatch do WriteLn('mismatch') + end + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('raises', 'mismatch', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_Compare_MismatchRaises; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var A, B: TMoney; R: Integer; + begin + A := MoneyFromStr('5.00', 'EUR'); + B := MoneyFromStr('5.00', 'USD'); + try + R := A.Compare(B); + WriteLn('no-raise ', R) + except + on E: EMoneyMismatch do WriteLn('mismatch') + end + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('raises', 'mismatch', Trim(Output)); +end; + +{ ------------------------------------------------------------------ } +{ Compare / Equals / IsZero / Sign } +{ ------------------------------------------------------------------ } + +procedure TE2EMoneyTests.TestRun_Compare_OrdersByAmount; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + var A, B: TMoney; + begin + A := MoneyFromStr('19.99', 'USD'); + B := MoneyFromStr('20.00', 'USD'); + WriteLn(A.Compare(B), ' ', B.Compare(A), ' ', A.Compare(A)) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('-1 1 0', '-1 1 0', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_Equals_DifferentScaleSameValue; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { 2 and 2.00 in the same currency are equal (value-based, like TDecimal). } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + begin + WriteLn(MoneyFromStr('2', 'USD').Equals(MoneyFromStr('2.00', 'USD'))) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('equal', 'True', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_Equals_DifferentCurrency_False; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { Same amount, different currency -> not equal (and does NOT raise). } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + begin + WriteLn(MoneyFromStr('2.00', 'USD').Equals(MoneyFromStr('2.00', 'EUR'))) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('not equal', 'False', Trim(Output)); +end; + +procedure TE2EMoneyTests.TestRun_IsZero_And_Sign; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + begin + WriteLn(MoneyZero('USD').IsZero(), ' ', + MoneyFromStr('-1.00', 'USD').Sign(), ' ', + MoneyFromStr('1.00', 'USD').Sign()) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('True -1 1', 'True -1 1', Trim(Output)); +end; + +{ ------------------------------------------------------------------ } +{ Registry } +{ ------------------------------------------------------------------ } + +procedure TE2EMoneyTests.TestRun_CurrencyScale_Registry; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money; + begin + WriteLn(CurrencyScale('JPY'), ' ', CurrencyScale('USD'), ' ', + CurrencyScale('KWD'), ' ', CurrencyScale('zzz')) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('0 2 3 2', '0 2 3 2', Trim(Output)); +end; + +{ ------------------------------------------------------------------ } +{ A small realistic flow } +{ ------------------------------------------------------------------ } + +procedure TE2EMoneyTests.TestRun_Invoice_LineItemsAndTax; +var Output: string; RCode: Integer; +begin + if not ToolchainAvailable() then begin Ignore('toolchain unavailable'); Exit; end; + { 2 x 9.99 + 1 x 4.50 = 24.48; +8% tax = 26.4384 -> 26.44. + Note: each step writes a DISTINCT variable — never `M := M.Method(...)` — + because self-assigning a record-method result aliases Self (see bugs.txt). } + AssertTrue('compile+run', CompileAndRunWithRTL( + ''' + program P; uses Numerics.Money, Numerics.Decimal; + var LineA, Subtotal, Total: TMoney; + begin + LineA := MoneyFromStr('9.99', 'USD').MultiplyInt(2); + Subtotal := LineA.Add(MoneyFromStr('4.50', 'USD')); + WriteLn('subtotal ', Subtotal.ToString()); + Total := Subtotal.Multiply(DecFromStr('1.08')); + WriteLn('total ', Total.ToString()) + end. + ''', Output, RCode)); + AssertEquals('exit code', 0, RCode); + AssertEquals('invoice', + 'subtotal 24.48 USD' + #10 + 'total 26.44 USD', Trim(Output)); +end; + +initialization + RegisterTest(TE2EMoneyTests); + +end. diff --git a/compiler/src/test/pascal/cp.test.numerics.money.pas b/compiler/src/test/pascal/cp.test.numerics.money.pas new file mode 100644 index 0000000..9a8d305 --- /dev/null +++ b/compiler/src/test/pascal/cp.test.numerics.money.pas @@ -0,0 +1,352 @@ +{ + Blaise - An Object Pascal Compiler + Copyright (c) 2026 Graeme Geldenhuys + SPDX-License-Identifier: Apache-2.0 WITH Swift-exception + Licensed under the Apache License v2.0 with Runtime Library Exception. + See LICENSE file in the project root for full license terms. +} + +unit cp.test.numerics.money; + +{ IR-level tests for the Numerics.Money stdlib unit (TMoney). + + These resolve Numerics.Money (and its Numerics.Decimal dependency) via + TUnitLoader, run the semantic pass, and inspect the generated QBE IR. They + cover the parser / semantic / codegen path for TMoney usage. RTL-contract and + runtime-behaviour issues are covered by cp.test.e2e.numerics.money.pas. } + +interface + +uses + blaise.testing, strutils, + uLexer, uParser, uAST, uSymbolTable, uSemantic, blaise.codegen.qbe, uUnitLoader; + +type + TMoneyIRTests = class(TTestCase) + private + FRTLUnitPath: string; + FStdlibUnitPath: string; + function GenIR(const ASrc: string): string; + procedure SemanticOK(const ASrc: string); + procedure AnalyseExpectError(const ASrc: string); + function IRContains(const AIR, AFragment: string): Boolean; + protected + procedure SetUp; override; + published + { --- Semantic resolution through the unit loader --- } + procedure TestSemantic_FromStr_OK; + procedure TestSemantic_FromInt_OK; + procedure TestSemantic_FromDecimal_OK; + procedure TestSemantic_Zero_OK; + procedure TestSemantic_ToString_OK; + procedure TestSemantic_AmountString_OK; + procedure TestSemantic_CurrencyCode_ReturnsString_OK; + procedure TestSemantic_Amount_ReturnsDecimal_OK; + procedure TestSemantic_CurrencyScale_ReturnsInteger_OK; + + { --- Arithmetic / queries --- } + procedure TestSemantic_Add_ReturnsMoney_OK; + procedure TestSemantic_Subtract_ReturnsMoney_OK; + procedure TestSemantic_Negate_ReturnsMoney_OK; + procedure TestSemantic_Multiply_ReturnsMoney_OK; + procedure TestSemantic_MultiplyInt_ReturnsMoney_OK; + procedure TestSemantic_Compare_ReturnsInteger_OK; + procedure TestSemantic_Equals_ReturnsBoolean_OK; + procedure TestSemantic_IsZero_ReturnsBoolean_OK; + procedure TestSemantic_Sign_ReturnsInteger_OK; + + { --- Type errors --- } + procedure TestSemantic_FromStr_WrongArgType_Error; + procedure TestSemantic_AssignMoneyToInt_Error; + + { --- IR shape --- } + procedure TestIR_FromStr_EmitsCall; + procedure TestIR_Add_EmitsCall; + end; + +implementation + +procedure TMoneyIRTests.SetUp; +var + ExeDir: string; +begin + inherited SetUp(); + ExeDir := ExtractFilePath(ParamStr(0)); + FRTLUnitPath := ExpandFileName(ExeDir + '../../runtime/src/main/pascal'); + FStdlibUnitPath := ExpandFileName(ExeDir + '../../stdlib/src/main/pascal'); +end; + +function TMoneyIRTests.GenIR(const ASrc: string): string; +var + Lexer: TLexer; + Parser: TParser; + Prog: TProgram; + Semantic: TSemanticAnalyser; + CG: TCodeGenQBE; + Loader: TUnitLoader; + Units: TObjectList; + SearchPaths: TStringList; + I: Integer; +begin + Lexer := nil; Parser := nil; Prog := nil; Semantic := nil; CG := nil; + Loader := nil; Units := nil; SearchPaths := nil; + try + Lexer := TLexer.Create(ASrc); + Parser := TParser.Create(Lexer); + Prog := Parser.Parse(); + Semantic := TSemanticAnalyser.Create(); + SearchPaths := TStringList.Create(); + SearchPaths.Add(FRTLUnitPath); + SearchPaths.Add(FStdlibUnitPath); + Loader := TUnitLoader.Create(SearchPaths); + Units := Loader.LoadAll(Prog.UsedUnits); + for I := 0 to Units.Count - 1 do + Semantic.AnalyseUnitForExport(TUnit(Units.Items[I])); + Semantic.Analyse(Prog); + CG := TCodeGenQBE.Create(); + CG.SetSymbolTable(Prog.SymbolTable); + for I := 0 to Units.Count - 1 do + CG.AppendUnit(TUnit(Units.Items[I])); + CG.AppendProgram(Prog); + Result := CG.GetOutput(); + finally + CG.Free(); Semantic.Free(); + Units.Free(); Loader.Free(); SearchPaths.Free(); + Prog.Free(); Parser.Free(); Lexer.Free(); + end; +end; + +procedure TMoneyIRTests.SemanticOK(const ASrc: string); +var + Lexer: TLexer; + Parser: TParser; + Prog: TProgram; + Semantic: TSemanticAnalyser; + Loader: TUnitLoader; + Units: TObjectList; + SearchPaths: TStringList; + I: Integer; +begin + Lexer := nil; Parser := nil; Prog := nil; Semantic := nil; + Loader := nil; Units := nil; SearchPaths := nil; + try + Lexer := TLexer.Create(ASrc); + Parser := TParser.Create(Lexer); + Prog := Parser.Parse(); + Semantic := TSemanticAnalyser.Create(); + SearchPaths := TStringList.Create(); + SearchPaths.Add(FRTLUnitPath); + SearchPaths.Add(FStdlibUnitPath); + Loader := TUnitLoader.Create(SearchPaths); + Units := Loader.LoadAll(Prog.UsedUnits); + for I := 0 to Units.Count - 1 do + Semantic.AnalyseUnitForExport(TUnit(Units.Items[I])); + Semantic.Analyse(Prog); + finally + Semantic.Free(); + Units.Free(); Loader.Free(); SearchPaths.Free(); + Prog.Free(); Parser.Free(); Lexer.Free(); + end; +end; + +procedure TMoneyIRTests.AnalyseExpectError(const ASrc: string); +begin + try + SemanticOK(ASrc); + Fail('Expected ESemanticError'); + except + on E: ESemanticError do ; { expected } + end; +end; + +function TMoneyIRTests.IRContains(const AIR, AFragment: string): Boolean; +begin + Result := Pos(AFragment, AIR) >= 0; +end; + +{ ------------------------------------------------------------------ } +{ Semantic resolution } +{ ------------------------------------------------------------------ } + +procedure TMoneyIRTests.TestSemantic_FromStr_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var M: TMoney; ' + + 'begin M := MoneyFromStr(''1.50'', ''USD'') end.'); +end; + +procedure TMoneyIRTests.TestSemantic_FromInt_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var M: TMoney; ' + + 'begin M := MoneyFromInt(5, ''USD'') end.'); +end; + +procedure TMoneyIRTests.TestSemantic_FromDecimal_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money, Numerics.Decimal; var M: TMoney; ' + + 'begin M := MoneyFromDecimal(DecFromStr(''1.50''), ''USD'') end.'); +end; + +procedure TMoneyIRTests.TestSemantic_Zero_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var M: TMoney; ' + + 'begin M := MoneyZero(''USD'') end.'); +end; + +procedure TMoneyIRTests.TestSemantic_ToString_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var M: TMoney; S: string; ' + + 'begin M := MoneyFromInt(5, ''USD''); S := M.ToString() end.'); +end; + +procedure TMoneyIRTests.TestSemantic_AmountString_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var M: TMoney; S: string; ' + + 'begin M := MoneyFromInt(5, ''USD''); S := M.AmountString() end.'); +end; + +procedure TMoneyIRTests.TestSemantic_CurrencyCode_ReturnsString_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var M: TMoney; S: string; ' + + 'begin M := MoneyFromInt(5, ''USD''); S := M.CurrencyCode() end.'); +end; + +procedure TMoneyIRTests.TestSemantic_Amount_ReturnsDecimal_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money, Numerics.Decimal; var M: TMoney; D: TDecimal; ' + + 'begin M := MoneyFromInt(5, ''USD''); D := M.Amount() end.'); +end; + +procedure TMoneyIRTests.TestSemantic_CurrencyScale_ReturnsInteger_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var I: Integer; ' + + 'begin I := CurrencyScale(''KWD'') end.'); +end; + +{ ------------------------------------------------------------------ } +{ Arithmetic / queries } +{ ------------------------------------------------------------------ } + +procedure TMoneyIRTests.TestSemantic_Add_ReturnsMoney_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var A, B, C: TMoney; ' + + 'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' + + 'C := A.Add(B) end.'); +end; + +procedure TMoneyIRTests.TestSemantic_Subtract_ReturnsMoney_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var A, B, C: TMoney; ' + + 'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' + + 'C := A.Subtract(B) end.'); +end; + +procedure TMoneyIRTests.TestSemantic_Negate_ReturnsMoney_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var A, C: TMoney; ' + + 'begin A := MoneyFromInt(1, ''USD''); C := A.Negate() end.'); +end; + +procedure TMoneyIRTests.TestSemantic_Multiply_ReturnsMoney_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money, Numerics.Decimal; var A, C: TMoney; ' + + 'begin A := MoneyFromInt(1, ''USD''); C := A.Multiply(DecFromStr(''1.08'')) end.'); +end; + +procedure TMoneyIRTests.TestSemantic_MultiplyInt_ReturnsMoney_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var A, C: TMoney; ' + + 'begin A := MoneyFromInt(1, ''USD''); C := A.MultiplyInt(3) end.'); +end; + +procedure TMoneyIRTests.TestSemantic_Compare_ReturnsInteger_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var A, B: TMoney; I: Integer; ' + + 'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' + + 'I := A.Compare(B) end.'); +end; + +procedure TMoneyIRTests.TestSemantic_Equals_ReturnsBoolean_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var A, B: TMoney; X: Boolean; ' + + 'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' + + 'X := A.Equals(B) end.'); +end; + +procedure TMoneyIRTests.TestSemantic_IsZero_ReturnsBoolean_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var A: TMoney; X: Boolean; ' + + 'begin A := MoneyFromInt(0, ''USD''); X := A.IsZero() end.'); +end; + +procedure TMoneyIRTests.TestSemantic_Sign_ReturnsInteger_OK; +begin + SemanticOK( + 'program P; uses Numerics.Money; var A: TMoney; I: Integer; ' + + 'begin A := MoneyFromInt(1, ''USD''); I := A.Sign() end.'); +end; + +{ ------------------------------------------------------------------ } +{ Type errors } +{ ------------------------------------------------------------------ } + +procedure TMoneyIRTests.TestSemantic_FromStr_WrongArgType_Error; +begin + { Second argument must be a string currency code, not an integer. } + AnalyseExpectError( + 'program P; uses Numerics.Money; var M: TMoney; ' + + 'begin M := MoneyFromStr(''1.50'', 5) end.'); +end; + +procedure TMoneyIRTests.TestSemantic_AssignMoneyToInt_Error; +begin + AnalyseExpectError( + 'program P; uses Numerics.Money; var M: TMoney; I: Integer; ' + + 'begin M := MoneyFromInt(1, ''USD''); I := M end.'); +end; + +{ ------------------------------------------------------------------ } +{ IR shape } +{ ------------------------------------------------------------------ } + +procedure TMoneyIRTests.TestIR_FromStr_EmitsCall; +var IR: string; +begin + IR := GenIR( + 'program P; uses Numerics.Money; var M: TMoney; ' + + 'begin M := MoneyFromStr(''1.50'', ''USD'') end.'); + AssertTrue('emits MoneyFromStr call', + IRContains(IR, '$Numerics_Money_MoneyFromStr')); +end; + +procedure TMoneyIRTests.TestIR_Add_EmitsCall; +var IR: string; +begin + IR := GenIR( + 'program P; uses Numerics.Money; var A, B, C: TMoney; ' + + 'begin A := MoneyFromInt(1, ''USD''); B := MoneyFromInt(2, ''USD''); ' + + 'C := A.Add(B) end.'); + AssertTrue('emits TMoney.Add call', + IRContains(IR, '$Numerics_Money_TMoney_Add')); +end; + +initialization + RegisterTest(TMoneyIRTests); + +end. diff --git a/docs/future-improvements.adoc b/docs/future-improvements.adoc index df1dd31..4783f04 100644 --- a/docs/future-improvements.adoc +++ b/docs/future-improvements.adoc @@ -180,20 +180,12 @@ local record variables at scope exit. == StdLib Packages — Numeric Types -The exact-decimal type itself (`TDecimal` in `Numerics.Decimal`) is implemented; -the design decision — one `TDecimal`, no separate `Currency`/`BigDecimal` — is -recorded in `docs/language-rationale.adoc` ("Decimal Arithmetic — One `TDecimal`, -No `Currency` Primitive"). The following numeric items remain genuinely future -work. - -=== `Numerics.Money` — currency-aware wrapper - -A thin type layering currency onto `TDecimal`: a `TMoney` carrying an amount plus -an ISO-4217 currency tag, with mismatched-currency arithmetic raising and a -per-currency default scale (JPY 0, USD 2, KWD 3). This is the universal pattern — -Moneta (Java), the `money` gem (Ruby) and `rusty-money` (Rust) all wrap a decimal -rather than baking currency into the numeric core. Deferred so currency/locale -policy stays out of `TDecimal`. +The exact-decimal type (`TDecimal` in `Numerics.Decimal`) and the currency-aware +wrapper (`TMoney` in `Numerics.Money`) are both implemented; the design +decisions are recorded in `docs/language-rationale.adoc` ("Decimal Arithmetic — +One `TDecimal`, No `Currency` Primitive" and "Currency Amounts — `TMoney` Wraps +`TDecimal`, Currency Is a String Tag"). The following numeric items remain +genuinely future work. === Operator overloading for `TDecimal` diff --git a/docs/language-rationale.adoc b/docs/language-rationale.adoc index 38fc916..5b20c17 100644 --- a/docs/language-rationale.adoc +++ b/docs/language-rationale.adoc @@ -5024,7 +5024,79 @@ rounding) need no change to the library. where exact decimal representation is impossible and pointless. `Double` + `Math` already serve this; `TDecimal` ships no such functions. -* *Baking currency (ISO-4217) into the numeric core.* Deferred to a future - `Numerics.Money` wrapper. Currency is a policy layer (which currencies, how to - format, per-jurisdiction rounding) that should not be frozen into the numeric - type — matching Moneta / money-gem / rusty-money, which all wrap a decimal. +* *Baking currency (ISO-4217) into the numeric core.* Deferred to the + `Numerics.Money` wrapper (see the next section). Currency is a policy layer + (which currencies, how to format, per-jurisdiction rounding) that should not be + frozen into the numeric type — matching Moneta / money-gem / rusty-money, which + all wrap a decimal. + +== Currency Amounts — `TMoney` Wraps `TDecimal`, Currency Is a String Tag + +=== Decision + +Currency-aware monetary amounts are provided by `TMoney` (`Numerics.Money`), a +thin value-type wrapper that pairs an exact `TDecimal` amount with an ISO-4217 +currency tag. The numeric core (`TDecimal`) stays currency- and locale-agnostic; +currency policy lives entirely in this wrapper. Three rules define `TMoney`: + +* The currency tag is an ISO-4217 alphabetic *string* code ('USD', 'JPY', + 'KWD'), upper-cased on construction. The set of currencies is open: a code the + built-in registry does not list is still accepted and uses the fallback minor- + unit scale of two. + +* Each currency has a default minor-unit scale (JPY 0, USD 2, KWD 3, fallback 2). + Every `TMoney` is normalised to its currency's scale on construction and after + every arithmetic operation, using banker's rounding (`rmHalfEven`). + +* Arithmetic across different currencies (`Add`, `Subtract`, `Compare`) raises + `EMoneyMismatch`. There is no implicit conversion — exchange rates are a + higher policy layer, not a property of the type. (`Equals` is the one + exception: it returns `False` for different currencies rather than raising, so + it is total and safe in containers.) + +`TMoney` has immutable value semantics: every operation returns a fresh value and +never mutates `Self`, exactly as `TDecimal` does. + +=== Rationale + +This is the universal industry pattern. Moneta (Java), the money gem (Ruby) and +rusty-money (Rust) each wrap a decimal with a currency tag rather than baking +currency into the numeric type. Keeping currency out of `TDecimal` preserves the +"one exact-decimal type" decision (see the previous section) and keeps locale and +jurisdiction policy — formatting, which currencies exist, per-currency rounding — +in a layer that can evolve without touching the numeric core. + +A *string* currency code (rather than a closed `enum`) keeps the type open: new +or non-standard codes (crypto, historical, regional) work without a library +edit, matching money gem and rusty-money. The small loss of compile-time +checking is the right trade for an inventory that changes outside the compiler's +release cycle; an unknown code degrades gracefully to the fallback scale instead +of failing to compile. + +Per-currency scale normalisation with banker's rounding on every operation makes +`TMoney` behave like real money: a JPY amount never carries a fraction, a USD +amount is always two places, and ties round without the upward bias of +round-half-up. Doing it on *every* operation (not just on display) keeps stored +values canonical, so equality and hashing are well-defined. + +=== Alternatives considered + +* *A `TCurrency` enum instead of a string code.* Rejected. It is type-safe but + closes the currency set: every new or non-standard code would require editing + and re-releasing the library. The open string code matches the dominant money + libraries and lets unknown codes degrade to the fallback scale. + +* *Preserving full `TDecimal` scale and rounding only on display.* Rejected as + the default. Lazy rounding lets non-canonical values (e.g. an un-rounded + division result) leak into stored amounts and breaks value equality between + amounts that should be equal. Normalising eagerly keeps every `TMoney` at its + currency scale. + +* *Baking exchange-rate conversion into `TMoney`.* Rejected. Rates are + time-varying external data, not a property of an amount; mixing them in would + make arithmetic depend on hidden state. Cross-currency arithmetic raises + instead, leaving conversion to an explicit higher layer. + +* *A fixed-point money type (Int64 scaled).* Already rejected for `TDecimal` + (see the previous section); `TMoney` inherits `TDecimal`'s compact `Int64` + fast path for the common case, so it needs no separate fixed-point design. diff --git a/stdlib/src/main/pascal/numerics.money.pas b/stdlib/src/main/pascal/numerics.money.pas new file mode 100644 index 0000000..99b9ac7 --- /dev/null +++ b/stdlib/src/main/pascal/numerics.money.pas @@ -0,0 +1,338 @@ +{ + Blaise - An Object Pascal Compiler + Copyright (c) 2026 Graeme Geldenhuys + SPDX-License-Identifier: Apache-2.0 WITH Swift-exception + Licensed under the Apache License v2.0 with Runtime Library Exception. + See LICENSE file in the project root for full license terms. +} + +unit Numerics.Money; + +{ Blaise StdLib — currency-aware monetary amounts. + + TMoney is a thin VALUE-TYPE wrapper that layers an ISO-4217 currency tag onto + an exact TDecimal amount (see Numerics.Decimal). It is the money type; the + numeric core (TDecimal) stays currency- and locale-agnostic, matching the + universal pattern of Moneta (Java), the money gem (Ruby) and rusty-money + (Rust), each of which wraps a decimal rather than baking currency into the + numeric type. See docs/language-rationale.adoc. + + Design: + + - Currency is an ISO-4217 alphabetic code held as a string ('USD', 'JPY', + 'KWD'). This is open-ended: a code the built-in registry does not know is + still accepted and uses the fallback scale (2). The code is upper-cased + on construction so 'usd' and 'USD' are the same currency. + + - Each currency has a default minor-unit scale: JPY 0, USD 2, KWD 3, and a + fallback of 2 for unknown codes. Every TMoney is NORMALISED to its + currency's scale on construction and after every arithmetic operation, + using banker's rounding (rmHalfEven) — the recommended money default. + So MoneyFromStr('1.005', 'USD') stores 1.00, and a JPY amount never + carries a fraction. + + - Mismatched-currency arithmetic RAISES EMoneyMismatch. Add, Subtract and + Compare across different currencies are programming errors, not silent + conversions (there is no exchange-rate concept here — that is a higher + policy layer). + + - Immutable value semantics: every operation returns a fresh TMoney and + never mutates Self. Scaling by a quantity (Multiply) keeps the same + currency and re-normalises to its scale. + + Construction uses free functions (MoneyFromStr / MoneyFromDecimal / + MoneyFromInt / MoneyZero), following the Numerics.Decimal and DateUtils + house style. Queries and arithmetic are record methods. } + +interface + +uses + SysUtils, Numerics.Decimal; + +type + { Base class for all errors raised by this unit. } + EMoneyError = class(Exception); + + { Raised when an operation combines two TMoney values of different + currencies (e.g. USD + JPY). } + EMoneyMismatch = class(EMoneyError); + + { ------------------------------------------------------------------ } + { TMoney — a decimal amount tagged with an ISO-4217 currency } + { ------------------------------------------------------------------ } + + { A monetary amount in a single currency. See the unit header for the + design rationale. The amount is always held at the currency's default + scale (banker's-rounded on every operation). } + TMoney = record + { The exact amount, normalised to the currency's default scale. } + FAmount: TDecimal; + { ISO-4217 alphabetic currency code, upper-case (e.g. 'USD'). } + FCurrency: string; + + { The amount as an exact TDecimal (at the currency scale). + @returns the monetary amount. } + function Amount: TDecimal; + + { The ISO-4217 currency code (upper-case). + @returns the currency code string. } + function CurrencyCode: string; + + { Tests whether the amount is exactly zero. + @returns True iff the amount is zero. } + function IsZero: Boolean; + + { Sign of the amount. + @returns -1 if negative, 0 if zero, +1 if positive. } + function Sign: Integer; + + { Sum of Self and B. Both must be the same currency; the result is in that + currency, normalised to its scale. + @param B the amount to add. + @returns Self + B. + @raises EMoneyMismatch if the currencies differ. } + function Add(const B: TMoney): TMoney; + + { Difference Self - B. Both must be the same currency. + @param B the amount to subtract. + @returns Self - B. + @raises EMoneyMismatch if the currencies differ. } + function Subtract(const B: TMoney): TMoney; + + { Arithmetic negation (-Self), same currency and scale. + @returns the amount with opposite sign. } + function Negate: TMoney; + + { Scales the amount by a dimensionless TDecimal factor (e.g. unit price * + quantity, or amount * tax-rate), re-normalising to the currency scale with + banker's rounding. The currency is preserved. + @param Factor the multiplier. + @returns Self * Factor at the currency scale. } + function Multiply(const Factor: TDecimal): TMoney; + + { Scales the amount by an integer quantity. Exact (no rounding needed + beyond the existing scale). The currency is preserved. + @param Quantity the integer multiplier. + @returns Self * Quantity. } + function MultiplyInt(Quantity: Integer): TMoney; + + { Three-way comparison by amount. Both must be the same currency. + @param B the amount to compare against. + @returns -1 if Self < B, 0 if equal, +1 if Self > B. + @raises EMoneyMismatch if the currencies differ. } + function Compare(const B: TMoney): Integer; + + { Value equality: same currency AND equal amount. Unlike Compare, this does + NOT raise on a currency mismatch — two amounts in different currencies are + simply not equal. + @param B the amount to compare against. + @returns True iff same currency and equal amount. } + function Equals(const B: TMoney): Boolean; + + { The bare amount as a plain decimal string at the currency scale, with no + currency code (e.g. '19.99'). Never scientific notation. + @returns the amount string. } + function AmountString: string; + + { Amount followed by a space and the currency code (e.g. '19.99 USD'). + @returns the formatted monetary string. } + function ToString: string; + end; + +{ ------------------------------------------------------------------ } +{ Construction (free functions, house style) } +{ ------------------------------------------------------------------ } + +{ Builds a TMoney from a decimal literal string and a currency code. The + amount is parsed exactly (see DecFromStr) then normalised to the currency's + default scale with banker's rounding. + @param AAmount the decimal literal (e.g. '19.99', '-0.005'). + @param ACurrency the ISO-4217 code (case-insensitive; stored upper-case). + @returns the money value. + @raises EDecimalParse if AAmount is malformed. } +function MoneyFromStr(const AAmount, ACurrency: string): TMoney; + +{ Builds a TMoney from an existing TDecimal amount and a currency code. The + amount is normalised to the currency's default scale (banker's rounding). + @param AAmount the decimal amount. + @param ACurrency the ISO-4217 code (case-insensitive; stored upper-case). + @returns the money value. } +function MoneyFromDecimal(const AAmount: TDecimal; const ACurrency: string): TMoney; + +{ Builds a TMoney from a whole-unit integer amount and a currency code + (e.g. MoneyFromInt(5, 'USD') = 5.00 USD). + @param AAmount the whole-unit integer amount. + @param ACurrency the ISO-4217 code (case-insensitive; stored upper-case). + @returns the money value. } +function MoneyFromInt(AAmount: Integer; const ACurrency: string): TMoney; + +{ A zero amount in the given currency, at the currency scale. + @param ACurrency the ISO-4217 code (case-insensitive; stored upper-case). + @returns zero money in that currency. } +function MoneyZero(const ACurrency: string): TMoney; + +{ ------------------------------------------------------------------ } +{ Currency registry } +{ ------------------------------------------------------------------ } + +{ The default minor-unit scale (number of fraction digits) for a currency code. + Known: JPY 0, USD/EUR/GBP/AUD/CAD/CHF/CNY 2, KWD/BHD/OMR 3. Unknown codes + return the fallback scale 2. The lookup is case-insensitive. + @param ACurrency the ISO-4217 code. + @returns the default fraction-digit count for that currency. } +function CurrencyScale(const ACurrency: string): Integer; + +implementation + +const + { Fallback minor-unit scale for currencies the registry does not list. } + cDefaultScale = 2; + +function CurrencyScale(const ACurrency: string): Integer; +var + C: string; +begin + C := UpperCase(ACurrency); + { Zero-decimal currencies. } + if (C = 'JPY') or (C = 'KRW') or (C = 'CLP') or (C = 'ISK') or + (C = 'VND') or (C = 'XAF') or (C = 'XOF') or (C = 'PYG') then + Result := 0 + { Three-decimal currencies. } + else if (C = 'KWD') or (C = 'BHD') or (C = 'OMR') or (C = 'TND') or + (C = 'JOD') or (C = 'IQD') or (C = 'LYD') then + Result := 3 + { Everything else (USD, EUR, GBP, ...) uses two. } + else + Result := cDefaultScale; +end; + +{ Normalises ADec to ACurrency's scale with banker's rounding and pairs it with + the upper-cased code. Central constructor used by every public builder so the + invariant "FAmount is always at the currency scale" holds in one place. } +function MakeMoney(const ADec: TDecimal; const ACurrency: string): TMoney; +var + Code: string; + Norm: TDecimal; +begin + Code := UpperCase(ACurrency); + Norm := ADec.RoundTo(CurrencyScale(Code), rmHalfEven); + Result.FAmount := Norm; + Result.FCurrency := Code; +end; + +function MoneyFromStr(const AAmount, ACurrency: string): TMoney; +begin + Result := MakeMoney(DecFromStr(AAmount), ACurrency); +end; + +function MoneyFromDecimal(const AAmount: TDecimal; const ACurrency: string): TMoney; +begin + Result := MakeMoney(AAmount, ACurrency); +end; + +function MoneyFromInt(AAmount: Integer; const ACurrency: string): TMoney; +begin + Result := MakeMoney(DecFromInt(AAmount), ACurrency); +end; + +function MoneyZero(const ACurrency: string): TMoney; +begin + Result := MakeMoney(DecFromInt(0), ACurrency); +end; + +{ Raises EMoneyMismatch when A and B are different currencies. AOp names the + operation for the message. } +procedure RequireSameCurrency(const A, B: TMoney; const AOp: string); +begin + if A.FCurrency <> B.FCurrency then + raise EMoneyMismatch.Create('Numerics.Money: cannot ' + AOp + + ' different currencies (' + A.FCurrency + ' and ' + B.FCurrency + ')'); +end; + +function TMoney.Amount: TDecimal; +begin + Result := Self.FAmount; +end; + +function TMoney.CurrencyCode: string; +begin + Result := Self.FCurrency; +end; + +function TMoney.IsZero: Boolean; +begin + Result := Self.FAmount.IsZero(); +end; + +function TMoney.Sign: Integer; +begin + Result := Self.FAmount.Sign(); +end; + +function TMoney.Add(const B: TMoney): TMoney; +var + Sum: TDecimal; +begin + RequireSameCurrency(Self, B, 'add'); + Sum := Self.FAmount.Add(B.FAmount); + Result := MakeMoney(Sum, Self.FCurrency); +end; + +function TMoney.Subtract(const B: TMoney): TMoney; +var + Diff: TDecimal; +begin + RequireSameCurrency(Self, B, 'subtract'); + Diff := Self.FAmount.Subtract(B.FAmount); + Result := MakeMoney(Diff, Self.FCurrency); +end; + +function TMoney.Negate: TMoney; +var + Neg: TDecimal; +begin + Neg := Self.FAmount.Negate(); + Result := MakeMoney(Neg, Self.FCurrency); +end; + +function TMoney.Multiply(const Factor: TDecimal): TMoney; +var + Prod: TDecimal; +begin + Prod := Self.FAmount.Multiply(Factor); + Result := MakeMoney(Prod, Self.FCurrency); +end; + +function TMoney.MultiplyInt(Quantity: Integer): TMoney; +var + Prod: TDecimal; +begin + Prod := Self.FAmount.Multiply(DecFromInt(Quantity)); + Result := MakeMoney(Prod, Self.FCurrency); +end; + +function TMoney.Compare(const B: TMoney): Integer; +begin + RequireSameCurrency(Self, B, 'compare'); + Result := Self.FAmount.Compare(B.FAmount); +end; + +function TMoney.Equals(const B: TMoney): Boolean; +begin + if Self.FCurrency <> B.FCurrency then + Result := False + else + Result := Self.FAmount.Equals(B.FAmount); +end; + +function TMoney.AmountString: string; +begin + Result := Self.FAmount.ToString(); +end; + +function TMoney.ToString: string; +begin + Result := Self.FAmount.ToString() + ' ' + Self.FCurrency; +end; + +end.