safe-decimal (empty) → 0.1.0.0

raw patch · 9 files changed

+1160/−0 lines, 9 filesdep +QuickCheckdep +basedep +deepseqsetup-changed

Dependencies added: QuickCheck, base, deepseq, exceptions, hspec, safe-decimal, scientific

Files

ChangeLog.md +3/−0
LICENSE +30/−0
README.md +6/−0
Setup.hs +2/−0
safe-decimal.cabal +46/−0
src/Numeric/Decimal.hs +128/−0
src/Numeric/Decimal/Internal.hs +684/−0
tests/Numeric/DecimalSpec.hs +260/−0
tests/Spec.hs +1/−0

+ ChangeLog.md view

@@ -0,0 +1,3 @@+# Changelog for decimal64++## Unreleased changes

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright FP Complete (c) 2018-2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Alexey Kuleshevich nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,6 @@+# 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ safe-decimal.cabal view

@@ -0,0 +1,46 @@+name:           safe-decimal+version:        0.1.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+homepage:       https://github.com/fpco/safe-decimal#readme+bug-reports:    https://github.com/fpco/safe-decimal/issues+author:         Alexey Kuleshevich+maintainer:     alexey@fpcomplete.com+copyright:      2018-2019 FP Complete+license:        BSD3+license-file:   LICENSE+build-type:     Simple+cabal-version:  >= 1.10+extra-source-files: ChangeLog.md+                    README.md++source-repository head+  type: git+  location: https://github.com/fpco/safe-decimal++library+  exposed-modules: Numeric.Decimal+  other-modules: Numeric.Decimal.Internal+  hs-source-dirs: src+  build-depends: base >=4.7 && <5+               , deepseq+               , exceptions+               , scientific+  ghc-options: -Wall+  default-language: Haskell2010++test-suite tests+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules: Numeric.DecimalSpec+  hs-source-dirs: tests+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends: hspec-discover:hspec-discover+  build-depends: base >=4.7 && <5+               , deepseq+               , safe-decimal+               , scientific+               , QuickCheck+               , hspec+  default-language: Haskell2010

+ src/Numeric/Decimal.hs view

@@ -0,0 +1,128 @@+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs               #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE NegativeLiterals           #-}+module Numeric.Decimal+  ( Decimal64+  , RoundHalfUp+  , RoundFloor+  , Truncate+  , module Numeric.Decimal.Internal+  -- * Operations+  , decimalList+  , sumDecimal+  , productDecimal+  -- * Conversion+  , toScientific+  , fromScientific+  , fromScientificBounded+  ) 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++-- | Most common Decimal type backed by `Int64` and standard rounding+type Decimal64 s = Decimal RoundHalfUp s Int64++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)+    where+      k = fromIntegral (natVal (Proxy :: Proxy k)) :: Int+      (q, r) = quotRem x (10 ^ k)+  {-# INLINABLE roundDecimal #-}++data RoundFloor++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)+    where+      k = fromIntegral (natVal (Proxy :: Proxy k)) :: Int+      (q, r) = quotRem x (10 ^ k)+  {-# INLINABLE roundDecimal #-}++data Truncate++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))+    where+      k = fromIntegral (natVal (Proxy :: Proxy k)) :: Int+  {-# INLINABLE roundDecimal #-}++-- | /O(1)/ - Conversion of a list.+--+-- __Note__: It doesn't do any scaling, eg:+--+-- >>> 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]+--+decimalList :: Integral p => [p] -> [Decimal r s p]+decimalList = coerce+++-- | Sum a list of decimal numbers+sumDecimal ::+     (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 #-}++-- | Multiply all decimal numbers in the list while doing rounding.+productDecimal ::+     (MonadThrow m, Foldable f, KnownNat s, Round r, Integral p, Bounded p)+  => f (Decimal r s p)+  -> m (Decimal r s p)+productDecimal = foldM timesDecimalRounded (fromNum 1)+{-# INLINABLE productDecimal #-}++++---- 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 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+  | point10 > s = throwM Underflow+  | otherwise = pure (Decimal (coefficient num * 10 ^ (s - point10)))+  where+      s = natVal (Proxy :: Proxy s)+      point10 = toInteger (negate (base10Exponent num))++-- | Convert from Scientific to Decimal while checking for Overflow/Underflow+fromScientificBounded ::+     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+  Decimal <$> fromIntegerBounded integer

+ src/Numeric/Decimal/Internal.hs view

