diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,19 @@ -# Changelog for decimal64 +# Changelog for safe-decimal -## Unreleased changes +## 0.2.0 + +* Add `Arith` monad and corresponding functions. +* Make rounding dependent on precision type (extra type argument to the `Round` type class) +* Rename `RoundFloor` to `RoundDown` (with `Floor` as synonym) +* Rename `Truncate` to `RoundToZero` (with `Truncate` as synonym) +* Fix conversion `fromRational` to throw `Underflow` instead of rounding. Without this fix + there was unexpected behavior on negative numbers. +* Addition of `scaleUp` and `scaleUpBounded` +* Addition of `toFixedDecimal`, `fromFixedDecimal` and `fromFixedDecimalBounded` +* Many function renames, just to make sure they all follow the same convention. +* Fix `RoundHalfUp` algorithm +* Addition of `RoundHalfDown` and `RoundHalfEven` + +## 0.1.0 + +Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,14 @@ # safe-decimal -An implementation of a decimal point data type, that is backed by any custom integral type. It is -safe, because all runtime exceptions and integer overflows are prevented on arithmetic operations, -namely things like integer overflows, underflows, division by zero etc. are checked for during the -runtime. +| Language | Travis | +|:--------:|:------:| +| ![GitHub top language](https://img.shields.io/github/languages/top/fpco/safe-decimal.svg) | [![Travis](https://img.shields.io/travis/fpco/safe-decimal/master.svg?label=Linux%20%26%20OS%20X)](https://travis-ci.org/fpco/safe-decimal) | + +| Package | Hackage | Nightly | LTS | +|:-------------------|:-------:|:-------:|:---:| +| [`safe-decimal`](https://github.com/fpco/safe-decimal/tree/master/safe-decimal)| [![Hackage](https://img.shields.io/hackage/v/safe-decimal.svg)](https://hackage.haskell.org/package/safe-decimal)| [![Nightly](https://www.stackage.org/package/safe-decimal/badge/nightly)](https://www.stackage.org/nightly/package/safe-decimal)| [![Nightly](https://www.stackage.org/package/safe-decimal/badge/lts)](https://www.stackage.org/lts/package/safe-decimal)| + + +An implementation of a decimal point data type, that is backed by any custom integral +type. It is safe, because things like integer overflows, underflows, division by zero +etc. are checked for during the runtime and are prevented in pure code. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,34 @@ +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -Wall #-} +module Main (main) where + +#ifndef MIN_VERSION_cabal_doctest +#define MIN_VERSION_cabal_doctest(x,y,z) 0 +#endif + +#if MIN_VERSION_cabal_doctest(1,0,0) + +import Distribution.Extra.Doctest ( defaultMainWithDoctests ) +main :: IO () +main = defaultMainWithDoctests "doctests" + +#else + +#ifdef MIN_VERSION_Cabal +-- If the macro is defined, we have new cabal-install, +-- but for some reason we don't have cabal-doctest in package-db +-- +-- Probably we are running cabal sdist, when otherwise using new-build +-- workflow +#warning You are configuring this package without cabal-doctest installed. \ + The doctests test-suite will not work as a result. \ + To fix this, install cabal-doctest before configuring. +#endif + import Distribution.Simple + +main :: IO () main = defaultMain + +#endif + diff --git a/safe-decimal.cabal b/safe-decimal.cabal --- a/safe-decimal.cabal +++ b/safe-decimal.cabal @@ -1,5 +1,5 @@ name: safe-decimal -version: 0.1.0.0 +version: 0.2.0.0 description: Please see the README on GitHub at synopsis: Safe and very efficient arithmetic operations on fixed decimal point numbers category: Math, Numeric, Numerical @@ -10,7 +10,7 @@ copyright: 2018-2019 FP Complete license: BSD3 license-file: LICENSE -build-type: Simple +build-type: Custom cabal-version: >= 1.10 extra-source-files: ChangeLog.md README.md @@ -19,16 +19,40 @@ type: git location: https://github.com/fpco/safe-decimal +custom-setup + setup-depends: + base + , Cabal + , cabal-doctest >=1.0.6 + library exposed-modules: Numeric.Decimal + , Numeric.Decimal.BoundedArithmetic other-modules: Numeric.Decimal.Internal hs-source-dirs: src - build-depends: base >=4.7 && <5 + build-depends: base >=4.8 && <5 , deepseq , exceptions , scientific ghc-options: -Wall default-language: Haskell2010 + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: doctests.hs + build-depends: base + , doctest >=0.15 + , QuickCheck + , safe-decimal + , template-haskell + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-orphans + -threaded test-suite tests type: exitcode-stdio-1.0 diff --git a/src/Numeric/Decimal.hs b/src/Numeric/Decimal.hs --- a/src/Numeric/Decimal.hs +++ b/src/Numeric/Decimal.hs @@ -1,117 +1,503 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} module Numeric.Decimal - ( Decimal64 + ( + -- * Arithmetic + module Numeric.Decimal.BoundedArithmetic + , module Numeric.Decimal.Internal + -- * Rounding + -- ** Round half up , RoundHalfUp - , RoundFloor + , roundHalfUp + -- ** Round half down + , RoundHalfDown + , roundHalfDown + -- ** Round half even + , RoundHalfEven + , roundHalfEven + -- ** Round down + , RoundDown + , Floor + , roundDown + -- ** Round towards zero + , RoundToZero , Truncate - , module Numeric.Decimal.Internal + , roundToZero -- * Operations , decimalList - , sumDecimal - , productDecimal + , sumDecimalBounded + , productDecimalBoundedWithRounding -- * Conversion - , toScientific - , fromScientific - , fromScientificBounded + -- ** Fixed + , FixedScale + , toFixedDecimal + , fromFixedDecimal + , fromFixedDecimalBounded + -- ** Scientific + , toScientificDecimal + , fromScientificDecimal + , fromScientificDecimalBounded ) where -import Control.Exception -import Control.Monad -import Control.Monad.Catch -import Data.Coerce -import Data.Int -import Data.Proxy -import Data.Scientific -import GHC.TypeLits -import Numeric.Decimal.Internal +import Control.Exception +import Control.Monad +import Control.Monad.Catch +import Data.Coerce +import Data.Fixed +import Data.Int +import Data.Word +import Data.Proxy +import Data.Scientific +import GHC.TypeLits +import Numeric.Decimal.BoundedArithmetic +import Numeric.Decimal.Internal --- | Most common Decimal type backed by `Int64` and standard rounding -type Decimal64 s = Decimal RoundHalfUp s Int64 +-- | [Round half up](https://en.wikipedia.org/wiki/Rounding#Round_half_up) rounding strategy: +-- +-- >>> :set -XDataKinds +-- >>> roundDecimal <$> (3.740 :: Arith (Decimal RoundHalfUp 3 Int)) :: Arith (Decimal RoundHalfUp 1 Int) +-- Arith 3.7 +-- +-- Or with a bit more concise approach using `arithRoundD` and @TypeApplications@: +-- +-- >>> :set -XTypeApplications +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int 3.740 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int 3.749 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int 3.750 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int 3.751 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int 3.760 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int (-3.740) +-- Arith -3.7 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int (-3.749) +-- Arith -3.7 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int (-3.750) +-- Arith -3.7 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int (-3.751) +-- Arith -3.8 +-- >>> arithRoundD @1 @RoundHalfUp @3 @Int (-3.760) +-- Arith -3.8 +-- +-- @since 0.1.0 data RoundHalfUp -instance Round RoundHalfUp where - roundDecimal :: forall r n k p . (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p - roundDecimal (Decimal x) - | k == 0 = Decimal x - | r < 5 * 10 ^ (k - 1) = Decimal q - | otherwise = Decimal (q + 1) +instance Round RoundHalfUp Integer where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Int where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Int8 where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Int16 where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Int32 where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Int64 where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Word where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Word8 where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Word16 where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Word32 where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfUp Word64 where + roundDecimal = roundHalfUp + {-# INLINABLE roundDecimal #-} + +roundHalfUp :: forall r n k p . (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p +roundHalfUp (Decimal x) + | k == 0 = Decimal x + | r >= s1 = Decimal (q + 1) + | signum r < 0 && abs r > s1 = Decimal (q - 1) + | otherwise = Decimal q where k = fromIntegral (natVal (Proxy :: Proxy k)) :: Int - (q, r) = quotRem x (10 ^ k) - {-# INLINABLE roundDecimal #-} + s1 = 10 ^ k + (q, r) = (2 *) <$> quotRem x s1 +{-# INLINABLE roundHalfUp #-} -data RoundFloor +-- | [Round half down](https://en.wikipedia.org/wiki/Rounding#Round_half_down) rounding strategy: +-- +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int 3.740 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int 3.749 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int 3.750 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int 3.751 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int 3.760 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int (-3.740) +-- Arith -3.7 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int (-3.749) +-- Arith -3.7 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int (-3.750) +-- Arith -3.8 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int (-3.751) +-- Arith -3.8 +-- >>> arithRoundD @1 @RoundHalfDown @3 @Int (-3.760) +-- Arith -3.8 +-- +-- @since 0.2.0 +data RoundHalfDown -instance Round RoundFloor where - roundDecimal :: forall r n k p . (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p - roundDecimal (Decimal x) - | x >= 0 || r == 0 = Decimal q - | otherwise = Decimal (q - 1) +instance Round RoundHalfDown Integer where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Int where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Int8 where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Int16 where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Int32 where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Int64 where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Word where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Word8 where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Word16 where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Word32 where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfDown Word64 where + roundDecimal = roundHalfDown + {-# INLINABLE roundDecimal #-} + +roundHalfDown :: forall r n k p . (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p +roundHalfDown (Decimal x) + | k == 0 = Decimal x + | r > s1 = Decimal (q + 1) + | signum r < 0 && abs r >= s1 = Decimal (q - 1) + | otherwise = Decimal q where k = fromIntegral (natVal (Proxy :: Proxy k)) :: Int - (q, r) = quotRem x (10 ^ k) - {-# INLINABLE roundDecimal #-} + s1 = 10 ^ k + (q, r) = (2 *) <$> quotRem x s1 +{-# INLINABLE roundHalfDown #-} -data Truncate +-- | [Round half even](https://en.wikipedia.org/wiki/Rounding#Round_half_to_even) rounding +-- strategy. If the fractional part of x is 0.5, then y is the even integer nearest to +-- x. This is the default rounding strategy in Haskell implemented by `round`. +-- +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int 3.650 +-- Arith 3.6 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int 3.740 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int 3.749 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int 3.750 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int 3.751 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int 3.760 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int (-3.650) +-- Arith -3.6 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int (-3.740) +-- Arith -3.7 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int (-3.749) +-- Arith -3.7 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int (-3.750) +-- Arith -3.8 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int (-3.751) +-- Arith -3.8 +-- >>> arithRoundD @1 @RoundHalfEven @3 @Int (-3.760) +-- Arith -3.8 +-- +-- @since 0.2.0 +data RoundHalfEven -instance Round Truncate where - roundDecimal :: forall r n k p . (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p - roundDecimal (Decimal x) = Decimal (quot x (10 ^ k)) +instance Round RoundHalfEven Integer where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Int where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Int8 where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Int16 where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Int32 where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Int64 where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Word where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Word8 where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Word16 where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Word32 where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} +instance Round RoundHalfEven Word64 where + roundDecimal = roundHalfEven + {-# INLINABLE roundDecimal #-} + +roundHalfEven :: forall r n k p . (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p +roundHalfEven (Decimal x) + | k == 0 = Decimal x + | abs r == s1 && odd q = Decimal (q + signum r) + | abs r == s1 = Decimal q + | r > s1 = Decimal (q + 1) + | signum r < 0 && abs r > s1 = Decimal (q - 1) + | otherwise = Decimal q where k = fromIntegral (natVal (Proxy :: Proxy k)) :: Int + s1 = 10 ^ k + (q, r) = (2 *) <$> quotRem x s1 +{-# INLINABLE roundHalfEven #-} + +-- | [Round down](https://en.wikipedia.org/wiki/Rounding#Rounding_down) rounding +-- startegy. This the strategy that is implemented by `floor`. Round towards minus +-- infinity: +-- +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> arithRoundD @1 @RoundDown @2 @Int 3.65 +-- Arith 3.6 +-- >>> arithRoundD @1 @RoundDown @2 @Int 3.75 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundDown @2 @Int 3.89 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundDown @2 @Int (-3.65) +-- Arith -3.7 +-- +-- @since 0.2.0 +data RoundDown + +-- | Synonym for round down +-- +-- @since 0.2.0 +type Floor = RoundDown + +instance Round RoundDown Integer where + roundDecimal = roundDown +instance Round RoundDown Int where + roundDecimal = roundDown {-# INLINABLE roundDecimal #-} +instance Round RoundDown Int8 where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +instance Round RoundDown Int16 where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +instance Round RoundDown Int32 where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +instance Round RoundDown Int64 where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +instance Round RoundDown Word where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +instance Round RoundDown Word8 where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +instance Round RoundDown Word16 where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +instance Round RoundDown Word32 where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +instance Round RoundDown Word64 where + roundDecimal = roundDown + {-# INLINABLE roundDecimal #-} +roundDown :: forall r n k p . (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p +roundDown (Decimal x) + | x >= 0 || r == 0 = Decimal q + | otherwise = Decimal (q - 1) + where + k = fromIntegral (natVal (Proxy :: Proxy k)) :: Int + (q, r) = quotRem x (10 ^ k) +{-# INLINABLE roundDown #-} + +-- | [Round towards zero](https://en.wikipedia.org/wiki/Rounding#Round_towards_zero) +-- strategy. Similar to Haskell's `truncate`. Drop the fractional digits, regardless of +-- the sign. +-- +-- >>> :set -XDataKinds +-- >>> :set -XTypeApplications +-- >>> arithRoundD @1 @RoundToZero @2 @Int 3.65 +-- Arith 3.6 +-- >>> arithRoundD @1 @RoundToZero @2 @Int 3.75 +-- Arith 3.7 +-- >>> arithRoundD @1 @RoundToZero @2 @Int 3.89 +-- Arith 3.8 +-- >>> arithRoundD @1 @RoundToZero @2 @Int (-3.65) +-- Arith -3.6 +-- +-- @since 0.2.0 +data RoundToZero + + +-- | Synonym for `RoundToZero` +-- +-- @since 0.1.0 +type Truncate = RoundToZero + +instance Round RoundToZero Integer where + roundDecimal = roundToZero +instance Round RoundToZero Int where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Int8 where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Int16 where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Int32 where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Int64 where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Word where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Word8 where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Word16 where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Word32 where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} +instance Round RoundToZero Word64 where + roundDecimal = roundToZero + {-# INLINABLE roundDecimal #-} + +roundToZero :: forall r n k p . (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p +roundToZero (Decimal x) = Decimal (quot x (10 ^ k)) + where + k = fromIntegral (natVal (Proxy :: Proxy k)) :: Int +{-# INLINABLE roundToZero #-} + -- | /O(1)/ - Conversion of a list. -- -- __Note__: It doesn't do any scaling, eg: -- +-- >>> :set -XDataKinds +-- >>> import Numeric.Decimal -- >>> decimalList [1,20,300] :: [Decimal RoundHalfUp 2 Int] -- [0.01,0.20,3.00] -- -- If scaling is what you need use `fromIntegral` instead: -- --- >>> mapM fromIntegral ([1,20,300] :: [Int]) :: Either SomeException [Decimal RoundHalfUp 2 Int] --- Right [1.00,20.00,300.00] +-- >>> sequenceA [1, 20, 300] :: Arith [Decimal RoundHalfUp 2 Int] +-- Arith [1.00,20.00,300.00] -- +-- @since 0.1.0 decimalList :: Integral p => [p] -> [Decimal r s p] decimalList = coerce -- | Sum a list of decimal numbers -sumDecimal :: +-- +-- >>> :set -XDataKinds +-- >>> sequenceA [1.1, 20.02, 300.003] >>= sumDecimalBounded :: Arith (Decimal RoundHalfUp 3 Int) +-- Arith 321.123 +-- +-- @since 0.2.0 +sumDecimalBounded :: (MonadThrow m, Foldable f, Eq p, Ord p, Num p, Bounded p) => f (Decimal r s p) -> m (Decimal r s p) -sumDecimal = foldM plusDecimal (Decimal 0) -{-# INLINABLE sumDecimal #-} +sumDecimalBounded = foldM plusDecimalBounded (Decimal 0) +{-# INLINABLE sumDecimalBounded #-} -- | Multiply all decimal numbers in the list while doing rounding. -productDecimal :: - (MonadThrow m, Foldable f, KnownNat s, Round r, Integral p, Bounded p) +-- +-- >>> :set -XDataKinds +-- >>> product [1.1, 20.02, 300.003] :: Double +-- 6606.666066000001 +-- >>> xs <- arithM (mapM fromRational [1.1, 20.02, 300.003] :: Arith [Decimal RoundHalfUp 4 Int]) +-- >>> xs +-- [1.1000,20.0200,300.0030] +-- >>> productDecimalBoundedWithRounding xs +-- 6606.6661 +-- +-- @since 0.2.0 +productDecimalBoundedWithRounding :: + (MonadThrow m, Foldable f, KnownNat s, Round r Integer, Integral p, Bounded p) => f (Decimal r s p) -> m (Decimal r s p) -productDecimal = foldM timesDecimalRounded (fromNum 1) -{-# INLINABLE productDecimal #-} - +productDecimalBoundedWithRounding ds = + fromIntegralDecimalBounded 1 >>= + (\acc -> foldM timesDecimalBoundedWithRounding acc ds) +{-# INLINABLE productDecimalBoundedWithRounding #-} ---- Scientific --- | Convert Decimal to Scientific -toScientific :: (Integral p, KnownNat s) => Decimal r s p -> Scientific -toScientific dec = scientific (toInteger (unwrapDecimal dec)) (negate (getScale dec)) +-- | Convert a `Decimal` to `Scientific` +-- +-- @since 0.1.0 +toScientificDecimal :: (Integral p, KnownNat s) => Decimal r s p -> Scientific +toScientificDecimal dec = + scientific + (toInteger (unwrapDecimal dec)) + (fromInteger (negate (getScale dec))) + -- | Convert Scientific to Decimal without loss of precision. Will return `Left` `Underflow` if -- `Scientific` has too many decimal places, more than `Decimal` scaling is capable to handle. -fromScientific :: forall m r s . (MonadThrow m, KnownNat s) => Scientific -> m (Decimal r s Integer) -fromScientific num +-- +-- @since 0.1.0 +fromScientificDecimal :: + forall m r s. (MonadThrow m, KnownNat s) + => Scientific + -> m (Decimal r s Integer) +fromScientificDecimal num | point10 > s = throwM Underflow | otherwise = pure (Decimal (coefficient num * 10 ^ (s - point10))) where @@ -119,10 +505,61 @@ point10 = toInteger (negate (base10Exponent num)) -- | Convert from Scientific to Decimal while checking for Overflow/Underflow -fromScientificBounded :: +-- +-- @since 0.1.0 +fromScientificDecimalBounded :: forall m r s p. (MonadThrow m, Integral p, Bounded p, KnownNat s) => Scientific -> m (Decimal r s p) -fromScientificBounded num = do - Decimal integer :: Decimal r s Integer <- fromScientific num +fromScientificDecimalBounded num = do + Decimal integer :: Decimal r s Integer <- fromScientificDecimal num Decimal <$> fromIntegerBounded integer + + +type family FixedScale e :: Nat + +type instance FixedScale E0 = 0 +type instance FixedScale E1 = 1 +type instance FixedScale E2 = 2 +type instance FixedScale E3 = 3 +type instance FixedScale E6 = 6 +type instance FixedScale E9 = 9 +type instance FixedScale E12 = 12 + + +-- | Convert a `Decimal` to a `Fixed` with the exactly same precision. +-- +-- >>> toFixedDecimal <$> (3.65 :: Arith (Decimal RoundDown 2 Int)) :: Arith (Fixed E2) +-- Arith 3.65 +-- >>> toFixedDecimal $ fromFixedDecimal (123.45 :: Fixed E2) :: Fixed E2 +-- 123.45 +-- +-- @since 0.2.0 +toFixedDecimal :: (s ~ FixedScale e, Integral p) => Decimal r s p -> Fixed e +toFixedDecimal = MkFixed . toInteger . unwrapDecimal + +-- | Convert a `Fixed` to a `Decimal` with the exactly same precision +-- +-- >>> fromFixedDecimal (123.45 :: Fixed E2) +-- 123.45 +-- +-- @since 0.2.0 +fromFixedDecimal :: s ~ FixedScale e => Fixed e -> Decimal r s Integer +fromFixedDecimal = coerce + +-- | Convert a `Fixed` to a decimal backed by a bounded integral with the exactly same +-- precision +-- +-- >>> fromFixedDecimalBounded (123.458 :: Fixed E3) :: Arith (Decimal RoundToZero 3 Int) +-- Arith 123.458 +-- >>> fromFixedDecimalBounded (123.458 :: Fixed E3) :: Arith (Decimal RoundToZero 3 Int8) +-- ArithError arithmetic overflow +-- >>> fromFixedDecimalBounded (-123.458 :: Fixed E3) :: Arith (Decimal RoundToZero 3 Word) +-- ArithError arithmetic underflow +-- +-- @since 0.2.0 +fromFixedDecimalBounded :: + (s ~ FixedScale e, MonadThrow m, Integral p, Bounded p) + => Fixed e + -> m (Decimal r s p) +fromFixedDecimalBounded = fromIntegerDecimalBounded . fromFixedDecimal diff --git a/src/Numeric/Decimal/BoundedArithmetic.hs b/src/Numeric/Decimal/BoundedArithmetic.hs new file mode 100644 --- /dev/null +++ b/src/Numeric/Decimal/BoundedArithmetic.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Numeric.Decimal.BoundedArithmetic + ( + -- * Arith Monad + Arith(..) + , arithM + , arithMaybe + , arithEither + -- * Bounded + , plusBounded + , minusBounded + , timesBounded + , absBounded + , fromIntegerBounded + , divBounded + , quotBounded + , quotRemBounded + ) where + +import Control.Exception +import Control.Monad.Catch + +-- | Monad for performing safe computation +data Arith a + = Arith !a + | ArithError !SomeException + + +-- | Convert `Arith` computation to any `MonadThrow` +-- +-- >>> import Numeric.Decimal +-- >>> :set -XDataKinds +-- >>> arithM (1.1 * 123 :: Arith (Decimal RoundDown 3 Int)) +-- 135.300 +-- >>> arithM (1.1 - 123 :: Arith (Decimal RoundDown 3 Word)) +-- *** Exception: arithmetic underflow +-- >>> 1.1 - 123 :: Arith (Decimal RoundDown 3 Word) +-- ArithError arithmetic underflow +-- +-- @since 0.2.0 +arithM :: MonadThrow m => Arith a -> m a +arithM = \case + Arith a -> pure a + ArithError exc -> throwM exc + +-- | A version of `arithM` restricted to `Maybe` +-- +-- @since 0.2.0 +arithMaybe :: Arith a -> Maybe a +arithMaybe = arithM + +-- | A version of `arithM` restricted to `Either` +-- +-- @since 0.2.0 +arithEither :: Arith a -> Either SomeException a +arithEither = arithM + + +instance Show a => Show (Arith a) where + showsPrec n r = + case r of + Arith a -> showsA "Arith" (shows a) + ArithError exc -> showsA "ArithError" (displayException exc ++) + where + showsA prefix content = + let showsExc = (prefix ++) . (' ':) . content + in if n == 0 + then showsExc + else ('(' :) . showsExc . (')' :) + +instance Functor Arith where + fmap f a = + case a of + Arith r -> Arith (f r) + ArithError exc -> ArithError exc + {-# INLINE fmap #-} + +instance Applicative Arith where + pure = Arith + {-# INLINE pure #-} + (<*>) fa a = + case fa of + Arith fr -> + case a of + Arith r -> Arith (fr r) + ArithError exc -> ArithError exc + ArithError exc -> ArithError exc + {-# INLINE (<*>) #-} + +instance Monad Arith where + return = Arith + {-# INLINE return #-} + (>>=) fa fab = + case fa of + Arith fr -> fab fr + ArithError exc -> ArithError exc + {-# INLINE (>>=) #-} + + +instance MonadThrow Arith where + throwM = ArithError . toException + {-# INLINE throwM #-} + + +----------------------------------- +-- Bounded arithmetics ------------ +----------------------------------- + +-- | Add two bounded numbers while checking for `Overflow`/`Underflow` +-- +-- @since 0.1.0 +plusBounded :: (MonadThrow m, Ord a, Num a, Bounded a) => a -> a -> m a +plusBounded x y + | sameSig && sigX == 1 && x > maxBound - y = throwM Overflow + | sameSig && sigX == -1 && x < minBound - y = throwM Underflow + | otherwise = pure (x + y) + where + sigX = signum x + sigY = signum y + sameSig = sigX == sigY +{-# INLINABLE plusBounded #-} + +-- | Subtract two bounded numbers while checking for `Overflow`/`Underflow` +-- +-- @since 0.1.0 +minusBounded :: (MonadThrow m, Ord a, Num a, Bounded a) => a -> a -> m a +minusBounded x y + | sigY == -1 && x > maxBound + y = throwM Overflow + | sigY == 1 && x < minBound + y = throwM Underflow + | otherwise = pure (x - y) + where sigY = signum y +{-# INLINABLE minusBounded #-} + +-- | Compute absolute value, while checking for `Overflow` +-- +-- @since 0.2.0 +absBounded :: (MonadThrow m, Num p, Ord p) => p -> m p +absBounded d + | absd < 0 = throwM Overflow + | otherwise = pure absd + where + absd = abs d +{-# INLINABLE absBounded #-} + + +-- | Divide two numbers while checking for `Overflow` and `DivideByZero` +-- +-- @since 0.1.0 +divBounded :: (MonadThrow m, Integral a, Bounded a) => a -> a -> m a +divBounded x y + | y == 0 = throwM DivideByZero + | signum y == -1 && y == -1 && x == minBound = throwM Overflow + ------------------- ^ Here we deal with special case overflow when (minBound * (-1)) + | otherwise = pure (x `div` y) +{-# INLINABLE divBounded #-} + + +-- | Find quotient of two numbers while checking for `Overflow` and `DivideByZero` +-- +-- @since 0.1.0 +quotBounded :: (MonadThrow m, Integral a, Bounded a) => a -> a -> m a +quotBounded x y + | y == 0 = throwM DivideByZero + | sigY == -1 && y == -1 && x == minBound = throwM Overflow + ------------------- ^ Here we deal with special case overflow when (minBound * (-1)) + | otherwise = pure (x `quot` y) + where + sigY = signum y -- Guard against wraparound in case of unsigned Word +{-# INLINABLE quotBounded #-} + +-- | Find quotient an remainder of two numbers while checking for `Overflow` and +-- `DivideByZero` +-- +-- @since 0.1.0 +quotRemBounded :: (MonadThrow m, Integral a, Bounded a) => a -> a -> m (a, a) +quotRemBounded x y + | y == 0 = throwM DivideByZero + | sigY == -1 && y == -1 && x == minBound = throwM Overflow + | otherwise = pure (x `quotRem` y) + where + sigY = signum y +{-# INLINABLE quotRemBounded #-} + + +-- | Multiply two numbers while checking for `Overflow` +-- +-- @since 0.1.0 +timesBounded :: (MonadThrow m, Integral a, Bounded a) => a -> a -> m a +timesBounded x y + | sigY == -1 && y == -1 && x == minBound = throwM Overflow + | signum x == -1 && x == -1 && y == minBound = throwM Overflow + | sigY == 1 && (minBoundQuotY > x || x > maxBoundQuotY) = eitherOverUnder + | sigY == -1 && y /= -1 && (minBoundQuotY < x || x < maxBoundQuotY) = eitherOverUnder + | otherwise = pure (x * y) + where + sigY = signum y + maxBoundQuotY = maxBound `quot` y + minBoundQuotY = minBound `quot` y + eitherOverUnder = throwM $ if sigY == signum x then Overflow else Underflow +{-# INLINABLE timesBounded #-} + +-- | Convert from an unbounded `Integer` to a `Bounded` `Integral`, while checking for +-- bounds and raising `Overflow`/`Underflow` +-- +-- @since 0.1.0 +fromIntegerBounded :: + forall m a. (MonadThrow m, Integral a, Bounded a) + => Integer + -> m a +fromIntegerBounded x + | x > toInteger (maxBound :: a) = throwM Overflow + | x < toInteger (minBound :: a) = throwM Underflow + | otherwise = pure $ fromInteger x +{-# INLINABLE fromIntegerBounded #-} + diff --git a/src/Numeric/Decimal/Internal.hs b/src/Numeric/Decimal/Internal.hs --- a/src/Numeric/Decimal/Internal.hs +++ b/src/Numeric/Decimal/Internal.hs @@ -1,684 +1,1088 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -module Numeric.Decimal.Internal - ( Decimal(..) - , Round(..) - , wrapDecimal - , unwrapDecimal - , splitDecimal - , getScale - , fromNum - , parseDecimalBounded - -- * Algebra - , plusDecimal - , minusDecimal - , timesDecimal - , signumDecimal - , timesDecimalBounded - , timesDecimalRounded - , divideDecimal - , quotRemBounded - , quotRemDecimalBounded - , fromIntegerDecimalBounded - , fromRationalDecimalRounded - , liftDecimal - , liftDecimal2 - , bindM2Decimal - , bindM2 - -- * Bounded - , plusBounded - , minusBounded - , timesBounded - , fromIntegerBounded - , fromIntegerScaleBounded - , divBounded - , quotBounded - ) where - -import Control.Applicative -import Control.DeepSeq -import Control.Exception -import Control.Monad -import Control.Monad.Catch -import Data.Char -import Data.Foldable as F -import Data.Int -import Data.List -import Data.Proxy -import Data.Ratio -import Data.Word -import GHC.Generics (Generic) -import GHC.TypeLits -import Text.Printf - - --- | Decimal number with custom precision (@p@) and type level scaling (@s@) parameter (i.e. number --- of digits after the decimal point). As well as the rounding (@r@) strategy to use -newtype Decimal r (s :: Nat) p = Decimal p - deriving (Enum, Ord, Eq, NFData, Functor, Generic) - -instance Applicative (Decimal r s) where - pure = Decimal - {-# INLINABLE pure #-} - (<*>) (Decimal f) (Decimal x) = Decimal (f x) - {-# INLINABLE (<*>) #-} - - -class Round r where - roundDecimal :: (Integral p, KnownNat k) => Decimal r (n + k) p -> Decimal r n p - - --- | Get the scale of the `Decimal`. Argument is not evaluated. -getScale :: forall r s p . KnownNat s => Decimal r s p -> Int -getScale _ = fromIntegral (natVal (Proxy :: Proxy s)) - --- | Split the number at the decimal point, i.e. whole number and the fraction -splitDecimal :: (Integral p, KnownNat s) => Decimal r s p -> (p, p) -splitDecimal d@(Decimal v) = v `quotRem` (10 ^ getScale d) - --- | Wrap an `Integral` as a `Decimal`. No scaling will be done. -wrapDecimal :: Integral p => p -> Decimal r s p -wrapDecimal = Decimal - --- | Get out the underlying representation for the decimal number. No scaling will be done. -unwrapDecimal :: Decimal r s p -> p -unwrapDecimal (Decimal p) = p - --- | This operation is susceptible to overflows, since it performs the scaling. -fromNum :: forall r s p . (Num p, KnownNat s) => p -> Decimal r s p -fromNum x = Decimal (x * (10 ^ s)) - where - s = natVal (Proxy :: Proxy s) -{-# INLINABLE fromNum #-} - - -liftDecimal :: (p1 -> p2) -> Decimal r s p1 -> Decimal r s p2 -liftDecimal f (Decimal x) = Decimal (f x) -{-# INLINABLE liftDecimal #-} - -liftDecimal2 :: (p1 -> p2 -> p3) -> Decimal r s p1 -> Decimal r s p2 -> Decimal r s p3 -liftDecimal2 f (Decimal x) (Decimal y) = Decimal (f x y) -{-# INLINABLE liftDecimal2 #-} - -bindM2Decimal :: - Monad m - => (p1 -> p2 -> m p) - -> m (Decimal r1 s1 p1) - -> m (Decimal r2 s2 p2) - -> m (Decimal r s p) -bindM2Decimal f dx dy = do - Decimal x <- dx - Decimal y <- dy - Decimal <$> f x y -{-# INLINABLE bindM2Decimal #-} - - -bindM2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c -bindM2 f mx my = do - x <- mx - y <- my - f x y -{-# INLINABLE bindM2 #-} - - -instance Bounded p => Bounded (Decimal r s p) where - minBound = Decimal minBound - maxBound = Decimal maxBound - ------------------------------------ --- Integer instances -------------- ------------------------------------ - -instance (Round r, KnownNat s) => Num (Decimal r s Integer) where - (+) = liftA2 (+) - {-# INLINABLE (+) #-} - (-) = liftDecimal2 (-) - {-# INLINABLE (-) #-} - (*) = liftDecimal2 (*) - {-# INLINABLE (*) #-} - signum = signumDecimal - {-# INLINABLE signum #-} - abs = fmap abs - {-# INLINABLE abs #-} - fromInteger = fromNum - {-# INLINABLE fromInteger #-} - -instance (Round r, KnownNat s) => Real (Decimal r s Integer) where - toRational (Decimal p) = p % (10 ^ natVal (Proxy :: Proxy s)) - {-# INLINABLE toRational #-} - --- | The order of fractional and negation for literals prevents rational numbers to be negative in --- `fromRational` function, which can cause some issues in rounding: --- --- >>> fromRational (-23.5) :: Either SomeException (Decimal RoundHalfUp 0 Integer) --- Right -23 --- >>> -23.5 :: Either SomeException (Decimal RoundHalfUp 0 Integer) --- Right -24 -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Integer)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational = fromRationalDecimalRounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Integer)) where - (+) = liftA2 (+) - {-# INLINABLE (+) #-} - (-) = liftA2 (-) - {-# INLINABLE (-) #-} - (*) x y = roundDecimal <$> liftA2 timesDecimal x y - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = fmap (fmap abs) - {-# INLINABLE abs #-} - fromInteger = pure . fromNum - {-# INLINABLE fromInteger #-} - - ------------------------------------ --- Bounded Integral instances ----- ------------------------------------ - - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Int)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = fmap (fmap abs) - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Int8)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = fmap (fmap abs) - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Int16)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = fmap (fmap abs) - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Int32)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = fmap (fmap abs) - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Int64)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = fmap (fmap abs) - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Word)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = id - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Word8)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = id - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Word16)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = id - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Word32)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = id - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Num (m (Decimal r s Word64)) where - (+) = bindM2 plusDecimal - {-# INLINABLE (+) #-} - (-) = bindM2 minusDecimal - {-# INLINABLE (-) #-} - (*) = bindM2 timesDecimalRounded - {-# INLINABLE (*) #-} - signum = fmap signumDecimal - {-# INLINABLE signum #-} - abs = id - {-# INLINABLE abs #-} - fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) - {-# INLINABLE fromInteger #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Int)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Int8)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Int16)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Int32)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Int64)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Word)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Word8)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Word16)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Word32)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -instance (MonadThrow m, Round r, KnownNat s) => Fractional (m (Decimal r s Word64)) where - (/) = bindM2 divideDecimal - {-# INLINABLE (/) #-} - fromRational r = fromRational r >>= fromIntegerDecimalBounded - {-# INLINABLE fromRational #-} - -divideDecimal :: - (MonadThrow m, Fractional (m (Decimal r s p)), Integral p, Integral p) - => Decimal r s p - -> Decimal r s p - -> m (Decimal r s p) -divideDecimal (Decimal x) (Decimal y) - | y == 0 = throwM DivideByZero - | otherwise = fromRational (toInteger x % toInteger y) -{-# INLINABLE divideDecimal #-} - - ------------------------------------ --- Helper functions --------------- ------------------------------------ - --- | Add two bounded numbers while checking for `Overflow`/`Underflow` -plusBounded :: (MonadThrow m, Eq a, Ord a, Num a, Bounded a) => a -> a -> m a -plusBounded x y - | sameSig && sigX == 1 && x > maxBound - y = throwM Overflow - | sameSig && sigX == -1 && x < minBound - y = throwM Underflow - | otherwise = pure (x + y) - where - sigX = signum x - sigY = signum y - sameSig = sigX == sigY -{-# INLINABLE plusBounded #-} - --- | Subtract two bounded numbers while checking for `Overflow`/`Underflow` -minusBounded :: (MonadThrow m, Eq a, Ord a, Num a, Bounded a) => a -> a -> m a -minusBounded x y - | sigY == -1 && x > maxBound + y = throwM Overflow - | sigY == 1 && x < minBound + y = throwM Underflow - | otherwise = pure (x - y) - where sigY = signum y -{-# INLINABLE minusBounded #-} - --- | Divide two decimal numbers while checking for `Overflow` and `DivideByZero` -divBounded :: (MonadThrow m, Integral a, Bounded a) => a -> a -> m a -divBounded x y - | y == 0 = throwM DivideByZero - | signum y == -1 && y == -1 && x == minBound = throwM Overflow - ------------------- ^ Here we deal with special case overflow when (minBound * (-1)) - | otherwise = pure (x `div` y) -{-# INLINABLE divBounded #-} - - --- | Divide two decimal numbers while checking for `Overflow` and `DivideByZero` -quotBounded :: (MonadThrow m, Integral a, Bounded a) => a -> a -> m a -quotBounded x y - | y == 0 = throwM DivideByZero - | sigY == -1 && y == -1 && x == minBound = throwM Overflow - ------------------- ^ Here we deal with special case overflow when (minBound * (-1)) - | otherwise = pure (x `quot` y) - where - sigY = signum y -- Guard against wraparound in case of unsigned Word -{-# INLINABLE quotBounded #-} - --- | Divide two decimal numbers while checking for `Overflow` and `DivideByZero` -quotRemBounded :: (MonadThrow m, Integral a, Bounded a) => a -> a -> m (a, a) -quotRemBounded x y - | y == 0 = throwM DivideByZero - | sigY == -1 && y == -1 && x == minBound = throwM Overflow - | otherwise = pure (x `quotRem` y) - where - sigY = signum y -{-# INLINABLE quotRemBounded #-} - -quotRemDecimalBounded :: - forall m r s p. (MonadThrow m, Integral p, Bounded p) - => Decimal r s p - -> Integer - -> m (Decimal r s p, Decimal r s p) -quotRemDecimalBounded (Decimal raw) i - | i < toInteger (minBound :: p) = throwM Underflow - | i > toInteger (maxBound :: p) = throwM Overflow - | otherwise = do - (q, r) <- quotRemBounded raw $ fromInteger i - pure (Decimal q, Decimal r) -{-# INLINABLE quotRemDecimalBounded #-} - - --- | Multiply two decimal numbers while checking for `Overflow` -timesBounded :: (MonadThrow m, Integral a, Bounded a) => a -> a -> m a -timesBounded x y - | (sigY == -1 && y == -1 && x == minBound) = throwM Overflow - | (signum x == -1 && x == -1 && y == minBound) = throwM Overflow - | (sigY == 1 && (minBoundQuotY > x || x > maxBoundQuotY)) = eitherOverUnder - | (sigY == -1 && y /= -1 && (minBoundQuotY < x || x < maxBoundQuotY)) = eitherOverUnder - | otherwise = pure (x * y) - where - sigY = signum y - maxBoundQuotY = maxBound `quot` y - minBoundQuotY = minBound `quot` y - eitherOverUnder = throwM $ if sigY == signum x then Overflow else Underflow -{-# INLINABLE timesBounded #-} - - -fromIntegerBounded :: - forall m a. (MonadThrow m, Integral a, Bounded a) - => Integer - -> m a -fromIntegerBounded x - | x > toInteger (maxBound :: a) = throwM Overflow - | x < toInteger (minBound :: a) = throwM Underflow - | otherwise = pure $ fromInteger x -{-# INLINABLE fromIntegerBounded #-} - -fromIntegerScaleBounded :: - forall m a s. (MonadThrow m, Integral a, Bounded a, KnownNat s) - => Proxy s - -> Integer - -> m a -fromIntegerScaleBounded ps x - | xs > toInteger (maxBound :: a) = throwM Overflow - | xs < toInteger (minBound :: a) = throwM Underflow - | otherwise = pure $ fromInteger xs - where s = natVal ps - xs = x * (10 ^ s) -{-# INLINABLE fromIntegerScaleBounded #-} - - -fromIntegerDecimalBounded :: - forall m r s p. (MonadThrow m, Integral p, Bounded p) - => Decimal r s Integer - -> m (Decimal r s p) -fromIntegerDecimalBounded (Decimal x) = Decimal <$> fromIntegerBounded x -{-# INLINABLE fromIntegerDecimalBounded #-} - - --- | Add two decimal numbers. -plusDecimal :: - (MonadThrow m, Eq p, Ord p, Num p, Bounded p) - => Decimal r s p - -> Decimal r s p - -> m (Decimal r s p) -plusDecimal (Decimal x) (Decimal y) = Decimal <$> plusBounded x y -{-# INLINABLE plusDecimal #-} - --- | Subtract two decimal numbers. -minusDecimal :: - (MonadThrow m, Eq p, Ord p, Num p, Bounded p) - => Decimal r s p - -> Decimal r s p - -> m (Decimal r s p) -minusDecimal (Decimal x) (Decimal y) = Decimal <$> minusBounded x y -{-# INLINABLE minusDecimal #-} - --- | Multiply two bounded decimal numbers, adjusting their scale at the type level as well. -timesDecimalBounded :: - (MonadThrow m, Integral p, Bounded p) - => Decimal r s1 p - -> Decimal r s2 p - -> m (Decimal r (s1 + s2) p) -timesDecimalBounded (Decimal x) (Decimal y) = Decimal <$> timesBounded x y -{-# INLINABLE timesDecimalBounded #-} - --- | Multiply two bounded decimal numbers, adjusting their scale at the type level as well. -timesDecimal :: - Decimal r s1 Integer - -> Decimal r s2 Integer - -> Decimal r (s1 + s2) Integer -timesDecimal (Decimal x) (Decimal y) = Decimal (x * y) -{-# INLINABLE timesDecimal #-} - - --- | Multiply two decimal numbers, while rounding the result according to the rounding strategy. -timesDecimalRounded :: - (MonadThrow m, KnownNat s, Round r, Integral p, Bounded p) - => Decimal r s p - -> Decimal r s p - -> m (Decimal r s p) -timesDecimalRounded dx dy = - fromIntegerDecimalBounded $ roundDecimal $ timesDecimal (fmap toInteger dx) (fmap toInteger dy) -{-# INLINABLE timesDecimalRounded #-} - -fromRationalDecimalRounded :: - forall m r s p. (MonadThrow m, KnownNat s, Round r, Integral p) - => Rational - -> m (Decimal r s p) -fromRationalDecimalRounded rational - | denominator rational == 0 = throwM DivideByZero - | otherwise = pure $ roundDecimal (Decimal (truncate scaledRat) :: Decimal r (s + 1) p) - where - scaledRat = rational * (d % 1) - d = 10 ^ (natVal (Proxy :: Proxy s) + 1) -{-# INLINABLE fromRationalDecimalRounded #-} - - --- | Compute signum of a decimal, always one of 1, 0 or -1 -signumDecimal :: (Num p, KnownNat s) => Decimal r s p -> Decimal r s p -signumDecimal (Decimal d) = fromNum (signum d) -- It is safe to scale since signum does not widen - -- the range, thus will always fall into a valid - -- value -{-# INLINABLE signumDecimal #-} - - ------------------------------------ --- Showing ------------------------ ------------------------------------ - -instance (Integral p, KnownNat s) => Show (Decimal r s p) where - show d@(Decimal a) - | s == 0 = show $ toInteger a - | r == 0 = printf ("%d." ++ replicate s '0') q - | signum r < 0 && q == 0 = "-" ++ formatted - | otherwise = formatted - where - formatted = printf fmt q (abs r) - s = getScale d - fmt = "%d.%0" ++ show s ++ "u" - (q, r) = quotRem (toInteger a) (10 ^ s) - ------------------------------------ --- Parsing ------------------------ ------------------------------------ - -maxBoundCharsCount :: forall a . (Integral a, Bounded a) => Proxy a -> Int -maxBoundCharsCount _ = length (show (toInteger (maxBound :: a))) - -minBoundCharsCount :: forall a . (Integral a, Bounded a) => Proxy a -> Int -minBoundCharsCount _ = length (show (toInteger (minBound :: a))) - -fromIntegersScaleBounded :: - forall m a s. (MonadThrow m, Integral a, Bounded a, KnownNat s) - => Proxy s - -> Integer - -> Integer - -> m a -fromIntegersScaleBounded ps x y - | xs > toInteger (maxBound :: a) = throwM Overflow - | xs < toInteger (minBound :: a) = throwM Underflow - | otherwise = pure $ fromInteger xs - where s = natVal ps - xs = x * (10 ^ s) + y -{-# INLINABLE fromIntegersScaleBounded #-} - - -parseDecimalBounded :: - forall r s p. (KnownNat s, Bounded p, Integral p) - => Bool - -> String - -> Either String (Decimal r s p) -parseDecimalBounded checkForPlusSign rawInput - | not (null tooMuch) = Left "Input is too big for parsing as a bounded Decimal value" - | otherwise = do - (sign, signLeftOver) <- getSign input - -- by now we conditionally extracted the sign (+/-) - (num, leftOver) <- digits signLeftOver - let s = fromIntegral (natVal spx) :: Int - case uncons leftOver of - Nothing -> do - toStringError (fromIntegersScaleBounded spx (sign * num) 0) - Just ('.', digitsTxt) - | length digitsTxt > s -> Left $ "Too much text after the decimal: " ++ digitsTxt - Just ('.', digitsTxt) - | not (null digitsTxt) -> do - (decimalDigits, extraTxt) <- digits (digitsTxt ++ replicate (s - length digitsTxt) '0') - unless (null extraTxt) $ Left $ "Unrecognized digits: " ++ digitsTxt - toStringError (fromIntegersScaleBounded spx (sign * num) (sign * decimalDigits)) - _ -> Left $ "Unrecognized left over text: " ++ leftOver - where - spx = Proxy :: Proxy s - toStringError = - \case - Left exc - | Just Underflow <- fromException exc -> - Left $ "Number is too small to be represented as decimal: " ++ input - Left exc - | Just Overflow <- fromException exc -> - Left $ "Number is too big to be represented as decimal: " ++ input - Left err -> Left $ "Unexpected error: " ++ displayException err - Right val -> Right (Decimal val) - maxChars = - 2 + max (maxBoundCharsCount (Proxy :: Proxy p)) (minBoundCharsCount (Proxy :: Proxy p)) - {-- ^ account for possible dot in the decimal and an extra preceding 0 -} - (input, tooMuch) = splitAt maxChars rawInput - getSign str = - if (minBound :: p) >= 0 - then Right (1, str) - else case uncons str of - Nothing -> Left "Input String is empty" - Just ('-', strLeftOver) -> Right (-1, strLeftOver) - Just ('+', strLeftOver) - | checkForPlusSign -> Right (1, strLeftOver) - _ -> Right (1, str) - -digits :: Num a => String -> Either String (a, String) -digits str - | null h = Left "Input does not start with a digit" - | otherwise = Right (F.foldl' go 0 h, t) - where - (h, t) = span isDigit str - go n d = (n * 10 + fromIntegral (digitToInt d)) - +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-redundant-constraints #-} +module Numeric.Decimal.Internal + ( Decimal(..) + , Round(..) + , wrapDecimal + , unwrapDecimal + , splitDecimal + , decimalNumerator + , decimalDenominator + , getScale + , scaleUp + , scaleUpBounded + , castRounding + , parseDecimalBounded + -- * Decimal Arithmetic + -- ** Integer + , absDecimal + , signumDecimal + , plusDecimal + , minusDecimal + , timesDecimal + , timesDecimalWithoutLoss + , timesDecimalWithRounding + , divideDecimalWithoutLoss + , divideDecimalWithRounding + + , fromIntegerDecimal + , fromRationalDecimalWithoutLoss + , fromRationalDecimalWithRounding + , toRationalDecimal + -- ** Bounded Integral + , absDecimalBounded + , signumDecimalBounded + , plusDecimalBounded + , minusDecimalBounded + , timesDecimalBounded + , timesDecimalBoundedWithoutLoss + , timesDecimalBoundedWithRounding + + , divideDecimalBoundedWithoutLoss + , divideDecimalBoundedWithRounding + + , fromIntegralDecimalBounded + , integralDecimalToDecimalBounded + , quotRemDecimalBounded + , fromIntegerDecimalBounded + , fromIntegerDecimalBoundedIntegral + , fromRationalDecimalBoundedWithoutLoss + , fromRationalDecimalBoundedWithRounding + , bindM2Decimal + , bindM2 + -- ** Evaluation failure + , MonadThrow(..) + , ArithException(..) + , SomeException + , arithD + , arithMD + , arithMaybeD + , arithEitherD + , arithRoundD + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Exception +import Control.Monad +import Control.Monad.Catch +import Data.Char +import Data.Coerce +import Data.Foldable as F +import Data.Int +import Data.List +import Data.Proxy +import Data.Ratio +import Data.Word +import Numeric.Decimal.BoundedArithmetic +import GHC.Generics (Generic) +import GHC.TypeLits +import Text.Printf + +-- | Decimal number with custom precision (@p@) and type level scaling (@s@) parameter (i.e. number +-- of digits after the decimal point). As well as the rounding (@r@) strategy to use. +newtype Decimal r (s :: Nat) p = Decimal p + deriving (Ord, Eq, NFData, Functor, Generic) + +instance Applicative (Decimal r s) where + pure = Decimal + {-# INLINABLE pure #-} + (<*>) (Decimal f) (Decimal x) = Decimal (f x) + {-# INLINABLE (<*>) #-} + + +-- | A way to type restrict a polymorphic computation. +-- +-- >>> import Numeric.Decimal +-- >>> arithRoundD @1 @RoundDown @2 @Word (123.05 + 1.1) +-- Arith 124.1 +-- +-- @since 0.2.0 +arithRoundD :: + forall s' r s p k. (Round r p, KnownNat k, s ~ (s' + k)) + => Arith (Decimal r s p) + -> Arith (Decimal r s' p) +arithRoundD = fmap roundDecimal + +-- | A way to type restrict a polymorphic computation. +-- +-- `arithD` provide an easy way to use @TypeApplications@ to supply a type of Decimal: +-- +-- >>> import Numeric.Decimal +-- >>> :set -XDataKinds -XTypeApplications +-- >>> arithMD @RoundDown @3 @Word (1.1 + 123) +-- 124.100 +-- >>> arithMD @RoundDown @3 @Word (1.1 - 123) +-- *** Exception: arithmetic underflow +-- +-- @since 0.2.0 +arithMD :: forall r s p m . MonadThrow m => Arith (Decimal r s p) -> m (Decimal r s p) +arithMD = arithM + +-- | A way to type restrict a polymorphic computation. +-- +-- `arithD` provide an easy way to use @TypeApplications@ to supply a type of Decimal: +-- +-- >>> import Numeric.Decimal +-- >>> :set -XTypeApplications +-- >>> arithM $ arithD @RoundDown @3 @Word (1.1 + 123) +-- 124.100 +-- >>> arithM $ arithD @RoundDown @3 @Word (1.1 - 123) +-- *** Exception: arithmetic underflow +-- +-- @since 0.2.0 +arithD :: forall r s p . Arith (Decimal r s p) -> Arith (Decimal r s p) +arithD = id + +-- | A version of `arithD` that converts to `Maybe` +-- +-- >>> import Numeric.Decimal +-- >>> :set -XTypeApplications +-- >>> arithMaybeD @RoundDown @3 @Word (1.1 + 123) +-- Just 124.100 +-- >>> arithMaybeD @RoundDown @3 @Word (1.1 - 123) +-- Nothing +-- +-- @since 0.2.0 +arithMaybeD :: forall r s p . Arith (Decimal r s p) -> Maybe (Decimal r s p) +arithMaybeD = arithM + +-- | A version of `arithD` that converts to `Either` +-- +-- @since 0.2.0 +arithEitherD :: forall r s p . Arith (Decimal r s p) -> Either SomeException (Decimal r s p) +arithEitherD = arithM + + +-- | Rounding strategy to be used with decimal numbers. +-- +-- @since 0.1.0 +class Integral p => Round r p where + + -- | Reduce the scale of a number by @k@ decimal places using rounding strategy @r@ + -- + -- @since 0.1.0 + roundDecimal :: KnownNat k => Decimal r (n + k) p -> Decimal r n p + +-- | Change the rounding strategy of a `Decimal` +-- +-- >>> import Numeric.Decimal +-- >>> :set -XDataKinds -XTypeApplications +-- >>> d <- arithMD @RoundHalfUp @3 @Int 123.45 +-- >>> roundDecimal d :: Decimal RoundHalfUp 1 Int +-- 123.5 +-- >>> :t castRounding @RoundDown d +-- castRounding @RoundDown d :: Decimal RoundDown 3 Int +-- >>> roundDecimal (castRounding d) :: Decimal RoundDown 1 Int +-- 123.4 +-- +-- @since 0.2.0 +castRounding :: forall r' r s p . Decimal r s p -> Decimal r' s p +castRounding = coerce + +-- | Exception thrown whenever operation cannot be performed withou loosing information +-- +-- @since 0.2.0 +data PrecisionLoss = PrecisionLoss !Rational !Integer + deriving Eq + +instance Show PrecisionLoss where + show (PrecisionLoss r s) = "PrecisionLoss (" ++ show r ++ ") to " ++ show s ++ " decimal spaces" + +instance Exception PrecisionLoss + +-- | Get the scale of a `Decimal`. Argument is not evaluated. +-- +-- >>> import Numeric.Decimal +-- >>> d <- arithM (36 :: Arith (Decimal RoundHalfUp 5 Int)) +-- >>> d +-- 36.00000 +-- >>> getScale d +-- 5 +-- +-- @since 0.1.0 +getScale :: forall r s p . KnownNat s => Decimal r s p -> Integer +getScale _ = natVal (Proxy :: Proxy s) + + +-- | Increase the precision of a `Decimal`, use `roundDecimal` if inverse is desired. +-- +-- >>> import Numeric.Decimal +-- >>> d2 <- arithM (1.65 :: Arith (Decimal RoundHalfUp 2 Integer)) +-- >>> d2 +-- 1.65 +-- >>> scaleUp d2 :: Decimal RoundHalfUp 50 Integer +-- 1.65000000000000000000000000000000000000000000000000 +-- +-- @since 0.2.0 +scaleUp :: + forall k r n. KnownNat k + => Decimal r n Integer + -> Decimal r (n + k) Integer +scaleUp (Decimal d) = Decimal (d * (10 ^ natVal (Proxy :: Proxy k))) + +-- | Increase the precision of a `Decimal` backed by a bounded type, use `roundDecimal` if +-- inverse is desired. +-- +-- >>> import Numeric.Decimal +-- >>> d2 <- arithM (1.65 :: Arith (Decimal RoundHalfUp 2 Int16)) +-- >>> scaleUpBounded d2 :: IO (Decimal RoundHalfUp 3 Int16) +-- 1.650 +-- >>> scaleUpBounded d2 :: IO (Decimal RoundHalfUp 4 Int16) +-- 1.6500 +-- >>> scaleUpBounded d2 :: IO (Decimal RoundHalfUp 5 Int16) +-- *** Exception: arithmetic overflow +-- +-- @since 0.1.1 +scaleUpBounded :: + forall k r n p m. (MonadThrow m, Integral p, Bounded p, KnownNat k) + => Decimal r n p + -> m (Decimal r (n + k) p) +scaleUpBounded (Decimal d) = do + i <- fromIntegerBounded (10 ^ natVal (Proxy :: Proxy k)) + Decimal <$> timesBounded d i + +-- | Split the number at the decimal point, i.e. whole number and the fraction +-- +-- >>> import Numeric.Decimal +-- >>> splitDecimal <$> (12.34 :: Arith (Decimal RoundHalfUp 2 Int)) +-- Arith (12,34) +-- +-- @since 0.1.0 +splitDecimal :: (Integral p, KnownNat s) => Decimal r s p -> (p, p) +splitDecimal d@(Decimal v) = v `quotRem` (10 ^ getScale d) + +-- | Get the numerator. Same as @`toInteger` . `unwrapDecimal`@ +-- +-- >>> import Numeric.Decimal +-- >>> :set -XDataKinds -XTypeApplications +-- >>> decimalNumerator <$> arithD @RoundHalfEven @3 @Int 123.45 +-- Arith 123450 +-- +-- @since 0.2.0 +decimalNumerator :: Integral p => Decimal r s p -> Integer +decimalNumerator (Decimal i) = toInteger i + +-- | Get the decimal denominator. Always will be a multiple of @10@. Does not evaluate the +-- argument. +-- +-- >>> import Numeric.Decimal +-- >>> :set -XDataKinds -XTypeApplications +-- >>> decimalDenominator <$> arithD @RoundHalfEven @3 @Int 123.45 +-- Arith 1000 +-- +-- @since 0.2.0 +decimalDenominator :: KnownNat s => Decimal r s p -> Integer +decimalDenominator d = 10 ^ getScale d + + +-- | Wrap an `Integral` as a `Decimal`. No scaling will be done. +-- +-- >>> import Numeric.Decimal +-- >>> wrapDecimal 1234 :: Decimal RoundHalfUp 4 Int +-- 0.1234 +-- >>> wrapDecimal 1234 :: Decimal RoundHalfUp 2 Int +-- 12.34 +-- +-- @since 0.1.0 +wrapDecimal :: Integral p => p -> Decimal r s p +wrapDecimal = Decimal + +-- | Get out the underlying representation for the decimal number. No scaling will be done. +-- +-- >>> import Numeric.Decimal +-- >>> unwrapDecimal (wrapDecimal 1234 :: Decimal RoundHalfUp 4 Int) +-- 1234 +-- +-- @since 0.1.0 +unwrapDecimal :: Decimal r s p -> p +unwrapDecimal (Decimal p) = p + +-- | Convert an `Integer` while performing the necessary scaling +-- +-- >>> import Numeric.Decimal +-- >>> fromIntegerDecimal 1234 :: Decimal RoundHalfUp 4 Integer +-- 1234.0000 +-- +-- @since 0.2.0 +fromIntegerDecimal :: forall r s . KnownNat s => Integer -> Decimal r s Integer +fromIntegerDecimal x = Decimal (x * (10 ^ s)) + where + s = natVal (Proxy :: Proxy s) +{-# INLINABLE fromIntegerDecimal #-} + +-- | Convert a bounded integeral into a decimal, while performing the necessary scaling +-- +-- >>> import Numeric.Decimal +-- >>> fromIntegralDecimalBounded 1234 :: IO (Decimal RoundHalfUp 4 Int) +-- 1234.0000 +-- >>> fromIntegralDecimalBounded 1234 :: IO (Decimal RoundHalfUp 4 Int16) +-- *** Exception: arithmetic overflow +-- +-- @since 0.2.0 +fromIntegralDecimalBounded :: + (Integral p, Bounded p, KnownNat s, MonadThrow m) => p -> m (Decimal r s p) +fromIntegralDecimalBounded = fromIntegerDecimalBounded . fromIntegerDecimal . toInteger +{-# INLINABLE fromIntegralDecimalBounded #-} + +-- | Convert a decimal backed by an integral to another decimal backed by a bounded +-- integeral, while checking for `Overflow`/`Underflow` +-- +-- >>> import Numeric.Decimal +-- >>> fromIntegralDecimalBounded 1234 :: IO (Decimal RoundHalfUp 4 Int) +-- 1234.0000 +-- >>> fromIntegralDecimalBounded 1234 :: IO (Decimal RoundHalfUp 4 Int16) +-- *** Exception: arithmetic overflow +-- +-- @since 0.2.0 +integralDecimalToDecimalBounded :: + (Integral p', Integral p, Bounded p, KnownNat s, MonadThrow m) + => Decimal r s p' + -> m (Decimal r s p) +integralDecimalToDecimalBounded = fromIntegerDecimalBounded . fmap toInteger +{-# INLINABLE integralDecimalToDecimalBounded #-} + + +bindM2Decimal :: + Monad m + => (p1 -> p2 -> m p) + -> m (Decimal r1 s1 p1) + -> m (Decimal r2 s2 p2) + -> m (Decimal r s p) +bindM2Decimal f dx dy = do + Decimal x <- dx + Decimal y <- dy + Decimal <$> f x y +{-# INLINABLE bindM2Decimal #-} + + +bindM2 :: Monad m => (a -> b -> m c) -> m a -> m b -> m c +bindM2 f mx my = do + x <- mx + y <- my + f x y +{-# INLINABLE bindM2 #-} + + +instance Bounded p => Bounded (Decimal r s p) where + minBound = Decimal minBound + maxBound = Decimal maxBound + +----------------------------------- +-- Integer instances -------------- +----------------------------------- + + +instance (Round r Integer, KnownNat s) => Num (Decimal r s Integer) where + (+) = plusDecimal + {-# INLINABLE (+) #-} + (-) = minusDecimal + {-# INLINABLE (-) #-} + (*) = timesDecimalWithRounding + {-# INLINABLE (*) #-} + signum = signumDecimal + {-# INLINABLE signum #-} + abs = absDecimal + {-# INLINABLE abs #-} + fromInteger = fromIntegerDecimal + {-# INLINABLE fromInteger #-} + + +instance (KnownNat s) => Num (Arith (Decimal r s Integer)) where + (+) = liftA2 plusDecimal + {-# INLINABLE (+) #-} + (-) = liftA2 minusDecimal + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalWithoutLoss + {-# INLINABLE (*) #-} + signum = fmap signumDecimal + {-# INLINABLE signum #-} + abs = fmap absDecimal + {-# INLINABLE abs #-} + fromInteger = pure . fromIntegerDecimal + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Integer)) where + (/) = bindM2 divideDecimalWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalWithoutLoss + {-# INLINABLE fromRational #-} + + + +----------------------------------- +-- Bounded Integral instances ----- +----------------------------------- + + +instance (KnownNat s) => Num (Arith (Decimal r s Int)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = (>>= absDecimalBounded) + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Int8)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = (>>= absDecimalBounded) + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Int16)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = (>>= absDecimalBounded) + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Int32)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = (>>= absDecimalBounded) + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Int64)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = (>>= absDecimalBounded) + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Word)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = id + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Word8)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = id + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Word16)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = id + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Word32)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = id + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Num (Arith (Decimal r s Word64)) where + (+) = bindM2 plusDecimalBounded + {-# INLINABLE (+) #-} + (-) = bindM2 minusDecimalBounded + {-# INLINABLE (-) #-} + (*) = bindM2 timesDecimalBoundedWithoutLoss + {-# INLINABLE (*) #-} + signum = (>>= signumDecimalBounded) + {-# INLINABLE signum #-} + abs = id + {-# INLINABLE abs #-} + fromInteger = fmap Decimal . fromIntegerScaleBounded (Proxy :: Proxy s) + {-# INLINABLE fromInteger #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Int)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Int8)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Int16)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Int32)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational =fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + + +instance (KnownNat s) => Fractional (Arith (Decimal r s Int64)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Word)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Word8)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Word16)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Word32)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + +instance (KnownNat s) => Fractional (Arith (Decimal r s Word64)) where + (/) = bindM2 divideDecimalBoundedWithoutLoss + {-# INLINABLE (/) #-} + fromRational = fromRationalDecimalBoundedWithoutLoss + {-# INLINABLE fromRational #-} + + +-- | Add two decimal numbers backed by `Integer`. +-- +-- @since 0.1.0 +plusDecimal :: Decimal r s Integer -> Decimal r s Integer -> Decimal r s Integer +plusDecimal = liftA2 (+) +{-# INLINABLE plusDecimal #-} + +-- | Subtract two decimal numbers backed by `Integer`. +-- +-- @since 0.1.0 +minusDecimal :: + Decimal r s Integer -> Decimal r s Integer -> Decimal r s Integer +minusDecimal = liftA2 (-) +{-# INLINABLE minusDecimal #-} + + +-- divideDecimalWithoutLoss :: +-- (MonadThrow m, KnownNat s) +-- => Decimal r s Integer +-- -> Decimal r s Integer +-- -> m (Decimal r s Integer) +-- divideDecimalWithoutLoss (Decimal x) (Decimal y) +-- | y == 0 = throwM DivideByZero +-- | otherwise = fromRationalDecimalWithoutLoss (toInteger x % toInteger y) +-- {-# INLINABLE divideDecimalWithoutLoss #-} + +-- divideDecimalBoundedWithoutLoss :: +-- (MonadThrow m, KnownNat s, Bounded p, Integral p) +-- => Decimal r s p +-- -> Decimal r s p +-- -> m (Decimal r s p) +-- divideDecimalBoundedWithoutLoss (Decimal x) (Decimal y) +-- | y == 0 = throwM DivideByZero +-- | otherwise = fromRationalDecimalBoundedWithoutLoss (toInteger x % toInteger y) +-- {-# INLINABLE divideDecimalBoundedWithoutLoss #-} + +divideDecimalWithRounding :: + (MonadThrow m, KnownNat s, Round r Integer) + => Decimal r s Integer + -> Decimal r s Integer + -> m (Decimal r s Integer) +divideDecimalWithRounding (Decimal x) (Decimal y) + | y == 0 = throwM DivideByZero + | otherwise = fromRationalDecimalWithRounding (toInteger x % toInteger y) +{-# INLINABLE divideDecimalWithRounding #-} + +divideDecimalBoundedWithRounding :: + (MonadThrow m, KnownNat s, Round r Integer, Bounded p, Integral p) + => Decimal r s p + -> Decimal r s p + -> m (Decimal r s p) +divideDecimalBoundedWithRounding (Decimal x) (Decimal y) + | y == 0 = throwM DivideByZero + | otherwise = fromRationalDecimalBoundedWithRounding (toInteger x % toInteger y) +{-# INLINABLE divideDecimalBoundedWithRounding #-} + + +quotRemDecimalBounded :: + forall m r s p. (MonadThrow m, Integral p, Bounded p) + => Decimal r s p + -> Integer + -> m (Decimal r s p, Decimal r s p) +quotRemDecimalBounded (Decimal raw) i + | i < toInteger (minBound :: p) = throwM Underflow + | i > toInteger (maxBound :: p) = throwM Overflow + | otherwise = do + i' <- fromIntegerBounded i + (q, r) <- quotRemBounded raw i' + pure (Decimal q, Decimal r) +{-# INLINABLE quotRemDecimalBounded #-} + +fromIntegerScaleBounded :: + forall m a s. (MonadThrow m, Integral a, Bounded a, KnownNat s) + => Proxy s + -> Integer + -> m a +fromIntegerScaleBounded px x = fromIntegerBounded xs + where + xs = x * (10 ^ natVal px) +{-# INLINABLE fromIntegerScaleBounded #-} + + +fromIntegersScaleBounded :: + forall m a s. (MonadThrow m, Integral a, Bounded a, KnownNat s) + => Proxy s + -> Integer + -> Integer + -> m a +fromIntegersScaleBounded ps x y = fromIntegerBounded xs + where + xs = x * (10 ^ natVal ps) + y +{-# INLINABLE fromIntegersScaleBounded #-} + + +fromIntegerDecimalBoundedIntegral :: + forall m r s p. (MonadThrow m, Integral p, Bounded p, KnownNat s) + => Integer + -> m (Decimal r s p) +fromIntegerDecimalBoundedIntegral x = Decimal <$> fromIntegerScaleBounded (Proxy :: Proxy s) x +{-# INLINABLE fromIntegerDecimalBoundedIntegral #-} + + +fromIntegerDecimalBounded :: + forall m r s p. (MonadThrow m, Integral p, Bounded p) + => Decimal r s Integer + -> m (Decimal r s p) +fromIntegerDecimalBounded (Decimal x) = Decimal <$> fromIntegerBounded x +{-# INLINABLE fromIntegerDecimalBounded #-} + + + +-- | Add two decimal numbers. +-- +-- @since 0.1.0 +plusDecimalBounded :: + (MonadThrow m, Eq p, Ord p, Num p, Bounded p) + => Decimal r s p + -> Decimal r s p + -> m (Decimal r s p) +plusDecimalBounded (Decimal x) (Decimal y) = Decimal <$> plusBounded x y +{-# INLINABLE plusDecimalBounded #-} + +-- | Subtract two decimal numbers. +-- +-- @since 0.1.0 +minusDecimalBounded :: + (MonadThrow m, Eq p, Ord p, Num p, Bounded p) + => Decimal r s p + -> Decimal r s p + -> m (Decimal r s p) +minusDecimalBounded (Decimal x) (Decimal y) = Decimal <$> minusBounded x y +{-# INLINABLE minusDecimalBounded #-} + +-- | Multiply two bounded decimal numbers, adjusting their scale at the type level as well. +-- +-- @since 0.1.0 +timesDecimalBounded :: + (MonadThrow m, Integral p, Bounded p) + => Decimal r s1 p + -> Decimal r s2 p + -> m (Decimal r (s1 + s2) p) +timesDecimalBounded (Decimal x) (Decimal y) = Decimal <$> timesBounded x y +{-# INLINABLE timesDecimalBounded #-} + +-- | Multiply two bounded decimal numbers, adjusting their scale at the type level as well. +-- +-- @since 0.1.0 +timesDecimal :: + Decimal r s1 Integer + -> Decimal r s2 Integer + -> Decimal r (s1 + s2) Integer +timesDecimal (Decimal x) (Decimal y) = Decimal (x * y) +{-# INLINABLE timesDecimal #-} + + +-- | Multiply two decimal numbers backed by `Integer`, while rounding the result according +-- to the rounding strategy. +-- +-- @since 0.2.0 +timesDecimalWithRounding :: + (KnownNat s, Round r Integer) + => Decimal r s Integer + -> Decimal r s Integer + -> Decimal r s Integer +timesDecimalWithRounding dx dy = roundDecimal $ timesDecimal dx dy +{-# INLINABLE timesDecimalWithRounding #-} + + +-- | Multiply two decimal numbers, while rounding the result according to the rounding strategy. +-- +-- @since 0.2.0 +timesDecimalBoundedWithRounding :: + (MonadThrow m, KnownNat s, Round r Integer, Integral p, Bounded p) + => Decimal r s p + -> Decimal r s p + -> m (Decimal r s p) +timesDecimalBoundedWithRounding dx dy = + fromIntegerDecimalBounded $ timesDecimalWithRounding (fmap toInteger dx) (fmap toInteger dy) +{-# INLINABLE timesDecimalBoundedWithRounding #-} + + + +-- | Multiply two decimal numbers that have the same scale, while throwing `PrecisionLoss` +-- whenever multiplication cannot be done without rounding. Also checks for bounds and can +-- throw `Overflow`/`Underflow`. +-- +-- @since 0.2.0 +timesDecimalBoundedWithoutLoss :: + forall r s p m. (Integral p, Bounded p, KnownNat s, MonadThrow m) + => Decimal r s p + -> Decimal r s p + -> m (Decimal r s p) +timesDecimalBoundedWithoutLoss d1 (Decimal i2) + | q /= toRational i = + throwM $ PrecisionLoss (q * (1 % decimalDenominator d1)) $ getScale d1 + | otherwise = fromIntegerDecimalBounded $ Decimal i + where + q = toRationalDecimal d1 * (toInteger i2 % 1) + i = truncate q + + +-- | Multiply two decimal numbers that have the same scale, while throwing `PrecisionLoss` +-- whenever multiplication cannot be done without rounding. +-- +-- @since 0.2.0 +timesDecimalWithoutLoss :: + forall r s m. (KnownNat s, MonadThrow m) + => Decimal r s Integer + -> Decimal r s Integer + -> m (Decimal r s Integer) +timesDecimalWithoutLoss d1 (Decimal i2) + | q /= toRational i = + throwM $ PrecisionLoss (q * (1 % decimalDenominator d1)) $ getScale d1 + | otherwise = pure $ Decimal i + where + q = toRationalDecimal d1 * (toInteger i2 % 1) + i = truncate q + + + +-- | Divide two decimal numbers that have the same scale, while throwing `PrecisionLoss` +-- whenever division cannot be done without rounding. +-- +-- @since 0.2.0 +divideDecimalWithoutLoss :: + forall r s m. (KnownNat s, MonadThrow m) + => Decimal r s Integer + -> Decimal r s Integer + -> m (Decimal r s Integer) +divideDecimalWithoutLoss d1 (Decimal i2) + | i2 == 0 = throwM DivideByZero + | q /= toRational i = throwM $ PrecisionLoss (q * (1 % decimalDenominator d1)) $ getScale d1 + | otherwise = pure $ Decimal i + where + q = (decimalNumerator d1 * decimalDenominator d1) % toInteger i2 + i = truncate q + + +-- | Divide two decimal numbers that have the same scale, while throwing `PrecisionLoss` +-- whenever division cannot be done without rounding. +-- +-- @since 0.2.0 +divideDecimalBoundedWithoutLoss :: + forall r s p m. (Integral p, Bounded p, KnownNat s, MonadThrow m) + => Decimal r s p + -> Decimal r s p + -> m (Decimal r s p) +divideDecimalBoundedWithoutLoss d1 (Decimal i2) + | i2 == 0 = throwM DivideByZero + | q /= toRational i = throwM $ PrecisionLoss (q * (1 % decimalDenominator d1)) $ getScale d1 + | otherwise = fromIntegerDecimalBounded $ Decimal i + where + q = (decimalNumerator d1 * decimalDenominator d1) % toInteger i2 + i = truncate q + + +toRationalDecimalInteger :: forall r s . KnownNat s => Decimal r s Integer -> Rational +toRationalDecimalInteger (Decimal p) = p % (10 ^ natVal (Proxy :: Proxy s)) +{-# INLINABLE toRationalDecimalInteger #-} + +-- | Convert a decimal to a Rational +-- +-- @since 0.2.0 +toRationalDecimal :: + (KnownNat s, Integral p) => Decimal r s p -> Rational +toRationalDecimal d = toRationalDecimalInteger (toInteger <$> d) +{-# INLINABLE toRationalDecimal #-} + +-- | Convert from `Rational` to a `Decimal` backed by `Integer`. `PrecisionLoss` will be +-- thrown if conversion cannot be achieved without any loss of data. In case that rounding +-- is acceptable use `fromRationalDecimalBoundedWithRounding` +-- +-- @since 0.2.0 +fromRationalDecimalWithoutLoss :: + forall m r s. (MonadThrow m, KnownNat s) + => Rational + -> m (Decimal r s Integer) +fromRationalDecimalWithoutLoss rational + | denominator rational == 0 = throwM DivideByZero + | fromIntegral t /= scaledRat = throwM (PrecisionLoss rational s) + | otherwise = pure truncated + where + truncated@(Decimal t) = Decimal (truncate scaledRat) :: Decimal r s Integer + scaledRat = rational * (d % 1) + s = natVal (Proxy :: Proxy s) + d = 10 ^ s +{-# INLINABLE fromRationalDecimalWithoutLoss #-} + +-- | Convert a `Rational` to a bounded `Decimal`, but only if there is no precision loss +-- or `Overflow`/`Undeflow`. +-- +-- @since 0.2.0 +fromRationalDecimalBoundedWithoutLoss :: + (MonadThrow m, KnownNat s, Integral p, Bounded p) + => Rational + -> m (Decimal r s p) +fromRationalDecimalBoundedWithoutLoss r = + fromRationalDecimalWithoutLoss r >>= fromIntegerDecimalBounded +{-# INLINABLE fromRationalDecimalBoundedWithoutLoss #-} + +fromRationalDecimalWithRounding :: + forall m r s . (MonadThrow m, KnownNat s, Round r Integer) + => Rational + -> m (Decimal r s Integer) +fromRationalDecimalWithRounding rational + | denominator rational == 0 = throwM DivideByZero + | otherwise = + pure $ roundDecimal (Decimal (truncate scaledRat) :: Decimal r (s + 1) Integer) + where + scaledRat = rational * (d % 1) + d = 10 ^ (natVal (Proxy :: Proxy s) + 1) +{-# INLINABLE fromRationalDecimalWithRounding #-} + + +fromRationalDecimalBoundedWithRounding :: + forall m r s p. (MonadThrow m, KnownNat s, Round r Integer, Bounded p, Integral p) + => Rational + -> m (Decimal r s p) +fromRationalDecimalBoundedWithRounding = + fromRationalDecimalWithRounding >=> fromIntegerDecimalBounded +{-# INLINABLE fromRationalDecimalBoundedWithRounding #-} + + +-- | Compute absolute value of a decimal +-- +-- @since 0.2.0 +absDecimal :: KnownNat s => Decimal r s Integer -> Decimal r s Integer +absDecimal (Decimal d) = Decimal (abs d) +{-# INLINABLE absDecimal #-} + +-- | Compute signum of a decimal, always one of 1, 0 or -1 +-- +-- @since 0.2.0 +signumDecimal :: KnownNat s => Decimal r s Integer -> Decimal r s Integer +signumDecimal (Decimal d) = fromIntegerDecimal (signum d) +{-# INLINABLE signumDecimal #-} + +-- | Compute signum of a decimal, always one of 1, 0 or -1 +signumDecimalBounded :: + (KnownNat s, MonadThrow m, Integral p, Bounded p) + => Decimal r s p + -> m (Decimal r s p) +signumDecimalBounded d = fromIntegerDecimalBounded $ signumDecimal (toInteger <$> d) +{-# INLINABLE signumDecimalBounded #-} + +-- | Compute absolute value of a bounded decimal. Protects against overflows for negative +-- `minBound`. +-- +-- >>> abs (minBound :: Int8) +-- -128 +-- >>> import Numeric.Decimal +-- >>> d <- arithM (fromRational (-1.28) :: Arith (Decimal RoundHalfUp 2 Int8)) +-- >>> d +-- -1.28 +-- >>> absDecimalBounded d :: Either SomeException (Decimal RoundHalfUp 2 Int8) +-- Left arithmetic overflow +-- +-- /Note/ - Watch out for order of negation +-- +-- >>> -1.28 :: Arith (Decimal RoundHalfUp 2 Int8) +-- ArithError arithmetic overflow +-- >>> negate (1.28 :: Arith (Decimal RoundHalfUp 2 Int8)) +-- ArithError arithmetic overflow +-- >>> :set -XNegativeLiterals +-- >>> -1.28 :: Arith (Decimal RoundHalfUp 2 Int8) +-- Arith -1.28 +-- +-- @since 0.2.0 +absDecimalBounded :: + (KnownNat s, MonadThrow m, Integral p, Bounded p) + => Decimal r s p + -> m (Decimal r s p) +absDecimalBounded = fmap Decimal . absBounded . coerce +{-# INLINABLE absDecimalBounded #-} + + +----------------------------------- +-- Showing ------------------------ +----------------------------------- + +instance (Integral p, KnownNat s) => Show (Decimal r s p) where + show d@(Decimal a) + | s == 0 = show $ toInteger a + | r == 0 = printf ("%d." ++ replicate s '0') q + | signum r < 0 && q == 0 = "-" ++ formatted + | otherwise = formatted + where + formatted = printf fmt q (abs r) + s = fromInteger $ getScale d + fmt = "%d.%0" ++ show s ++ "u" + (q, r) = quotRem (toInteger a) (10 ^ s) + +----------------------------------- +-- Parsing ------------------------ +----------------------------------- + +maxBoundCharsCount :: forall a . (Integral a, Bounded a) => Proxy a -> Int +maxBoundCharsCount _ = length (show (toInteger (maxBound :: a))) + +minBoundCharsCount :: forall a . (Integral a, Bounded a) => Proxy a -> Int +minBoundCharsCount _ = length (show (toInteger (minBound :: a))) + + +parseDecimalBounded :: + forall r s p. (KnownNat s, Bounded p, Integral p) + => Bool + -> String + -> Either String (Decimal r s p) +parseDecimalBounded checkForPlusSign rawInput + | not (null tooMuch) = Left "Input is too big for parsing as a bounded Decimal value" + | otherwise = do + (sign, signLeftOver) <- getSign input + -- by now we conditionally extracted the sign (+/-) + (num, leftOver) <- digits signLeftOver + let s = fromIntegral (natVal spx) :: Int + case uncons leftOver of + Nothing -> toStringError (fromIntegerScaleBounded spx (sign * num)) + Just ('.', digitsTxt) + | length digitsTxt > s -> Left $ "Too much text after the decimal: " ++ digitsTxt + Just ('.', digitsTxt) + | not (null digitsTxt) -> do + (decimalDigits, extraTxt) <- digits (digitsTxt ++ replicate (s - length digitsTxt) '0') + unless (null extraTxt) $ Left $ "Unrecognized digits: " ++ digitsTxt + toStringError (fromIntegersScaleBounded spx (sign * num) (sign * decimalDigits)) + _ -> Left $ "Unrecognized left over text: " ++ leftOver + where + spx = Proxy :: Proxy s + toStringError = + \case + Left exc + | Just Underflow <- fromException exc -> + Left $ "Number is too small to be represented as decimal: " ++ input + Left exc + | Just Overflow <- fromException exc -> + Left $ "Number is too big to be represented as decimal: " ++ input + Left err -> Left $ "Unexpected error: " ++ displayException err + Right val -> Right (Decimal val) + maxChars = + 2 + max (maxBoundCharsCount (Proxy :: Proxy p)) (minBoundCharsCount (Proxy :: Proxy p)) + {-- ^ account for possible dot in the decimal and an extra preceding 0 -} + (input, tooMuch) = splitAt maxChars rawInput + getSign str = + if (minBound :: p) >= 0 + then Right (1, str) + else case uncons str of + Nothing -> Left "Input String is empty" + Just ('-', strLeftOver) -> Right (-1, strLeftOver) + Just ('+', strLeftOver) + | checkForPlusSign -> Right (1, strLeftOver) + _ -> Right (1, str) + +digits :: Num a => String -> Either String (a, String) +digits str + | null h = Left "Input does not start with a digit" + | otherwise = Right (F.foldl' go 0 h, t) + where + (h, t) = span isDigit str + go n d = n * 10 + fromIntegral (digitToInt d) diff --git a/tests/Numeric/DecimalSpec.hs b/tests/Numeric/DecimalSpec.hs --- a/tests/Numeric/DecimalSpec.hs +++ b/tests/Numeric/DecimalSpec.hs @@ -1,23 +1,30 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Numeric.DecimalSpec (spec) where -import Control.DeepSeq -import Control.Exception hiding (assert) -import Control.Monad -import Data.Either -import Data.Int -import Data.Proxy -import Data.Scientific -import Data.Typeable -import Data.Word -import GHC.TypeLits -import Numeric.Decimal -import Test.Hspec -import Test.QuickCheck -import Test.QuickCheck.Monadic +import Control.DeepSeq +import Control.Exception hiding (assert) +import Control.Monad +import Data.Either +import Data.Int +import Data.Proxy +import Data.Ratio +import Data.Scientific +import Data.Typeable +import Data.Word +import GHC.TypeLits +import Numeric.Decimal +import Numeric.Natural +import Test.Hspec +import Test.Hspec.QuickCheck +import Test.QuickCheck +import Test.QuickCheck.Monadic -- | Values generated will usually be somewhere close to the bounds. newtype Extremum a = Extremum a deriving Show @@ -25,18 +32,34 @@ instance (Arbitrary a, Bounded a, Integral a) => Arbitrary (Extremum a) where arbitrary = do NonNegative x <- arbitrary - frequency $ - [(f, pure (Extremum v)) | (f, v) <- [(40, minBound + x), (40, maxBound - x), (20, x)]] + frequency + [ (f, pure (Extremum v)) + | (f, v) <- [(40, minBound + x), (40, maxBound - x), (20, x)] + ] instance (Arbitrary p) => Arbitrary (Decimal r s p) where arbitrary = fmap pure arbitrary showType :: forall t . Typeable t => Proxy t -> String -showType _ = (showsTypeRep (typeRep (Proxy :: Proxy t))) "" +showType _ = showsTypeRep (typeRep (Proxy :: Proxy t)) "" +prop_absBounded :: + (Show a, Integral a) + => [ArithException] -- ^ Exceptions to expect + -> Extremum a + -> Property +prop_absBounded excs (Extremum x) = + classify (not noOverflow) "Outside of Bounds" $ + if noOverflow + then Right res === resBounded + else disjoin (fmap ((resBounded ===) . Left) excs) + where + res = abs x + noOverflow = abs (toInteger x) == toInteger res + resBounded = toArithException $ absBounded x prop_plusBounded :: - (Arbitrary a, Show a, Integral a, Bounded a) + (Show a, Integral a, Bounded a) => [ArithException] -- ^ Exceptions to expect -> Extremum a -> Extremum a @@ -53,7 +76,7 @@ prop_minusBounded :: - (Arbitrary a, Show a, Integral a, Bounded a) + (Show a, Integral a, Bounded a) => [ArithException] -- ^ Exceptions to expect -> Extremum a -> Extremum a @@ -69,7 +92,7 @@ resBounded = toArithException $ minusBounded x y prop_timesBounded :: - (Arbitrary a, Show a, Integral a, Bounded a) + (Show a, Integral a, Bounded a) => [ArithException] -- ^ Exceptions to expect -> Extremum a -> Extremum a @@ -85,7 +108,7 @@ resBounded = toArithException $ timesBounded x y prop_fromIntegerBounded :: - forall a . (Arbitrary a, Show a, Integral a, Bounded a) + forall a . (Show a, Integral a, Bounded a) => [ArithException] -- ^ Exceptions to expect -> Int -- ^ This is used for scaling -> Extremum a @@ -112,7 +135,7 @@ Right res -> Right res prop_divBounded :: - (Arbitrary a, Show a, Integral a, Bounded a, NFData a) + (Show a, Integral a, Bounded a, NFData a) => Extremum a -> Extremum a -> Property @@ -125,7 +148,7 @@ resBounded = toArithException $ divBounded x y prop_quotBounded :: - (Arbitrary a, Show a, Integral a, Bounded a, NFData a) + (Show a, Integral a, Bounded a, NFData a) => Extremum a -> Extremum a -> Property @@ -139,45 +162,141 @@ specBouned :: - forall a. (Typeable a, Arbitrary a, Show a, Integral a, Bounded a, NFData a) + forall a. + ( Typeable a + , Arbitrary a + , Show a + , Integral a + , Bounded a + , NFData a + , Round RoundHalfUp a + , Round RoundHalfDown a + , Round RoundHalfEven a + , Round RoundDown a + , Round RoundToZero a + ) => Proxy a -> Spec specBouned px = do let typeName = showsTypeRep (typeRep px) "" describe ("Bounded: " ++ typeName) $ do let excs = [Overflow, Underflow] - plusExcs = if (minBound :: a) >= 0 then [Overflow] else excs - it "plusBounded" $ property (prop_plusBounded plusExcs :: Extremum a -> Extremum a -> Property) + plusExcs = + if (minBound :: a) >= 0 + then [Overflow] + else excs + it "plusBounded" $ + property + (prop_plusBounded plusExcs :: Extremum a -> Extremum a -> Property) it "minusBounded" $ property (prop_minusBounded excs :: Extremum a -> Extremum a -> Property) it "timesBounded" $ property (prop_timesBounded excs :: Extremum a -> Extremum a -> Property) + it "absBounded" $ + property (prop_absBounded [Overflow] :: Extremum a -> Property) it "fromIntegerBounded" $ property (prop_fromIntegerBounded excs :: Int -> Extremum a -> Property) it "divBounded" $ property (prop_divBounded :: Extremum a -> Extremum a -> Property) it "quotBounded" $ property (prop_quotBounded :: Extremum a -> Extremum a -> Property) - specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 0) px - specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 1) px - specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 2) px + specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 0) px + specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 1) px + specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 2) px + specRounding @0 @0 @a + specRounding @1 @0 @a + specRounding @1 @1 @a + specRounding @2 @0 @a let maxLen = length (show (maxBound :: a)) when (maxLen >= 3) $ do - specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 3) px + specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 3) px + specRounding @2 @1 @a + specRounding @3 @0 @a when (maxLen >= 4) $ do - specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 4) px + specRounding @2 @2 @a + specRounding @3 @1 @a + specRounding @4 @0 @a + specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 4) px when (maxLen >= 5) $ do - specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 5) px - when (maxLen >= 19) $ do - specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 19) px + specRounding @3 @2 @a + specRounding @4 @1 @a + specRounding @5 @0 @a + specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 5) px + when (maxLen >= 19) $ + specBoundedDecimal (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 19) px +specRounding :: + forall s k p. + ( KnownNat s + , KnownNat k + , KnownNat (s + k) + , Typeable p + , Arbitrary p + , Round RoundHalfUp p + , Round RoundHalfDown p + , Round RoundHalfEven p + , Round RoundDown p + , Round RoundToZero p + ) + => Spec +specRounding = do + prop (propNamePrefix . showsDecimalType @RoundHalfUp @(s + k) @p $ "") $ + prop_Rounding @RoundHalfUp @s @k @p + (roundHalfUpTo (fromIntegral (natVal (Proxy :: Proxy s)))) + prop (propNamePrefix . showsDecimalType @RoundHalfDown @(s + k) @p $ "") $ + prop_Rounding @RoundHalfDown @s @k @p + (roundHalfDownTo (fromIntegral (natVal (Proxy :: Proxy s)))) + prop (propNamePrefix . showsDecimalType @RoundHalfEven @(s + k) @p $ "") $ + prop_Rounding @RoundHalfEven @s @k @p + (roundHalfEvenTo (fromIntegral (natVal (Proxy :: Proxy s)))) + prop (propNamePrefix . showsDecimalType @RoundToZero @(s + k) @p $ "") $ + prop_Rounding @RoundToZero @s @k @p + (roundRoundToZeroTo (fromIntegral (natVal (Proxy :: Proxy s)))) + prop (propNamePrefix . showsDecimalType @RoundDown @(s + k) @p $ "") $ + prop_Rounding @RoundDown @s @k @p + (roundFloorTo (fromIntegral (natVal (Proxy :: Proxy s)))) + where + propNamePrefix = + ("Rounding to " ++) . showsTypeRep (typeRep (Proxy :: Proxy s)) . (" places " ++) + +prop_Rounding :: + forall r s k a. + ( KnownNat s + , KnownNat k + , KnownNat (s + k) + , Round r a + ) + => (Rational -> Rational) + -> Decimal r (s + k) a + -> Property +prop_Rounding roundTo d = + let r = toRationalDecimal d + in fmap toInteger (roundDecimal d :: Decimal r s a) === + throwDecimal (fromRationalDecimalWithoutLoss (roundTo r)) + +showsDecimalType :: + forall r (s :: Nat) p. (Typeable r, Typeable s, Typeable p) + => ShowS +showsDecimalType = ("(Decimal " ++) + . showsType @r . (' ':) + . showsTypeRep (typeRep (Proxy :: Proxy s)) + . (' ':) + . showsType @p + . (')':) + +showsType :: forall t . Typeable t => ShowS +showsType = showsTypeRep (typeRep (Proxy :: Proxy t)) + +throwDecimal :: Either SomeException (Decimal r s p) -> Decimal r s p +throwDecimal = either throw id + specBoundedDecimal :: forall r s p. (Typeable r, Typeable p, KnownNat s, Show p, Integral p, Bounded p, Arbitrary p) => Proxy r -> Proxy s -> Proxy p -> Spec -specBoundedDecimal pr ps pp = do +specBoundedDecimal pr ps pp = describe ("Decimal " ++ showType (Proxy :: Proxy r) ++ " " ++ show (natVal ps) ++ " " ++ showType (Proxy :: Proxy p)) $ do @@ -187,29 +306,37 @@ -- TODO: x times integral / integral == x prop_toFromScientific :: - (Arbitrary p, Integral p, KnownNat s) + (Integral p, KnownNat s) => Proxy r -> Proxy s -> Proxy p -> Decimal r s p -> Property prop_toFromScientific _ _ _ d = - (Right d === toArithException (fmap fromInteger <$> fromScientific (toScientific d))) .&&. - (Right d === toArithException (fmap fromInteger <$> fromScientific (normalize (toScientific d)))) + (Right d === + toArithException + (fmap fromInteger <$> fromScientificDecimal (toScientificDecimal d))) .&&. + (Right d === + toArithException + (fmap fromInteger <$> + fromScientificDecimal (normalize (toScientificDecimal d)))) prop_toFromScientificBounded :: - (Arbitrary p, Integral p, Bounded p, KnownNat s) + (Integral p, Bounded p, KnownNat s) => Proxy r -> Proxy s -> Proxy p -> Decimal r s p -> Property prop_toFromScientificBounded _ _ _ d = - (Right d === toArithException (fromScientificBounded (toScientific d))) .&&. - (Right d === toArithException (fromScientificBounded (normalize (toScientific d)))) + (Right d === + toArithException (fromScientificDecimalBounded (toScientificDecimal d))) .&&. + (Right d === + toArithException + (fromScientificDecimalBounded (normalize (toScientificDecimal d)))) prop_showParseBouded :: - (Arbitrary p, Show p, Integral p, Bounded p, KnownNat s) + (Show p, Integral p, Bounded p, KnownNat s) => Proxy r -> Proxy s -> Proxy p @@ -234,6 +361,22 @@ specBouned (Proxy :: Proxy Word16) specBouned (Proxy :: Proxy Word32) specBouned (Proxy :: Proxy Word64) + describe "Integer" $ do + specRounding @0 @0 @Integer + specRounding @1 @0 @Integer + specRounding @1 @1 @Integer + specRounding @2 @0 @Integer + specRounding @2 @1 @Integer + specRounding @2 @2 @Integer + specRounding @3 @0 @Integer + specRounding @3 @1 @Integer + specRounding @3 @2 @Integer + specRounding @3 @3 @Integer + specRounding @4 @0 @Integer + specRounding @4 @1 @Integer + specRounding @4 @2 @Integer + specRounding @4 @3 @Integer + specRounding @4 @4 @Integer @@ -258,3 +401,43 @@ res `deepseq` return False) $ \exc -> show exc `deepseq` return (isExc exc)) assert hasFailed + +roundHalfUpTo :: Natural -> Rational -> Rational +roundHalfUpTo to rational = + floor ((rational * ((s10 * 10) % 1) + 5) * (1 % 10)) % s10 + where + s10 = 10 ^ to :: Integer + +roundHalfDownTo :: Natural -> Rational -> Rational +roundHalfDownTo to rational = + ceiling ((rational * ((s10 * 10) % 1) - 5) * (1 % 10)) % s10 + where + s10 = 10 ^ to :: Integer + +roundHalfEvenTo :: Natural -> Rational -> Rational +roundHalfEvenTo to rational = + fromInteger (round $ rational * (10 ^ to)) / 10 ^ to + +roundFloorTo :: Natural -> Rational -> Rational +roundFloorTo to rational = (floor (rational * (s10 % 1)) :: Integer) % s10 + where + s10 = 10 ^ to :: Integer + +roundRoundToZeroTo :: Natural -> Rational -> Rational +roundRoundToZeroTo to rational = (truncate (rational * (s10 % 1)) :: Integer) % s10 + where + s10 = 10 ^ to :: Integer + +-- Use for testing once HalfAwayFromZero is implemented +_roundCommercial :: Natural -> Rational -> Rational +_roundCommercial to rational + | rational < 0 = negate (roundPositive (negate rational)) + | otherwise = roundPositive rational + where + s10 = 10 ^ to :: Integer + roundPositive positiveRational = + let (q, r) = quotRem (truncate (positiveRational * (s10 * 10 % 1)) :: Integer) 10 + in (if r >= 5 + then q + 1 + else q) % + s10 diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,12 @@ +module Main where + +import Build_doctests (flags, pkgs, module_sources) +import Data.Foldable (traverse_) +import Test.DocTest (doctest) + +main :: IO () +main = do + traverse_ putStrLn args + doctest args + where + args = flags ++ pkgs ++ module_sources