exchangealgebra-0.6.0.0: src/ExchangeAlgebra/Algebra/Value.hs
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DerivingStrategies #-}
{- |
Module : ExchangeAlgebra.Algebra.Value
Copyright : (c) Kaya Akagi. 2018-2026
Maintainer : yakagika@icloud.com
Released under the OWL license
Exact, non-negative decimal value type t'MoneyDecimal' for use as the @v@
parameter of @Alg v b@ / @Journal n v b@.
== Why this exists (DESIGN, 2026-06-06)
The accounting value type is selectable:
* @Double@ — fast IEEE-754; the default. Addition is /non-associative/,
so the order in which same-base postings are summed (which depends on how a
value was /constructed/) can change @norm@ / @bar@ results. In the
agent-based simulations this manifested as a ~3% swing in a stock value when
the construction order changed (see plans/in-progress/LAZY_EVAL_AUDIT.md and
FP_SUMMATION_SURVEY.md). This is acceptable for relative-price ABM work where
speed matters, but it is not deterministic/auditable.
* @MoneyDecimal@ — exact base-10 fixed-point (a non-negative 'Data.Decimal').
Addition is /exact and associative/, so results are independent of
construction order: the fromList fold direction, parallel merges, etc. no
longer change the answer. This is the right choice for audited ledgers and
for making the construction-order optimizations (fromList O(N)) safe.
@Integer@ (minimal-currency-unit) is intentionally NOT offered: ABM simulations
use relative prices with base unit 1 and sub-unit fractional prices, which an
integer cannot represent.
== Ergonomics
Numeric literals work without wrapping, because 'Num'/'Fractional' are derived:
> import ExchangeAlgebra.Algebra
> import ExchangeAlgebra.Algebra.Value (MoneyDecimal)
>
> entry :: Alg MoneyDecimal (HatBase CountUnit)
> entry = 10.5 .@ Hat :< Amount .+ 2 .@ Not :< Yen
== Rounding
The core algebra only adds/subtracts, which is exact for t'MoneyDecimal' and needs no
rounding. Rounding is only needed by /multiplication and division/ (tax ratios,
proration, scalar product) at the point a monetary amount is /finalized/. Use
'bankersRound': it rounds half-to-even (the unbiased financial default; also GHC's
'Prelude.round' and IEEE-754's default mode). A ceiling variant ('ceilingRound') is
provided for jurisdictions whose
rules differ. There is no single correct rule (e.g. Japanese consumption tax rounding
varies by company), so the rounding function is explicit and swappable.
-}
module ExchangeAlgebra.Algebra.Value
( Nearly(..)
, isNearlyNum
, HatVal(..)
, ValueError(..)
, isErrorValue
, Rounding(..)
, Tolerance(..)
, defaultTolerance
-- * Sums
, sumValues
, roundScaled
-- * Accumulators for user-defined value types
, RationalAccum(..)
, rationalAddAccum
, rationalRoundAccum
, MoneyDecimal(..)
, toDecimal
, bankersRound
, ceilingRound
-- * Parsing
, MoneyParseError(..)
, moneyDecimalFromText
, moneyDecimalFromScientific
-- * Fast floating-point value
, MoneyDouble(..)
, toDouble
) where
import ExchangeAlgebra.Algebra.Value.Class ( HatVal (..)
, ValueError (..)
, isErrorValue
, Nearly (..)
, Rounding (..)
, Tolerance (..)
, defaultTolerance
, isNearlyNum
, sumValues
, roundScaled
)
import Data.Decimal (Decimal, DecimalRaw (Decimal), normalizeDecimal, roundTo')
import Data.Ratio (numerator, denominator)
import Data.Word (Word8)
import Data.Scientific (Scientific, coefficient, base10Exponent)
import qualified Data.Scientific as Scientific
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Hashable (Hashable (..))
import Control.DeepSeq (NFData (..))
import qualified Data.Binary as Binary
-- | A non-negative exact decimal value (wraps 'Data.Decimal.Decimal').
--
-- Non-negativity is a /soft/ invariant, the same as for the @Double@ instance:
-- it is not enforced by the constructor (intermediate subtraction inside @bar@/@(.-)@
-- can produce negatives), but 'isErrorValue' reports @x < 0@ so the @(.@)@ smart
-- constructor rejects negative postings.
newtype MoneyDecimal = MoneyDecimal Decimal
-- Num/Fractional are derived so numeric literals (@10.5@, @0.08@) work directly,
-- with no @MoneyDecimal@ wrapper at use sites. Show/Eq/Ord delegate to t'Decimal'.
-- 'Real' (and thus 'toRational') is derived so values can be converted to/from
-- @Double@ via 'realToFrac' at the simulation boundary: ABM parameters, input
-- coefficients and random draws stay 'Double', and are converted to t'MoneyDecimal'
-- only where they enter a ledger; final stock/profit amounts convert back for
-- reporting. The ledger arithmetic in between is exact.
deriving newtype (Eq, Ord, Show, Num, Fractional, Real)
-- | Project out the underlying t'Decimal'.
toDecimal :: MoneyDecimal -> Decimal
toDecimal (MoneyDecimal d) = d
-- * Parsing
-- | A rejected money input. The constructors are stable failure categories.
data MoneyParseError
= MalformedMoney -- ^ The text is not a JSON number.
| NegativeMoney -- ^ The coefficient is negative and nonzero.
| MoneyExponentOutOfRange -- ^ The exponent is outside [-10000, 10000].
| MoneyScaleOutOfRange -- ^ The decimal scale exceeds 255 places.
deriving (Eq, Show)
-- | The parts of a fully validated JSON number, before numeric conversion.
data ParsedMoney = ParsedMoney
{ parsedNegative :: Bool
, parsedIntegerDigits :: Text
, parsedFractionDigits :: Text
, parsedExponentMinus :: Bool
, parsedExponentDigits :: Text
}
-- | Check the complete JSON number grammar using ASCII digits only.
parseMoneySyntax :: Text -> Maybe ParsedMoney
parseMoneySyntax input = do
let (negative, unsigned) = case Text.uncons input of
Just ('-', rest) -> (True, rest)
_ -> (False, input)
(integerDigits, afterInteger) <- case Text.uncons unsigned of
Just ('0', rest) -> Just (Text.singleton '0', rest)
Just (digit, rest) | isMoneyDigitNonzero digit ->
let (digits, suffix) = Text.span isMoneyDigit rest
in Just (Text.cons digit digits, suffix)
_ -> Nothing
(fractionDigits, afterFraction) <- case Text.uncons afterInteger of
Just ('.', rest) -> case Text.span isMoneyDigit rest of
(digits, _) | Text.null digits -> Nothing
result -> Just result
_ -> Just (Text.empty, afterInteger)
(exponentMinus, exponentDigits) <- case Text.uncons afterFraction of
Just ('e', rest) -> parseExponent rest
Just ('E', rest) -> parseExponent rest
Nothing -> Just (False, Text.singleton '0')
_ -> Nothing
pure ParsedMoney
{ parsedNegative = negative
, parsedIntegerDigits = integerDigits
, parsedFractionDigits = fractionDigits
, parsedExponentMinus = exponentMinus
, parsedExponentDigits = exponentDigits
}
where
parseExponent :: Text -> Maybe (Bool, Text)
parseExponent exponent
| Text.null digits = Nothing
| Text.null suffix = Just (minus, digits)
| otherwise = Nothing
where
(minus, unsigned) = case Text.uncons exponent of
Just ('-', rest) -> (True, rest)
Just ('+', rest) -> (False, rest)
_ -> (False, exponent)
(digits, suffix) = Text.span isMoneyDigit unsigned
-- | Recognize a JSON decimal digit without accepting Unicode numerals.
isMoneyDigit :: Char -> Bool
isMoneyDigit digit = digit >= '0' && digit <= '9'
-- | Recognize a nonzero JSON digit at the start of an integer part.
isMoneyDigitNonzero :: Char -> Bool
isMoneyDigitNonzero digit = digit >= '1' && digit <= '9'
-- | Decode an exponent only after its nonzero digits pass the length bound.
boundedExponent :: Text -> Either MoneyParseError Integer
boundedExponent digits
| Text.length significant > 5 = Left MoneyExponentOutOfRange
| Text.length significant == 5 && significant > Text.pack "10000" = Left MoneyExponentOutOfRange
| otherwise = Right (decimalDigits significant)
where
significant = Text.dropWhile (== '0') digits
-- | Convert already validated decimal digits without a binary float.
decimalDigits :: Text -> Integer
decimalDigits = Text.foldl' (\value digit -> value * 10 + toInteger (fromEnum digit - fromEnum '0')) 0
-- | Construct an exact decimal after the exponent and scale checks.
moneyFromParts :: Integer -> Integer -> Either MoneyParseError MoneyDecimal
moneyFromParts mantissa places
| places > 255 = Left MoneyScaleOutOfRange
| places >= 0 = Right (MoneyDecimal (Decimal (fromInteger places) mantissa))
| otherwise = Right (MoneyDecimal (Decimal 0 (mantissa * 10 ^ negate places)))
-- | Parse a JSON number as an exact, non-negative money value.
--
-- The input has no surrounding whitespace. The result retains the written
-- decimal places and never rounds. Failures follow the priority in this table:
--
-- +---------------------+----------------------------------------------------+
-- | Rule | Result |
-- +=====================+====================================================+
-- | Text syntax | Optional @-@; @0@ or @[1-9][0-9]*@; optional |
-- | | @.@ and digits; optional exponent with @e@ or |
-- | | @E@, optional sign, and digits. Each present |
-- | | digit group is nonempty. |
-- | | Whitespace, @+1@, @01@, @.5@, @5.@, @NaN@, |
-- | | @Infinity@, and separators are malformed. |
-- +---------------------+----------------------------------------------------+
-- | Negative value | A nonzero negative returns 'NegativeMoney'. |
-- | | @-0@ and @-0.00@ are accepted as zero. |
-- +---------------------+----------------------------------------------------+
-- | Exponent | Magnitudes over 10000 return |
-- | | 'MoneyExponentOutOfRange'. |
-- +---------------------+----------------------------------------------------+
-- | Scale | More than 255 decimal places return |
-- | | 'MoneyScaleOutOfRange'. |
-- +---------------------+----------------------------------------------------+
-- | Exact value | Digits form the coefficient; scale is fractional |
-- | | digits minus exponent. Negative scale multiplies |
-- | | the coefficient by a power of ten. |
-- +---------------------+----------------------------------------------------+
-- | Written scale | Trailing zeroes are retained: @1.50@ has scale 2 |
-- | | and mantissa 150. No normalization or rounding. |
-- +---------------------+----------------------------------------------------+
-- | Failure priority | Syntax, negative value, exponent, then scale. |
-- +---------------------+----------------------------------------------------+
-- | Scientific input | The raw coefficient and exponent determine scale |
-- | | and acceptance; syntax failure does not apply. |
-- +---------------------+----------------------------------------------------+
--
-- Lexical scanning is linear in the input length. Converting an unbounded
-- coefficient to 'Integer' and multiplying large integers have separate costs.
--
-- >>> moneyDecimalFromText (Text.pack "19.99")
-- Right 19.99
-- >>> moneyDecimalFromText (Text.pack "1.50")
-- Right 1.50
moneyDecimalFromText :: Text -> Either MoneyParseError MoneyDecimal
moneyDecimalFromText source = do
parsed <- maybe (Left MalformedMoney) Right (parseMoneySyntax source)
let digits = parsedIntegerDigits parsed <> parsedFractionDigits parsed
if parsedNegative parsed && Text.any (/= '0') digits
then Left NegativeMoney
else do
magnitude <- boundedExponent (parsedExponentDigits parsed)
let exponent
| parsedExponentMinus parsed = negate magnitude
| otherwise = magnitude
places = toInteger (Text.length (parsedFractionDigits parsed)) - exponent
if places > 255
then Left MoneyScaleOutOfRange
else moneyFromParts (decimalDigits digits) places
-- | Convert a 'Scientific' representation to an exact money value.
--
-- The raw 'coefficient' and 'base10Exponent' determine the result. Equal
-- numerical values can have different scales or acceptance results when their
-- representations differ. Negative nonzero coefficients fail first; an
-- exponent outside [-10000, 10000] fails next; a scale above 255 fails last.
-- Zero follows the same exponent and scale checks. This function never returns
-- 'MalformedMoney' and never rounds.
--
-- >>> moneyDecimalFromScientific (Scientific.scientific 1999 (-2))
-- Right 19.99
moneyDecimalFromScientific :: Scientific -> Either MoneyParseError MoneyDecimal
moneyDecimalFromScientific value
| mantissa < 0 = Left NegativeMoney
| exponent < -10000 || exponent > 10000 = Left MoneyExponentOutOfRange
| otherwise = moneyFromParts mantissa (negate (toInteger exponent))
where
mantissa = coefficient value
exponent = base10Exponent value
-- 'Nearly': for an exact type there is no rounding noise to tolerate, so the
-- tolerance argument is ignored and equality is exact. (Contrast the @Double@
-- instance, which uses a scale-aware tolerance.)
instance Nearly MoneyDecimal where
{-# INLINE isNearly #-}
isNearly x y _ = x == y
instance HatVal MoneyDecimal where
{-# INLINE zeroValue #-}
zeroValue = MoneyDecimal 0
-- Exact decimals have no NaN/Infinity; the only invalid value is a negative
-- amount, which violates the non-negativity invariant of the algebra. No
-- posting bound: sums never overflow.
{-# INLINE valueError #-}
valueError (MoneyDecimal x)
| x < 0 = Just NegativeValue
| otherwise = Nothing
-- Render exactly (e.g. "0.3", "12.34"); unlike the Double instance there is no
-- fixed-2-decimal formatting, because the decimal value is already exact.
{-# INLINE showValue #-}
showValue (MoneyDecimal x) = show x
-- Decimal addition is exact, so the state is the signed exact sum.
newtype Accum MoneyDecimal = MoneyDecimalAccum Decimal
emptyAccum = MoneyDecimalAccum 0
addAccum (MoneyDecimal value) (MoneyDecimalAccum total) =
MoneyDecimalAccum (total + value)
mergeAccum (MoneyDecimalAccum left) (MoneyDecimalAccum right) =
MoneyDecimalAccum (left + right)
negateAccum (MoneyDecimalAccum value) = MoneyDecimalAccum (negate value)
signAccum (MoneyDecimalAccum value) = Just (compare value 0)
roundAccum (MoneyDecimalAccum value) = MoneyDecimal value
splitAccum (MoneyDecimalAccum value)
| value > 0 = Just [MoneyDecimal value]
| otherwise = Nothing
exactAccum (MoneyDecimalAccum value) = Just (toRational value)
roundRational Nearest value = represent 0 (numerator value) (denominator value)
where
-- Each step supplies one decimal place without rounding.
represent places coefficient divisor
| divisor == 1 = Just (MoneyDecimal (Decimal places coefficient))
| places == 255 || common == 1 = Nothing
| otherwise = represent (places + 1)
(coefficient * (10 `div` common)) (divisor `div` common)
where
common = gcd divisor 10
roundRational (ToMultipleOf (MoneyDecimal unit)) value
| unit > 0 = Just (MoneyDecimal (fromInteger (round (value / toRational unit)) * unit))
| otherwise = Nothing
-- 'Binary'/'Hashable' are defined here (not orphan) because 'Data.Decimal' ships
-- neither, and 'Alg'/t'Journal' serialization and the binary spill path require
-- @Binary v@. 'Binary' keeps the (places, mantissa) structure of t'Decimal'.
-- 'Hashable' hashes the normalized form (trailing zeros removed), so values that
-- are equal under 'Eq' (@1.0 == 1.00@) have the same hash.
instance Binary.Binary MoneyDecimal where
{-# INLINE put #-}
put (MoneyDecimal (Decimal places mantissa)) = do
Binary.put (places :: Word8)
Binary.put (mantissa :: Integer)
{-# INLINE get #-}
get = do
places <- Binary.get :: Binary.Get Word8
mantissa <- Binary.get :: Binary.Get Integer
pure (MoneyDecimal (Decimal places mantissa))
instance Hashable MoneyDecimal where
{-# INLINE hashWithSalt #-}
hashWithSalt s (MoneyDecimal d) = case normalizeDecimal d of
Decimal places mantissa -> s `hashWithSalt` places `hashWithSalt` mantissa
instance NFData MoneyDecimal where
{-# INLINE rnf #-}
rnf (MoneyDecimal (Decimal places mantissa)) = rnf places `seq` rnf mantissa
-- * Fast floating-point value
-- | A fast IEEE-754 money value (wraps 'Prelude.Double').
--
-- This is the @newtype@ counterpart of the bare-@Double@ instance: a dedicated,
-- domain-specific money type so a ledger value cannot be silently confused with
-- an ABM coefficient, a random draw, or any other raw 'Double'. Every instance
-- it needs is owned here (via @deriving newtype@), so — exactly like
-- t'MoneyDecimal' — there are no orphan instances. Use t'MoneyDouble' for the same
-- speed as bare 'Double' while keeping the value type distinct in signatures.
--
-- Trade-off vs t'MoneyDecimal': addition is /non-associative/ (FP), so @norm@ \/
-- @bar@ can differ in the last ULP depending on construction order. It is fast
-- and runs everywhere bare 'Double' does (subtraction is signed, so the
-- intermediate negatives that arise inside @bar@\/@(.-)@ are fine — unlike
-- @Number.NonNegative.Double@, whose @(-)@ /errors/ on a negative result).
--
-- Non-negativity is the same /soft/ invariant as for t'MoneyDecimal' and bare
-- 'Double': not enforced by the constructor, but 'isErrorValue' reports
-- @isNaN x || isInfinite x || x < 0@, so the @(.\@)@ smart constructor and
-- @(.*)@ reject negative\/non-finite values.
newtype MoneyDouble = MoneyDouble Double
-- All instances are coerced from the existing bare-'Double' instances
-- ('Nearly'/'HatVal' live in "ExchangeAlgebra.Algebra"; 'Binary'/'Hashable'/
-- 'NFData' come from the binary/hashable/deepseq packages), so t'MoneyDouble'
-- is a zero-cost wrapper with identical numeric behavior and 2-decimal
-- 'showValue' formatting.
deriving newtype ( Eq, Ord, Show, Num, Fractional, Real, RealFrac
, Nearly, Hashable, NFData, Binary.Binary )
-- | Delegates to the 'Prelude.Double' accumulator. Written by hand because the
-- associated data family 'Accum' cannot be derived through a newtype.
instance HatVal MoneyDouble where
zeroValue = MoneyDouble zeroValue
isZeroValue (MoneyDouble x) = isZeroValue x
valueError (MoneyDouble x) = valueError x
postingUpperBound = fmap MoneyDouble postingUpperBound
showValue (MoneyDouble x) = showValue x
newtype Accum MoneyDouble = MoneyDoubleAccum (Accum Double)
emptyAccum = MoneyDoubleAccum emptyAccum
addAccum (MoneyDouble x) (MoneyDoubleAccum a) = MoneyDoubleAccum (addAccum x a)
mergeAccum (MoneyDoubleAccum a) (MoneyDoubleAccum b) = MoneyDoubleAccum (mergeAccum a b)
negateAccum (MoneyDoubleAccum a) = MoneyDoubleAccum (negateAccum a)
signAccum (MoneyDoubleAccum a) = signAccum a
roundAccum (MoneyDoubleAccum a) = MoneyDouble (roundAccum a)
splitAccum (MoneyDoubleAccum a) = fmap (map MoneyDouble) (splitAccum a)
exactAccum (MoneyDoubleAccum a) = exactAccum a
roundRational rule q = fmap MoneyDouble (roundRational (fmap' rule) q)
where
fmap' Nearest = Nearest
fmap' (ToMultipleOf (MoneyDouble u)) = ToMultipleOf u
-- | Project out the underlying 'Prelude.Double'.
toDouble :: MoneyDouble -> Double
toDouble (MoneyDouble d) = d
-- | Round a value to @n@ decimal places using /banker's rounding/
-- (round-half-to-even): the unbiased financial default. Ties go to the nearest
-- even digit (@2.5 -> 2@, @3.5 -> 4@, @0.125 -> 0.12@), so repeated rounding over
-- many transactions does not drift the total upward the way half-up does. This is
-- 'Prelude.round' applied per 'Data.Decimal.roundTo''.
--
-- Apply at the point a monetary amount is finalized after multiplication/division
-- (tax, proration, scalar product). The core algebra (add/subtract) is exact and
-- needs no rounding.
bankersRound :: Word8 -> MoneyDecimal -> MoneyDecimal
bankersRound places (MoneyDecimal d) = MoneyDecimal (roundTo' round places d)
-- | Round a value to @n@ decimal places by rounding /up/ (ceiling).
-- This suits jurisdictions whose rules round up.
-- Prefer 'bankersRound' unless a ceiling rule is specifically required.
ceilingRound :: Word8 -> MoneyDecimal -> MoneyDecimal
ceilingRound places (MoneyDecimal d) = MoneyDecimal (roundTo' ceiling places d)
-- * Accumulators for user-defined value types
-- | Exact rational state for a user-defined value type without special values
-- (no NaN or infinity). A complete instance for an exact amount of yen
-- (the type name avoids the unit constructor @Yen@):
--
-- > newtype JPY = JPY Rational
-- > deriving newtype (Eq, Ord, Show, Num, Fractional, Real)
-- >
-- > instance HatVal JPY where
-- > zeroValue = 0
-- > valueError (JPY x)
-- > | x < 0 = Just NegativeValue
-- > | otherwise = Nothing
-- > showValue (JPY x) = show (fromRational x :: Double)
-- >
-- > newtype Accum JPY = JPYAccum RationalAccum
-- > emptyAccum = JPYAccum (RationalAccum 0)
-- > addAccum x (JPYAccum a) = JPYAccum (rationalAddAccum x a)
-- > mergeAccum (JPYAccum (RationalAccum a)) (JPYAccum (RationalAccum b)) = JPYAccum (RationalAccum (a + b))
-- > negateAccum (JPYAccum (RationalAccum a)) = JPYAccum (RationalAccum (negate a))
-- > signAccum (JPYAccum (RationalAccum a)) = Just (compare a 0)
-- > roundAccum (JPYAccum a) = rationalRoundAccum JPY a
-- > splitAccum (JPYAccum (RationalAccum a))
-- > | a > 0 = Just [JPY a]
-- > | otherwise = Nothing
-- > exactAccum (JPYAccum (RationalAccum a)) = Just a
-- > roundRational Nearest q = Just (JPY q)
-- > roundRational (ToMultipleOf (JPY u)) q
-- > | u > 0 = Just (JPY (u * fromInteger (round (q / u))))
-- > | otherwise = Nothing
--
-- Every value of such a type is finite, so laws A3 and A6 hold by construction;
-- the instance still has to satisfy A5' ('splitAccum' succeeds on every positive
-- state) and T1-T3. 'Prelude.round' rounds ties to even.
newtype RationalAccum = RationalAccum Rational
deriving (Eq, Ord, Show)
-- | Add a finite value of a 'Real' type exactly.
rationalAddAccum :: Real n => n -> RationalAccum -> RationalAccum
rationalAddAccum value (RationalAccum total) = RationalAccum (total + toRational value)
-- | Round the exact value with a function the user supplies (for example
-- 'fromRational'). 'Real' alone cannot guarantee ties-to-even, so the rule is
-- the caller's.
rationalRoundAccum :: (Rational -> n) -> RationalAccum -> n
rationalRoundAccum convert (RationalAccum total) = convert total