safe-decimal 0.1.0.0 → 0.2.0.0

raw patch · 9 files changed

+2134/−802 lines, 9 filesdep +doctestdep +template-haskelldep ~basebuild-type:Customsetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies added: doctest, template-haskell

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• ChangeLog.md +18/−2
• README.md +12/−4
• Setup.hs +32/−0
• safe-decimal.cabal +27/−3
• src/Numeric/Decimal.hs +501/−64
• src/Numeric/Decimal/BoundedArithmetic.hs +216/−0
• src/Numeric/Decimal/Internal.hs +1088/−684
• tests/Numeric/DecimalSpec.hs +228/−45
• tests/doctests.hs +12/−0

@@ -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

@@ -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.

@@ -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+

@@ -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 <https://github.com/fpco/safe-decimal#readme> 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

@@ -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

@@ -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 #-}+

@@ -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)

@@ -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

@@ -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