@@ -0,0 +1,684 @@+{-# 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))+

+ tests/Numeric/DecimalSpec.hs view

@@ -0,0 +1,260 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE KindSignatures      #-}+{-# LANGUAGE ScopedTypeVariables #-}+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++-- | Values generated will usually be somewhere close to the bounds.+newtype Extremum a = Extremum a deriving Show++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)]]++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))) ""+++prop_plusBounded ::+     (Arbitrary a, Show a, Integral a, Bounded a)+  => [ArithException] -- ^ Exceptions to expect+  -> Extremum a+  -> Extremum a+  -> Property+prop_plusBounded excs (Extremum x) (Extremum y) =+  classify (not withinBounds) "Outside of Bounds" $+  if withinBounds+    then Right res === resBounded+    else disjoin (fmap ((resBounded ===) . Left) excs)+  where+    res = x + y+    withinBounds = toInteger res == toInteger x + toInteger y+    resBounded = toArithException $ plusBounded x y+++prop_minusBounded ::+     (Arbitrary a, Show a, Integral a, Bounded a)+  => [ArithException] -- ^ Exceptions to expect+  -> Extremum a+  -> Extremum a+  -> Property+prop_minusBounded excs (Extremum x) (Extremum y) =+  classify (not withinBounds) "Outside of Bounds" $+  if withinBounds+    then Right res === resBounded+    else disjoin (fmap ((resBounded ===) . Left) excs)+  where+    res = x - y+    withinBounds = toInteger res == toInteger x - toInteger y+    resBounded = toArithException $ minusBounded x y++prop_timesBounded ::+     (Arbitrary a, Show a, Integral a, Bounded a)+  => [ArithException] -- ^ Exceptions to expect+  -> Extremum a+  -> Extremum a+  -> Property+prop_timesBounded excs (Extremum x) (Extremum y) =+  classify (not withinBounds) "Outside of Bounds" $+  if withinBounds+    then Right res === resBounded+    else disjoin (fmap ((resBounded ===) . Left) excs)+  where+    res = x * y+    withinBounds = toInteger res == toInteger x * toInteger y+    resBounded = toArithException $ timesBounded x y++prop_fromIntegerBounded ::+  forall a . (Arbitrary a, Show a, Integral a, Bounded a)+  => [ArithException] -- ^ Exceptions to expect+  -> Int -- ^ This is used for scaling+  -> Extremum a+  -> Property+prop_fromIntegerBounded excs n (Extremum x) =+  classify (not withinBounds) "Outside of Bounds" $+  if withinBounds+    then Right (fromInteger x') === resBounded+    else disjoin (fmap ((resBounded ===) . Left) excs)+  where+    multiplier = (n `mod` 3) + 1+    x' = toInteger x * toInteger multiplier -- Try to go overboard 66% of the time+    withinBounds = x' == toInteger (x * fromIntegral multiplier)+    resBounded :: Either ArithException a+    resBounded = toArithException $ fromIntegerBounded x'++-- | Throw all exceptions except the ArithException+toArithException :: Either SomeException a -> Either ArithException a+toArithException eRes =+  case eRes of+    Left exc+      | Just arithExc <- fromException exc -> Left arithExc+    Left exc -> throw exc+    Right res -> Right res++prop_divBounded ::+     (Arbitrary a, Show a, Integral a, Bounded a, NFData a)+  => Extremum a+  -> Extremum a+  -> Property+prop_divBounded (Extremum x) (Extremum y) =+  classify (isLeft resBounded) "Received Exception" $+  case resBounded of+    Left exc  -> assertException (==exc) (x `div` y)+    Right res -> res === x `div` y+  where+    resBounded = toArithException $ divBounded x y++prop_quotBounded ::+     (Arbitrary a, Show a, Integral a, Bounded a, NFData a)+  => Extremum a+  -> Extremum a+  -> Property+prop_quotBounded (Extremum x) (Extremum y) =+  classify (isLeft resBounded) "Received Exception" $+  case resBounded of+    Left exc  -> assertException (==exc) (x `quot` y)+    Right res -> res === x `quot` y+  where+    resBounded = toArithException $ quotBounded x y+++specBouned ::+     forall a. (Typeable a, Arbitrary a, Show a, Integral a, Bounded a, NFData 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)+    it "minusBounded" $+      property (prop_minusBounded excs :: Extremum a -> Extremum a -> Property)+    it "timesBounded" $+      property (prop_timesBounded excs :: Extremum a -> 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+  let maxLen = length (show (maxBound :: a))+  when (maxLen >= 3) $ do+    specBoundedDecimal  (Proxy :: Proxy RoundHalfUp) (Proxy :: Proxy 3) px+  when (maxLen >= 4) $ do+    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++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+  describe+    ("Decimal " ++ showType (Proxy :: Proxy r) ++ " " ++ show (natVal ps) ++ " " +++     showType (Proxy :: Proxy p)) $ do+    it "toFromScientific" $ property $ prop_toFromScientific pr ps pp+    it "toFromScientificBounded" $ property $ prop_toFromScientificBounded pr ps pp+    it "showParseBounded" $ property $ prop_showParseBouded pr ps pp+    -- TODO: x times integral / integral == x++prop_toFromScientific ::+     (Arbitrary p, 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))))++prop_toFromScientificBounded ::+     (Arbitrary p, 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))))++prop_showParseBouded ::+     (Arbitrary p, Show p, Integral p, Bounded p, KnownNat s)+  => Proxy r+  -> Proxy s+  -> Proxy p+  -> Decimal r s p+  -> Property+prop_showParseBouded _ _ _ d@(Decimal x) =+  case parseDecimalBounded False (show d) of+    Left err              -> error err+    Right d'@(Decimal x') -> x === x' .&&. d === d'++spec :: Spec+spec = do+  describe "Int" $ do+    specBouned (Proxy :: Proxy Int)+    specBouned (Proxy :: Proxy Int8)+    specBouned (Proxy :: Proxy Int16)+    specBouned (Proxy :: Proxy Int32)+    specBouned (Proxy :: Proxy Int64)+  describe "Word" $ do+    specBouned (Proxy :: Proxy Word)+    specBouned (Proxy :: Proxy Word8)+    specBouned (Proxy :: Proxy Word16)+    specBouned (Proxy :: Proxy Word32)+    specBouned (Proxy :: Proxy Word64)+++++assertException :: (NFData a, Exception exc) =>+                   (exc -> Bool) -- ^ Return True if that is the exception that was expected+                -> a -- ^ Value that should throw an exception, when fully evaluated+                -> Property+assertException isExc action = assertExceptionIO isExc (return action)+++assertExceptionIO :: (NFData a, Exception exc) =>+                     (exc -> Bool) -- ^ Return True if that is the exception that was expected+                  -> IO a -- ^ IO Action that should throw an exception+                  -> Property+assertExceptionIO isExc action =+  monadicIO $ do+    hasFailed <-+      run+        (catch+           (do res <- action+               res `deepseq` return False) $ \exc ->+           show exc `deepseq` return (isExc exc))+    assert hasFailed

+ tests/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}