deka (empty) → 0.2.0.0
raw patch · 15 files changed
+4286/−0 lines, 15 filesdep +QuickCheckdep +basedep +bindings-DSLsetup-changed
Dependencies added: QuickCheck, base, bindings-DSL, bytestring, either, tasty, tasty-quickcheck, transformers
Files
- LICENSE +30/−0
- README.md +58/−0
- Setup.hs +2/−0
- deka.cabal +122/−0
- lib/Data/Deka.hs +168/−0
- lib/Data/Deka/Decnumber.hsc +211/−0
- lib/Data/Deka/Docs.hs +23/−0
- lib/Data/Deka/Docs/Examples.lhs +282/−0
- lib/Data/Deka/Internal.hs +78/−0
- lib/Data/Deka/Quad.hs +1774/−0
- test/DataDir.hs +12/−0
- test/DataDir/DekaDir.hs +10/−0
- test/DataDir/DekaDir/QuadTest.hs +1422/−0
- test/DataDir/DekaTest.hs +81/−0
- test/tasty-test.hs +13/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Omari Norman++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 Omari Norman 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,58 @@+deka provides correctly rounded decimal arithmetic for Haskell.++Currently the library is nearly done, but it needs more tests and+documentation, which I'm working on. Use at your own risk.++The core of deka is a binding to the C library decNumber. As the+author of deka, I have no association with the author of decNumber,+and any errors in this library are mine and should be reported to+omari@smileystation.com or to the Github tracker at++http://www.github.com/massysett/deka++deka uses the decQuad functions in decNumber. This means that deka+is limited to 34 digits of precision. Because 1 quadrillion (that+is, one thousand trillion) has only 16 digits of precision, I figure+that 34 should be sufficient for many uses. Also, you are limited+to exponents no smaller than -6176 and no greater than 6111. deka+will notify you if you perform calculations that must be rounded in+order to fit within the 34 digits of precision or within the size+limits for the exponent.++You will want to understand decNumber and the General Decimal+Arithmetic Specification in order to fully understand deka. The+specification is at++http://speleotrove.com/decimal/decarith.html++and decNumber is at++http://speleotrove.com/decimal/decnumber.html++and more about decimal arithmetic generally at++http://speleotrove.com/decimal/++You will need to have the decNumber library installed in order to+use this library. I have packaged decNumber for easy installation,+as the original decNumber files are distributed as plain C files+without any provision for installation as a library. This packaging+was done without any collaboration with the author of decNumber, so+use it at your own risk. The latest version of the package is+downloadable by clicking on the big green button here:++https://github.com/massysett/decnumber/releases++Much more documentation is available in the Haddock comments in the+source files. There is also a file of examples to get you started.+It has copious comments. It is written in literate Haskell, so the+compiler keeps me honest with the example code. Unfortunately+Haddock does not play very nice with literate Haskell. However, the+file is easy to view on Github:++[Examples](lib/Data/Deka/Docs/Examples.lhs)++deka is licensed under the BSD license, see the LICENSE file.++[](https://travis-ci.org/massysett/deka)+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ deka.cabal view
@@ -0,0 +1,122 @@+name: deka++-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented.+-- http://www.haskell.org/haskellwiki/Package_versioning_policy+-- PVP summary: +-+------- breaking API changes+-- | | +----- non-breaking API additions+-- | | | +--- code changes with no API change+version: 0.2.0.0+synopsis: Decimal floating point arithmetic++description:+ deka provides decimal floating point arithmetic. It+ is based on the decNumber C library, which is available+ at+ .+ <http://speleotrove.com/decimal/decnumber.html>+ .+ decNumber, in turn, implements the General Decimal Arithmetic+ Specification, which is available at+ .+ <http://speleotrove.com/decimal/>+ .+ To use deka, you will first need to install the decNumber+ C library. To make this easy for users of UNIX-like operating+ systems, I have packaged decNumber; the package is at+ .+ <https://github.com/massysett/decnumber/releases>+ .+ For more on deka, please see the Github home page at+ .+ <https://github.com/massysett/deka>++-- URL for the project homepage or repository.+homepage: http://www.github.com/massysett/deka++-- The license under which the package is released.+license: BSD3++-- The file containing the license text.+license-file: LICENSE++-- The package author(s).+author: Omari Norman++-- An email address to which users can send suggestions, bug reports, and +-- patches.+maintainer: omari@smileystation.com++-- A copyright notice.+-- copyright: ++category: Math++build-type: Simple++-- Extra files to be distributed with the package, such as examples or a +-- README.+extra-source-files: README.md++-- Constraint on the version of Cabal needed to build this package.+cabal-version: >=1.10++library+ hs-source-dirs: lib+ extra-libraries: decnumber+ + exposed-modules: + Data.Deka+ , Data.Deka.Decnumber+ , Data.Deka.Quad+ , Data.Deka.Docs+ , Data.Deka.Docs.Examples++ other-modules:+ Data.Deka.Internal+ + build-depends:+ base >=4.6 && <4.7+ , bytestring ==0.10.*+ , transformers ==0.3.*+ , either ==4.1.*+ , bindings-DSL ==1.0.*++ ghc-options: -Wall+ default-language: Haskell2010++-- The test suite does not have deka listed in the build-depends.+-- This lengthens the compilation times but it allows the test suite+-- to have access to Data.Deka.Internal, which is critical for+-- testing.++Test-Suite tasty-test+ Build-depends:+ base ==4.6.*+ , either ==4.1.*+ , tasty-quickcheck ==0.3.*+ , tasty ==0.7.*+ , QuickCheck ==2.6.*+ , bytestring ==0.10.*+ , transformers ==0.3.*++ extra-libraries: decnumber++ other-modules:+ Data.Deka+ , Data.Deka.Decnumber+ , Data.Deka.Quad+ , Data.Deka.Docs+ , Data.Deka.Docs.Examples++ , DataDir+ , DataDir.DekaDir+ , DataDir.DekaTest+ , DataDir.DekaDir.QuadTest++ type: exitcode-stdio-1.0+ hs-source-dirs: test lib+ ghc-options: -Wall -rtsopts -fprof-auto+ main-is: tasty-test.hs+ default-language: Haskell2010+
+ lib/Data/Deka.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE Safe, DeriveDataTypeable #-}++-- | Simple decimal arithmetic.+--+-- 'Deka' provides a decimal arithmetic type. You are limited to 34+-- digits of precision. That's 34 digits total, not 34 digits after+-- the decimal point. For example, the numbers @123.0@ and @0.1230@+-- both have four digits of precision. Deka remembers significant+-- digits, so @123@ has three digits of precision while @123.0@ has+-- four digits of precision.+--+-- Using this module, the results are never inexact. Computations+-- will throw exceptions rather than returning an inexact result.+-- That way, you know that any result you have is exactly correct.+--+-- 'Deka' represents only finite values. There are no infinities or+-- not-a-number values allowed.+--+-- For more control over your arithmetic, see "Data.Deka.Quad", but+-- for many routine uses this module is sufficient and is more+-- succinct because, unlike 'Quad', 'Deka' is a member of the 'Num'+-- typeclass.+module Data.Deka+ ( Deka+ , unDeka+ , DekaT(..)+ , integralToDeka+ , strToDeka+ , quadToDeka+ , DekaError(..)+ ) where++import Control.Exception+import Data.Maybe+import Data.Typeable+import Data.Deka.Quad+import qualified Data.Deka.Quad as P+import qualified Data.ByteString.Char8 as BS8++-- | Thrown by arithmetic functions in the Num class, as this is the+-- only way to indicate errors.+data DekaError+ = IntegerTooBig Integer+ -- ^ Could not convert an integer to a Deka; it is too big.+ | Flagged Flags+ -- ^ A computation set flags. This will happen if, for example,+ -- you calculate a result that is out of range, such as+ --+ -- >>> maxBound + maxBound :: Deka+ deriving (Show, Typeable)++instance Exception DekaError++-- | Deka wraps a 'Quad'. Only finite 'Quad' may become a 'Deka';+-- no infinities or NaN values are allowed.+--+-- 'Deka' is a member of 'Num' and 'Real', making it easy to use for+-- elementary arithmetic. Any time you perform arithmetic, the+-- results are always exact. The arithmetic functions will throw+-- exceptions rather than give you an inexact result.+--+-- 'Deka' is not a member 'Fractional' because it is generally+-- impossible to perform division without getting inexact results,+-- and 'Deka' never holds inexact results.+newtype Deka = Deka { unDeka :: Quad }+ deriving Show++eval :: Ctx a -> a+eval c+ | fl == emptyFlags = r+ | otherwise = throw . Flagged $ fl+ where+ (r, fl) = runCtx c++-- | Eq compares by value. For instance, @3.5 == 3.500@.+instance Eq Deka where+ Deka x == Deka y = case compareOrd x y of+ Just EQ -> True+ Just _ -> False+ _ -> error "Deka: Eq: unexpected result"++-- | Ord compares by value. For instance, @compare 3.5 3.500 ==+-- EQ@.+instance Ord Deka where+ compare (Deka x) (Deka y) = case compareOrd x y of+ Just r -> r+ _ -> error "Deka: compare: unexpected reslt"++-- | Many of the 'Num' functions will throw 'DekaError' if their+-- arguments are out of range or if they produce results that are+-- out of range or inexact. For functions that don't throw, you can+-- use 'integralToDeka' rather than 'fromInteger', or you can use+-- "Data.Deka.Quad" instead of 'Deka'.+instance Num Deka where+ Deka x + Deka y = Deka . eval $ P.add x y+ Deka x - Deka y = Deka . eval $ P.subtract x y+ Deka x * Deka y = Deka . eval $ P.multiply x y+ negate = Deka . eval . P.minus . unDeka+ abs = Deka . eval . P.abs . unDeka+ signum (Deka x)+ | f isZero = fromInteger 0+ | f isNegative = fromInteger (-1)+ | otherwise = fromInteger 1+ where+ f g = g x+ fromInteger i = fromMaybe (throw (IntegerTooBig i))+ . integralToDeka $ i++instance Real Deka where+ toRational (Deka x) = case decodedToRational . toBCD $ x of+ Nothing -> error "Deka.toRational: failed."+ Just r -> r++instance Bounded Deka where+ minBound = Deka $ fromBCD (Decoded Sign1 (Finite oneCoeff minBound))+ where+ oneCoeff = succ minBound+ maxBound = Deka $ fromBCD (Decoded Sign0 (Finite maxBound maxBound))+++-- | Decimals with a total ordering.+newtype DekaT = DekaT { unDekaT :: Deka }+ deriving Show++-- | Eq compares by a total ordering.+instance Eq DekaT where+ DekaT (Deka x) == DekaT (Deka y)+ | r == EQ = True+ | otherwise = False+ where+ r = compareTotal x y++-- | Ord compares by a total ordering.+instance Ord DekaT where+ compare (DekaT (Deka x)) (DekaT (Deka y)) = compareTotal x y+++-- | Convert any integral to a Deka. Returns 'Nothing' if the+-- integer is too big to fit into a Deka (34 digits).+integralToDeka :: Integral a => a -> Maybe Deka+integralToDeka i = do+ coe <- P.coefficient . P.integralToDigits $ i+ let d = Decoded sgn (Finite coe zeroExponent)+ sgn = if i < 0 then Sign1 else Sign0+ return . Deka $ fromBCD d++-- | Convert a string to a Deka. You can use ordinary numeric+-- strings, such as @3.25@, or exponential notation, like @325E-2@.+-- More infomration on your choices is at:+--+-- <http://speleotrove.com/decimal/daconvs.html#reftonum>+--+-- You cannot use strings that represent an NaN or an infinity. If+-- you do that, or use an otherwise invalid string, this function+-- returns 'Nothing'.+strToDeka :: String -> Maybe Deka+strToDeka s+ | fl /= emptyFlags = Nothing+ | not (isFinite r) = Nothing+ | otherwise = Just (Deka r)+ where+ (r, fl) = runCtx . fromByteString . BS8.pack $ s++-- | Change a Quad to a Deka. Only succeeds for finite Quad.+quadToDeka :: Quad -> Maybe Deka+quadToDeka q+ | isFinite q = Just $ Deka q+ | otherwise = Nothing
+ lib/Data/Deka/Decnumber.hsc view
@@ -0,0 +1,211 @@+{-# LANGUAGE ForeignFunctionInterface #-}+-- Bindings-dsl sometimes shadows in do notation+-- Bindings-dsl imports unused things++{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-unused-imports #-}++#include <bindings.dsl.h>+#include <decContext.h>+#include <decQuad.h>++-- | Low-level bindings to the decNumber library.+module Data.Deka.Decnumber where++#strict_import++#num NULL++#integral_t enum rounding+#num DEC_ROUND_CEILING+#num DEC_ROUND_UP+#num DEC_ROUND_HALF_UP+#num DEC_ROUND_HALF_EVEN+#num DEC_ROUND_HALF_DOWN+#num DEC_ROUND_DOWN+#num DEC_ROUND_FLOOR+#num DEC_ROUND_05UP+#num DEC_ROUND_MAX++#integral_t int32_t+#integral_t uint8_t+#integral_t uint16_t+#integral_t uint32_t+#integral_t uint64_t+++#starttype decContext+#field digits , <int32_t>+#field emax , <int32_t>+#field emin , <int32_t>+#field round , <enum rounding>+#field traps , <uint32_t>+#field status , <uint32_t>+#field clamp , <uint8_t>+#stoptype++-- decContext+#num DEC_INIT_DECQUAD+#ccall_unsafe decContextDefault , Ptr <decContext> -> <int32_t> -> IO (Ptr <decContext>)++#integral_t enum decClass+#num DEC_CLASS_SNAN+#num DEC_CLASS_QNAN+#num DEC_CLASS_NEG_INF+#num DEC_CLASS_NEG_NORMAL+#num DEC_CLASS_NEG_SUBNORMAL+#num DEC_CLASS_NEG_ZERO+#num DEC_CLASS_POS_ZERO+#num DEC_CLASS_POS_SUBNORMAL+#num DEC_CLASS_POS_NORMAL+#num DEC_CLASS_POS_INF++#num DEC_Conversion_syntax+#num DEC_Division_by_zero+#num DEC_Division_impossible+#num DEC_Division_undefined+#num DEC_Insufficient_storage+#num DEC_Inexact+#num DEC_Invalid_context+#num DEC_Invalid_operation+#num DEC_Overflow+#num DEC_Clamped+#num DEC_Rounded+#num DEC_Subnormal+#num DEC_Underflow++#num DEC_IEEE_754_Division_by_zero+#num DEC_IEEE_754_Inexact+#num DEC_IEEE_754_Invalid_operation+#num DEC_IEEE_754_Overflow+#num DEC_IEEE_754_Underflow+#num DEC_Errors+#num DEC_NaNs++#num DEC_Condition_Length++#num DEC_INIT_BASE+#num DEC_INIT_DECIMAL32+#num DEC_INIT_DECIMAL64+#num DEC_INIT_DECIMAL128+++#num DECQUAD_Bytes+#num DECQUAD_Pmax+#num DECQUAD_Emin+#num DECQUAD_Emax+#num DECQUAD_EmaxD+#num DECQUAD_Bias+#num DECQUAD_String+#num DECQUAD_EconL+#num DECQUAD_Declets+#num DECQUAD_Ehigh++#starttype decQuad+#array_field bytes , <uint8_t>+#array_field shorts , <uint16_t>+#array_field words , <uint32_t>+#stoptype+++#num DECFLOAT_Sign+#num DECFLOAT_NaN+#num DECFLOAT_qNaN+#num DECFLOAT_sNaN+#num DECFLOAT_Inf+#num DECFLOAT_MinSp++#num DECPPLUSALT+#num DECPMINUSALT+#num DECPPLUS+#num DECPMINUS+#num DECPPLUSALT2+#num DECPUNSIGNED++-- Utilities++#ccall_unsafe decQuadToInt32 , Ptr <decQuad> -> Ptr <decContext> -> <enum rounding> -> IO <int32_t>+#ccall_unsafe decQuadToInt32Exact , Ptr <decQuad> -> Ptr <decContext> -> <enum rounding> -> IO <int32_t>++#ccall_unsafe decQuadFromInt32 , Ptr <decQuad> -> <int32_t> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadFromPacked , Ptr <decQuad> -> <int32_t> -> Ptr <uint8_t> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadFromPackedChecked , Ptr <decQuad> -> <int32_t> -> Ptr <uint8_t> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadFromUInt32 , Ptr <decQuad> -> <uint32_t> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadFromString , Ptr <decQuad> -> CString -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadGetCoefficient , Ptr <decQuad> -> Ptr <uint8_t> -> IO <int32_t>+#ccall_unsafe decQuadGetExponent , Ptr <decQuad> -> IO <int32_t>+#ccall_unsafe decQuadSetCoefficient , Ptr <decQuad> -> Ptr <uint8_t> -> <int32_t> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadSetExponent , Ptr <decQuad> -> Ptr <decContext> -> <int32_t> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadShow , Ptr <decQuad> -> CString -> IO ()+#ccall_unsafe decQuadToEngString , Ptr <decQuad> -> CString -> IO CString+#ccall_unsafe decQuadToString , Ptr <decQuad> -> CString -> IO CString+#ccall_unsafe decQuadToUInt32 , Ptr <decQuad> -> Ptr <decContext> -> <enum rounding> -> IO <uint32_t>+#ccall_unsafe decQuadToUInt32Exact , Ptr <decQuad> -> Ptr <decContext> -> <enum rounding> -> IO <uint32_t>+#ccall_unsafe decQuadZero , Ptr <decQuad> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadAbs , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadAdd , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadAnd , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadDivide , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadDivideInteger , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadFMA , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadFromBCD , Ptr <decQuad> -> <int32_t> -> Ptr <uint8_t> -> <int32_t> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadInvert , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadLogB , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadMax , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadMaxMag , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadMin , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadMinMag , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadMinus , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadMultiply , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadNextMinus , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadNextPlus , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadNextToward , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadOr , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadPlus , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadQuantize , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadReduce , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadRemainder , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadRemainderNear , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadRotate , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadScaleB , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadShift , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadSubtract , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadToBCD , Ptr <decQuad> -> Ptr <int32_t> -> Ptr <uint8_t> -> IO <int32_t>+#ccall_unsafe decQuadToIntegralValue , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> <enum rounding> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadToIntegralExact , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadXor , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)++-- Comparisons++#ccall_unsafe decQuadCompare , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadCompareSignal , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decContext> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadCompareTotal , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadCompareTotalMag , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> IO (Ptr <decQuad>)++-- Copies+#ccall_unsafe decQuadCanonical , Ptr <decQuad> -> Ptr <decQuad> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadCopyAbs , Ptr <decQuad> -> Ptr <decQuad> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadCopyNegate , Ptr <decQuad> -> Ptr <decQuad> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadCopySign , Ptr <decQuad> -> Ptr <decQuad> -> Ptr <decQuad> -> IO (Ptr <decQuad>)+#ccall_unsafe decQuadCopy , Ptr <decQuad> -> Ptr <decQuad> -> IO (Ptr <decQuad>)++-- Non-computational++#ccall_unsafe decQuadClass , Ptr <decQuad> -> IO <decClass>+#ccall_unsafe decQuadClassString , Ptr <decQuad> -> IO CString+#ccall_unsafe decQuadDigits , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsCanonical , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsFinite , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsInteger , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsLogical , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsInfinite , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsNaN , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsNegative , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsNormal , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsPositive , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsSignaling , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsSigned , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsSubnormal , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadIsZero , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadRadix , Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadSameQuantum , Ptr <decQuad> -> Ptr <decQuad> -> IO <uint32_t>+#ccall_unsafe decQuadVersion , IO CString
+ lib/Data/Deka/Docs.hs view
@@ -0,0 +1,23 @@+-- | Documentation for Deka.+--+-- At the moment, documentation is scattered about. Some of it is+-- in the main README.md, which is in the source code tree and is+-- viewable in Github at+--+-- <http://github.com/massysett/deka/blob/master/README.md>+--+-- Of course much of it is in the Haddock comments in the source+-- code itself.+--+-- There is also a module here, "Data.Deka.Docs.Examples". It is in+-- literate Haskell and has many comments. Unfortunately Haddock+-- does not play well with Literate Haskell. However, the style of+-- the file would not play well with Haddock anyway so I'm not sure+-- I would ever switch back to regular Haskell for that file.+--+-- So if you link to the file from the Haddock docs, you will just+-- get a blank page. Fortunately it is easily readable in Github:+--+-- <http://github.com/massysett/deka/blob/master/lib/Data/Deka/Docs/Examples.hs>++module Data.Deka.Docs where
+ lib/Data/Deka/Docs/Examples.lhs view
@@ -0,0 +1,282 @@+Examples for the Deka library+=============================++For very simple arithmetic, just import `Data.Deka`. It contains a+`Deka` type, which is an instance of Num. For more control over your+arithmetic, import `Data.Deka.Quad`. Be aware that `Quad` exports some+functions that clash with Prelude names, so you might want to do a+qualified `import`; however we will just import them unqualified+here.++> -- Examples will deliberately shadow some names+> {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+>+> -- | If you are viewing this module in Haddock and expecting to+> -- see examples, you won't see anything. The file is written in+> -- literate Haskell, so the idea is that you will look at the+> -- source itself. You can look at the source in Haddock, but it+> -- will probably be poorly formatted because HsColour formats it+> -- rather oddly by default. The easiest way to see it+> -- is on Github:+> --+> -- <https://github.com/massysett/deka/blob/master/lib/Data/Deka/Docs/Examples.lhs>+> module Data.Deka.Docs.Examples where++> import Data.Deka+> import Data.Maybe+> import Data.Deka.Quad++We need Char8 ByteStrings when working with the `Quad` module:++> import qualified Data.ByteString.Char8 as BS8++> examples :: IO ()+> examples = do {++Why is decimal arithmetic important? The webpages here discuss the+issue at great length:++http://speleotrove.com/decimal/++But in a nutshell, the floats that are built in to nearly every+computer language, including Haskell, are approximate. That's OK+for many purposes. It's not OK if you need exact results, such as+for financial purposes.++For example, on my machine this will not output 0.3 but instead will+output 0.3 plus a small fraction:++> print $ 0.1 + 0.1 + (0.1 :: Double);++This sort of imprecision adds up quickly and makes your life as a+programmer harder in many ways. It also produces results that are+simply incorrect if you needed an exact answer.++For simple arithmetic like this, deka provides the `Deka` type. It is+an instance of `Num`. Results with the `Deka` type are never, ever+rounded. You are limited to 34 digits of precision. If you need+more than 34 digits of precision, you can afford to pay someone to+develop your own library :) For example, these numbers all have 5+digits of precision:++ 12345+ 123.45+ 0.12345+ 0.00012345++All numbers in deka are stored as a "coefficient" and an "exponent".+The coefficient is an integer, and the exponent is an+integer that may be negative, zero, or positive. Here, the+coefficient is always 12345, but the exponent varies:++ Number Exponent+ 12345 0+ 123.45 -2+ 0.12345 -5+ 0.00012345 -8++Some numbers can only accurately be written down using scientific+notation if we want to reflect how many digits are in the+coefficient. We can do this with E notation, where the coefficient+is followed by the exponent. To get the original number, if the+coefficient is c and the exponent is e, do++ c * 10 ^ e++So, for example, you can say that `12345e0` and `1234500e-2` are the+same number, but they have different coefficients.++For more about decimal arithmetic, you will really want to read++http://speleotrove.com/decimal/decarith.html++It's written in a very clear style.++OK, so back to `Deka`. We said that `print $ 0.1 + 0.1 + 0.1` yields+an inaccurate result. How to do it with `Deka`?++First we have to create a `Deka`. `Deka` is not an instance of+`Read`. However you can use `strToDeka`, which has the type++ strToDeka :: String -> Maybe Deka++If you give a bad input string, you get `Nothing`; otherwise you get+a `Just` with your `Deka`. The input string can be in regular or+scientific notation.++So, the following snippet will not give you incorrectly rounded+results:++> let { oneTenth = fromJust . strToDeka $ "0.1" };+> print $ oneTenth + oneTenth + oneTenth;++`Deka` is not an instance of other numeric typeclasses, such as+`Real` or `Fractional`. That's because `Deka` never ever rounds, no+matter what. For `Deka` to be a member of `Fractional`, it would+need to implement division, and division without rounding can't do+very much.++Sometimes it will be impossible for `Deka` to do its math without+rounding. In that case, the functions in the `Deka` module will+apply `error` and quit. That way you are assured that if you have a+result, it is not rounded.+++More flexibility with the `Data.Deka.Quad` module+===============================================++Though the `Deka` type provides you with some flexibility--and it's+easy to use because it's an instance of `Num`--sometimes you need more+flexibility. If you want to perform division, for example, `Deka` is+no good. For more flexibility, but more cumbersome use, turn to the+`Data.Deka.Quad` module.++The main type of the `Quad` module is called `Quad`, after decQuad in+the decNumber library. It exposes the full power of the decNumber+library. The disadvantage is that many computations must be+performed in the `Ctx` monad. This monad carries the state that+decNumber needs to do its work. It provides you with a lot of+information about any errors that have occurred during computations.++If you are getting into the `Quad` module, you really need to read the+decimal arithmetic specification at++http://speleotrove.com/decimal/decarith.html++Context+-------++This specification provides that many computations occur within a+so-called "context", which holds information that affects the+computation, such as how to round inexact results. The context also+holds information about any errors that have happened so far, such+as division by zero, and can tell you other information such as+whether any computations performed so far have calculated an inexact+result.++The context of the decimal arithmetic specification is represented+in Deka by the `Ctx` type. `Ctx` provides computations with the+context that they need, and it allows computations to record errors+that may arise. `Ctx` is a `Monad` so you can use the usual monad+functions and `do` notation to combine your computations.+`Data.Deka.Quad` has functions you can use to change the context's+rounding, see what errors have been set, and clear errors. Once an+error flag is set, you have to clear it; the functions in `Quad`+won't clear it for you. However, computations can proceed normally+even if an error flag was set in a previous computation.++After building up a computation in the `Ctx` monad, you need a way+to get the results and use them elsewhere in your program. Two+functions do this: `runCtx` and `evalCtx`. `runCtx` has type++ runCtx :: Ctx a -> (a, Flags)++It gives you the result of the computation, as well as any flags+that may have arisen. Later we'll talk more about flags; they+indicate any errors or warnings that arose during a computation.+`evalCtx` has type++ evalCtx :: Ctx a -> a++so it does not tell you any flags that may have arisen.++Not all computations need a context. For example, `compareTotal`+does not need a context, and it can never return an error. These+functions are pure like any other Haskell function.++Example - using `do` notation+-----------------------------++Following is an example of how you would add one tenth using the+Quad type:++> let { oneTenth = evalCtx . fromByteString . BS8.pack $ "0.1" };+> BS8.putStrLn . toByteString . evalCtx $ do+> r1 <- add oneTenth oneTenth+> add r1 oneTenth+> ;++As you can see this is much more cumbersome than using `Deka`. But+it does give you the full power of decNumber.++Rounding+--------++One reason to use the `Deka` module is because you want greater+control over rounding. There are many varieties of rounding+available, which you can set. This can be useful with division, for+example, where you will not get exact results. All results are+computed to 34 digits of precision.++> let tenSixths = evalCtx $ do+> setRound roundDown+> ten <- fromByteString . BS8.pack $ "10"+> three <- fromByteString . BS8.pack $ "6"+> divide ten three+> ;++Perhaps you want to round the result to a particular number of+decimal places. You do this with the `quantize` function. It takes+two `Quad`: one that you want to round, and another that has the+number of decimal places you want to round to.++> putStrLn "This is 10 / 6, rounded to two places:";+> BS8.putStrLn . toByteString . evalCtx $ do+> twoPlaces <- fromByteString . BS8.pack $ "1e-2"+> quantize tenSixths twoPlaces+> ;++By default, rounding is done using the "roundHalfEven" method. You+can set a different rounding method if you wish; the rounding+methods are listed in the Haddock documentation for `Data.Deka.Quad`.++> putStrLn "This is 10 / 6, rounded using the 'roundDown' method.";+> BS8.putStrLn . toByteString . evalCtx $ do+> twoPlaces <- fromByteString . BS8.pack $ "1e-2"+> setRound roundDown+> quantize tenSixths twoPlaces+> ;+++Flags+-----++A computation may set any number of flags. These are listed in the+`Data.Deka.Quad` module. They indicate errors (like division by zero)+or give information (such as the fact that a computation was+inexact.) Functions in `Data.Deka.Quad` manipulate which flags are+currently set. Though computations set flags, they never clear+them. You have to clear them yourself.++In addition to flags being available for inspection within the `Ctx`+monad, you can get the final flags using `runCtx`. ++> let (r, fl) = runCtx $ do+> big1 <- fromByteString . BS8.pack $ "987e3000"+> big2 <- fromByteString . BS8.pack $ "322e6000"+> rslt <- multiply big1 big2+> return $ toByteString rslt+> ; +> putStr "result: ";+> BS8.putStrLn r;+> putStr "flags set: ";+> print fl;++The above example also shows that computations may return a Quad+that is not finite--that is, it might be inifite, or it might be a+Not-a-Number, or NaN. In contrast, computations using the Deka type+never return non-finite values.++Conclusion+----------++That should be enough to get you started. If you find any bug no+matter how small--even just a typo in the documentation--report it+to me at omari@smileystation.com or file a ticket or a pull request+in Github:++https://github.com/massysett/deka++No bug is too small!++> };
+ lib/Data/Deka/Internal.hs view
@@ -0,0 +1,78 @@+-- | Internal types - for Deka use only+--+-- This module is not listed for export in the cabal file. It+-- contains types that library users have no access to, but which+-- are needed by multiple Deka modules or that the test suite needs+-- access to.+module Data.Deka.Internal where++import Foreign.Safe+import Foreign.C+import qualified Data.ByteString.Char8 as BS8+import Data.Deka.Decnumber+import Control.Applicative+import Control.Monad+import System.IO.Unsafe (unsafePerformIO)++-- | The Ctx monad+--+-- The General Decimal Arithmetic specification states that most+-- computations occur within a @context@, which affects the manner+-- in which computations are done (for instance, the context+-- determines the rounding algorithm). The context also carries+-- the flags that computations can set (for instance, a computation might+-- set a flag to indicate that the result is rounded or inexact or+-- was a division by zero.) The Ctx monad carries this context.+newtype Ctx a = Ctx { unCtx :: Ptr C'decContext -> IO a }++instance Functor Ctx where+ fmap = liftM++instance Applicative Ctx where+ pure = return+ (<*>) = ap++instance Monad Ctx where+ return a = Ctx $ \_ -> return a+ Ctx a >>= f = Ctx $ \p -> do+ r1 <- a p+ let b = unCtx $ f r1+ b p+ fail s = Ctx $ \_ -> fail s++-- | Decimal number. As indicated in the General Decimal+-- Arithmetic specification, a 'Quad' might be a finite number+-- (perhaps the most common type) or it might be infinite or a+-- not-a-number. 'decClass' will tell you a little more about a+-- particular 'Quad'.+newtype Quad = Quad { unQuad :: ForeignPtr C'decQuad }++-- | The Show instance uses 'toByteString'.+instance Show Quad where+ show = BS8.unpack . toByteString++-- | Converts a 'Quad' to a string. May use non-scientific+-- notation, but only if that's unambiguous; otherwise, uses+-- scientific notation.+--+-- In the decNumber C library, this is called @toString@; the name+-- was changed here because this function doesn't return a Haskell+-- 'String'.+toByteString :: Quad -> BS8.ByteString+toByteString = mkString unsafe'c'decQuadToString++type MkString+ = Ptr C'decQuad+ -> CString+ -> IO CString++mkString+ :: MkString+ -> Quad+ -> BS8.ByteString+mkString f d = unsafePerformIO $+ withForeignPtr (unQuad d) $ \pD ->+ allocaBytes c'DECQUAD_String $ \pS ->+ f pD pS+ >> BS8.packCString pS+
+ lib/Data/Deka/Quad.hs view
@@ -0,0 +1,1774 @@+{-# LANGUAGE Trustworthy, DeriveDataTypeable #-}++-- | Floating-point decimals.+--+-- This uses the decNumber C library, so you will want to read the+-- documentation about it to fully understand this module:+--+-- <http://speleotrove.com/decimal/decnumber.html>+--+-- <http://speleotrove.com/decimal/decarith.html>+--+-- <http://speleotrove.com/decimal/>+--+-- Many of the comments on what these functions do are taken+-- directly from the documentation for the decNumber C library.+--+-- In particular, this module implements the decQuad type. decQuad+-- supports up to 34 digits of precision and exponents between -6176+-- and 6111. It doesn't silently round, overflow, or underflow;+-- rather, the library will notify you if these things happen.+--+-- Many functions in this module clash with Prelude names, so you+-- might want to do+--+-- > import qualified Data.Deka.Quad as Q+module Data.Deka.Quad+ (+ -- * Quad+ Quad+ , QuadT(..)++ -- * Rounding+ -- | For more on the rounding algorithms, see+ --+ -- <http://speleotrove.com/decimal/damodel.html>+ , Round+ , roundCeiling+ , roundUp+ , roundHalfUp+ , roundHalfEven+ , roundHalfDown+ , roundDown+ , roundFloor+ , round05Up++ -- * Flags+ --+ -- | For more on possible flags, see+ --+ -- <http://speleotrove.com/decimal/damodel.html>+ , Flag+ , divisionUndefined+ , divisionByZero+ , divisionImpossible+ , invalidOperation+ , inexact+ , underflow+ , overflow+ , conversionSyntax++ , Flags+ , unFlags+ , setFlag+ , clearFlag+ , checkFlag+ , emptyFlags++ -- * Ctx monad+ , Ctx+ , getStatus+ , setStatus+ , mapStatus+ , getRound+ , setRound+ , runCtx+ , evalCtx++ -- * Class+ , DecClass+ , sNan+ , qNan+ , negInf+ , negNormal+ , negSubnormal+ , negZero+ , posZero+ , posSubnormal+ , posNormal+ , posInf+ , decClass++ -- * Converting to and from strings+ , fromByteString+ , toByteString+ , toEngByteString++ -- * Converting to and from integers+ , fromInt32+ , fromUInt32+ , toInt32+ , toInt32Exact+ , toUInt32+ , toUInt32Exact++ -- * Arithmetic+ , add+ , subtract+ , multiply+ , fma+ , divide+ , divideInteger+ , remainder+ , remainderNear++ -- * Exponent and coefficient adjustment+ , quantize+ , reduce++ -- * Comparisons+ , compare+ , compareOrd+ , compareSignal+ , compareTotal+ , compareTotalMag+ , max+ , maxMag+ , min+ , minMag+ , sameQuantum++ -- * Tests+ , isFinite+ , isInfinite+ , isInteger+ , isLogical+ , isNaN+ , isNegative+ , isNormal+ , isPositive+ , isSignaling+ , isSigned+ , isSubnormal+ , isZero++ -- * Signs+ , plus+ , minus+ , abs+ , copySign++ -- * Increment and decrement+ , nextMinus+ , nextPlus+ , nextToward++ -- * Digit-wise+ , and+ , or+ , xor+ , invert+ , shift+ , rotate++ -- * log and scale+ , logB+ , scaleB++ -- * Attributes+ , digits++ -- * Integral rounding++ -- | If you want to round but not to an integral value (e.g. round+ -- to two decimal places), see 'quantize'.+ , toIntegralExact+ , toIntegralValue++ -- * Constants+ , zero+ , one+ , version++ -- * Complete encoding and decoding++ -- | These convert a 'Quad' to a 'Decoded', which is a pure+ -- Haskell type containing all the information in the 'Quad'.++ -- ** Digits+ , Digit(..)+ , digitToInt+ , intToDigit+ , digitToChar+ , digitsToInteger+ , integralToDigits++ -- ** Coefficients+ , coefficientLen+ , payloadLen+ , Coefficient+ , coefficient+ , unCoefficient+ , zeroCoefficient+ , oneCoefficient+ , Payload+ , payload+ , unPayload+ , zeroPayload++ -- ** Exponents+ , Exponent+ , exponent+ , unExponent+ , zeroExponent+ , minMaxExp+ , AdjustedExp+ , adjustedExp+ , unAdjustedExp+ , minNormalAdj+ , minNormalExp+ , adjustedToExponent++ -- ** Sign, NaN, Value, Decoded+ , Sign(..)+ , NaN(..)+ , Value(..)+ , Decoded(..)++ --- ** Conversion functions+ , fromBCD+ , toBCD+ , scientific+ , ordinary+ , decodedToRational++ -- ** Decoded predicates++ -- *** Duplicates of Quad tests that return Bool+ -- | These duplicate the tests that are available for the Quad+ -- type directly.+ , dIsFinite+ , dIsInfinite+ , dIsInteger+ , dIsLogical+ , dIsNaN+ , dIsNegative+ , dIsNormal+ , dIsPositive+ , dIsSignaling+ , dIsSigned+ , dIsSubnormal+ , dIsZero+ , dDigits++ -- *** Duplicates of Quad tests that return 'DecClass'+ , dIsSNaN+ , dIsQNaN+ , dIsNegInf+ , dIsNegNormal+ , dIsNegSubnormal+ , dIsNegZero+ , dIsPosZero+ , dIsPosSubnormal+ , dIsPosNormal+ , dIsPosInf++ ) where++-- # Imports++import Control.Exception+import Control.Monad+import qualified Data.ByteString.Char8 as BS8+import Data.Maybe+import Data.Ratio+import Data.Typeable+import Foreign.Safe hiding+ ( void+ , isSigned+ , rotate+ , shift+ , xor+ )+import Prelude hiding+ ( abs+ , and+ , compare+ , isInfinite+ , isNaN+ , max+ , min+ , or+ , subtract+ , significand+ , exponent+ )+import qualified Prelude+import System.IO.Unsafe (unsafePerformIO)++import Data.Deka.Decnumber+import Data.Deka.Internal++-- # Rounding++newtype Round = Round { unRound :: C'rounding }+ deriving (Eq, Ord)++instance Show Round where+ show (Round r)+ | r == c'DEC_ROUND_CEILING = "roundCeiling"+ | r == c'DEC_ROUND_UP = "roundUp"+ | r == c'DEC_ROUND_HALF_UP = "roundHalfUp"+ | r == c'DEC_ROUND_HALF_EVEN = "roundHalfEven"+ | r == c'DEC_ROUND_HALF_DOWN = "roundHalfDown"+ | r == c'DEC_ROUND_DOWN = "roundDown"+ | r == c'DEC_ROUND_FLOOR = "roundFloor"+ | r == c'DEC_ROUND_05UP = "round05Up"+ | otherwise = error "Deka.Quad.Round.show: unrecognized rounding"++-- | Round toward positive infinity.+roundCeiling :: Round+roundCeiling = Round c'DEC_ROUND_CEILING++-- | Round away from zero.+roundUp :: Round+roundUp = Round c'DEC_ROUND_UP++-- | @0.5@ rounds up+roundHalfUp :: Round+roundHalfUp = Round c'DEC_ROUND_HALF_UP++-- | @0.5@ rounds to nearest even+roundHalfEven :: Round+roundHalfEven = Round c'DEC_ROUND_HALF_EVEN++-- | @0.5@ rounds down+roundHalfDown :: Round+roundHalfDown = Round c'DEC_ROUND_HALF_DOWN++-- | Round toward zero - truncate+roundDown :: Round+roundDown = Round c'DEC_ROUND_DOWN++-- | Round toward negative infinity.+roundFloor :: Round+roundFloor = Round c'DEC_ROUND_FLOOR++-- | Round for reround+round05Up :: Round+round05Up = Round c'DEC_ROUND_05UP++-- # Status++-- | A single error or warning condition that may be set in the+-- 'Ctx'.+newtype Flag = Flag C'uint32_t+ deriving (Eq, Ord)++instance Show Flag where+ show (Flag f)+ | f == c'DEC_Division_undefined = "disivionUndefined"+ | f == c'DEC_Division_by_zero = "divisionByZero"+ | f == c'DEC_Division_impossible = "divisionImpossible"+ | f == c'DEC_Inexact = "inexact"+ | f == c'DEC_Invalid_operation = "invalidOperation"+ | f == c'DEC_Underflow = "underflow"+ | f == c'DEC_Overflow = "overflow"+ | f == c'DEC_Conversion_syntax = "conversionSyntax"+ | otherwise = error "Deka.Quad: show flag: unrecogized flag"++-- Docs are a bit unclear about what status flags can actually be+-- set; the source code reveals that these can be set.++-- | @0/0@ is undefined. It sets this flag and returns a quiet NaN.+divisionUndefined :: Flag+divisionUndefined = Flag c'DEC_Division_undefined++-- | A non-zero dividend is divided by zero. Unlike @0/0@, it has a+-- defined result (a signed Infinity).+divisionByZero :: Flag+divisionByZero = Flag c'DEC_Division_by_zero++-- | Sometimes raised by 'divideInteger' and 'remainder'.+divisionImpossible :: Flag+divisionImpossible = Flag c'DEC_Division_impossible++-- | Raised on a variety of invalid operations, such as an attempt+-- to use 'compareSignal' on an operand that is an NaN.+invalidOperation :: Flag+invalidOperation = Flag c'DEC_Invalid_operation++-- | One or more non-zero coefficient digits were discarded during+-- rounding.+inexact :: Flag+inexact = Flag c'DEC_Inexact++-- | A result is both subnormal and inexact.+underflow :: Flag+underflow = Flag c'DEC_Underflow++-- | The exponent of a result is too large to be represented.+overflow :: Flag+overflow = Flag c'DEC_Overflow++-- | A source string (for instance, in 'fromByteString') contained+-- errors.+conversionSyntax :: Flag+conversionSyntax = Flag c'DEC_Conversion_syntax++-- Invalid Context is not recreated here; it should never happen++-- | A container for multiple 'Flag' indicating which are set and+-- which are not. An instance of 'Exception' so you can throw it if+-- you want (no functions in this module throw.)+newtype Flags = Flags C'uint32_t+ deriving (Eq, Ord, Typeable)++instance Exception Flags++unFlags :: Flags -> [Flag]+unFlags fs = mapMaybe getFlag allFlags+ where+ getFlag fl = if checkFlag fl fs then Just fl else Nothing+ allFlags = [ divisionUndefined, divisionByZero,+ divisionImpossible, invalidOperation, inexact, underflow,+ overflow, conversionSyntax]++-- | Show gives you a comma-separated list of flags that are set, or+-- an empty string if no flags are set.+instance Show Flags where+ show = show . unFlags++setFlag :: Flag -> Flags -> Flags+setFlag (Flag f1) (Flags fA) = Flags (f1 .|. fA)++clearFlag :: Flag -> Flags -> Flags+clearFlag (Flag f1) (Flags fA) = Flags (complement f1 .&. fA)++-- | Is this 'Flag' set?+checkFlag :: Flag -> Flags -> Bool+checkFlag (Flag f1) (Flags fA) = (f1 .&. fA) /= 0++-- | A 'Flags' with no 'Flag' set.+emptyFlags :: Flags+emptyFlags = Flags 0++-- | The current status flags, which indicate results from previous+-- computations.+getStatus :: Ctx Flags+getStatus = Ctx $ \cPtr -> do+ let pSt = p'decContext'status cPtr+ fmap Flags . peek $ pSt++-- | Set the current status to whatever you wish.+setStatus :: Flags -> Ctx ()+setStatus (Flags f) = Ctx $ \cPtr -> do+ let pSt = p'decContext'status cPtr+ poke pSt f++mapStatus :: (Flags -> Flags) -> Ctx ()+mapStatus f = do+ st <- getStatus+ let st' = f st+ setStatus st'++-- | The current rounding method+getRound :: Ctx Round+getRound = Ctx $ \cPtr -> do+ let pR = p'decContext'round cPtr+ fmap Round . peek $ pR++-- | Change the current rounding method+setRound :: Round -> Ctx ()+setRound r = Ctx $ \cPtr -> do+ let pR = p'decContext'round cPtr+ poke pR . unRound $ r++-- | By default, rounding is set to 'roundHalfEven'. No status flags are set+-- initially. Returns the final status flags along with the result+-- of the computation.+runCtx :: Ctx a -> (a, Flags)+runCtx (Ctx k) = unsafePerformIO $ do+ fp <- mallocForeignPtr+ withForeignPtr fp $ \pCtx -> do+ _ <- unsafe'c'decContextDefault pCtx c'DEC_INIT_DECQUAD+ res <- k pCtx+ fl' <- fmap Flags . peek . p'decContext'status $ pCtx+ return (res, fl')++-- | Like 'runCtx' but does not return the final flags.+evalCtx :: Ctx a -> a+evalCtx (Ctx k) = unsafePerformIO $ do+ fp <- mallocForeignPtr+ withForeignPtr fp $ \pCtx -> do+ _ <- unsafe'c'decContextDefault pCtx c'DEC_INIT_DECQUAD+ k pCtx+++-- # Class++-- | Different categories of 'Quad'.+newtype DecClass = DecClass C'decClass+ deriving (Eq, Ord)++-- | Signaling NaN+sNan :: DecClass+sNan = DecClass c'DEC_CLASS_SNAN++-- | Quiet NaN+qNan :: DecClass+qNan = DecClass c'DEC_CLASS_QNAN++-- | Negative infinity+negInf :: DecClass+negInf = DecClass c'DEC_CLASS_NEG_INF++-- | Negative normal number+negNormal :: DecClass+negNormal = DecClass c'DEC_CLASS_NEG_NORMAL++-- | Negative subnormal number+negSubnormal :: DecClass+negSubnormal = DecClass c'DEC_CLASS_NEG_SUBNORMAL++-- | The negative zero+negZero :: DecClass+negZero = DecClass c'DEC_CLASS_NEG_ZERO++-- | The positive zero+posZero :: DecClass+posZero = DecClass c'DEC_CLASS_POS_ZERO++-- | A positive subnormal number+posSubnormal :: DecClass+posSubnormal = DecClass c'DEC_CLASS_POS_SUBNORMAL++-- | A positive normal number+posNormal :: DecClass+posNormal = DecClass c'DEC_CLASS_POS_NORMAL++-- | Positive infinity+posInf :: DecClass+posInf = DecClass c'DEC_CLASS_POS_INF++instance Show DecClass where+ show (DecClass x)+ | x == c'DEC_CLASS_SNAN = "sNaN"+ | x == c'DEC_CLASS_QNAN = "NaN"+ | x == c'DEC_CLASS_NEG_INF = "-Infinity"+ | x == c'DEC_CLASS_NEG_NORMAL = "-Normal"+ | x == c'DEC_CLASS_NEG_SUBNORMAL = "-Subnormal"+ | x == c'DEC_CLASS_NEG_ZERO = "-Zero"+ | x == c'DEC_CLASS_POS_ZERO = "+Zero"+ | x == c'DEC_CLASS_POS_SUBNORMAL = "+Subnormal"+ | x == c'DEC_CLASS_POS_NORMAL = "+Normal"+ | x == c'DEC_CLASS_POS_INF = "+Infinity"+ | otherwise = error "decClass show: invalid value"+++-- | A Quad is not a member of 'Eq' or 'Ord' because the semantics+-- of the 'compare' function do not easily allow for this. However,+-- if you want to compare using a total ordering, you can wrap your+-- 'Quad' in 'QuadT'. For more on what a total ordering is, see+--+-- <http://speleotrove.com/decimal/decifaq4.html>+--+-- and look under @Which is larger? 7.5 or 7.500?@. As this+-- title suggests, when using a total ordering, @7.5@ and @7.500@+-- are not equal.++newtype QuadT = QuadT { unQuadT :: Quad }+ deriving Show++instance Eq QuadT where+ QuadT x == QuadT y = compareTotal x y == EQ++instance Ord QuadT where+ compare (QuadT x) (QuadT y) = compareTotal x y+++-- # Helpers. Do not export these.++-- | Creates a new Quad. Uninitialized, so don't export this+-- function.+newQuad :: IO Quad+newQuad = fmap Quad mallocForeignPtr++type Unary+ = Ptr C'decQuad+ -> Ptr C'decQuad+ -> Ptr C'decContext+ -> IO (Ptr C'decQuad)++unary+ :: Unary+ -> Quad+ -> Ctx Quad+unary f d = Ctx $ \ptrC ->+ newQuad >>= \r ->+ withForeignPtr (unQuad d) $ \ptrX ->+ withForeignPtr (unQuad r) $ \ptrR ->+ f ptrR ptrX ptrC >>+ return r++type Binary+ = Ptr C'decQuad+ -> Ptr C'decQuad+ -> Ptr C'decQuad+ -> Ptr C'decContext+ -> IO (Ptr C'decQuad)++binary+ :: Binary+ -> Quad+ -> Quad+ -> Ctx Quad+binary f x y = Ctx $ \pC ->+ newQuad >>= \r ->+ withForeignPtr (unQuad r) $ \pR ->+ withForeignPtr (unQuad x) $ \pX ->+ withForeignPtr (unQuad y) $ \pY ->+ f pR pX pY pC >>+ return r++type BinaryCtxFree+ = Ptr C'decQuad+ -> Ptr C'decQuad+ -> Ptr C'decQuad+ -> IO (Ptr C'decQuad)++binaryCtxFree+ :: BinaryCtxFree+ -> Quad+ -> Quad+ -> Quad+binaryCtxFree f x y = unsafePerformIO $+ newQuad >>= \r ->+ withForeignPtr (unQuad r) $ \pR ->+ withForeignPtr (unQuad x) $ \pX ->+ withForeignPtr (unQuad y) $ \pY ->+ f pR pX pY >>+ return r++type UnaryGet a+ = Ptr C'decQuad+ -> IO a++unaryGet+ :: UnaryGet a+ -> Quad+ -> a+unaryGet f d = unsafePerformIO $+ withForeignPtr (unQuad d) $ \pD -> f pD++type Ternary+ = Ptr C'decQuad+ -> Ptr C'decQuad+ -> Ptr C'decQuad+ -> Ptr C'decQuad+ -> Ptr C'decContext+ -> IO (Ptr C'decQuad)++ternary+ :: Ternary+ -> Quad+ -> Quad+ -> Quad+ -> Ctx Quad+ternary f x y z = Ctx $ \pC ->+ newQuad >>= \r ->+ withForeignPtr (unQuad r) $ \pR ->+ withForeignPtr (unQuad x) $ \pX ->+ withForeignPtr (unQuad y) $ \pY ->+ withForeignPtr (unQuad z) $ \pZ ->+ f pR pX pY pZ pC+ >> return r++type Boolean+ = Ptr C'decQuad+ -> IO C'uint32_t++boolean+ :: Boolean+ -> Quad+ -> Bool+boolean f d = unsafePerformIO $+ withForeignPtr (unQuad d) $ \pD ->+ f pD >>= \r ->+ return $ case r of+ 1 -> True+ 0 -> False+ _ -> error "boolean: bad return value"++-- MkString and mkString - moved to Internal so that toByteString+-- can use them++type GetRounded a+ = Ptr C'decQuad+ -> Ptr C'decContext+ -> C'rounding+ -> IO a++getRounded+ :: GetRounded a+ -> Round+ -> Quad+ -> Ctx a+getRounded f (Round r) d = Ctx $ \pC ->+ withForeignPtr (unQuad d) $ \pD ->+ f pD pC r++-- # End Helpers++-- # Functions from decQuad. In alphabetical order.++-- | Absolute value. NaNs are handled normally (the sign of an NaN+-- is not affected, and an sNaN sets 'invalidOperation'.+abs :: Quad -> Ctx Quad+abs = unary unsafe'c'decQuadAbs++add :: Quad -> Quad -> Ctx Quad+add = binary unsafe'c'decQuadAdd++-- | Digit-wise logical and. Operands must be:+--+-- * zero or positive+--+-- * integers+--+-- * comprise only zeroes and/or ones+--+-- If not, 'invalidOperation' is set.+and :: Quad -> Quad -> Ctx Quad+and = binary unsafe'c'decQuadAnd++-- | More information about a particular 'Quad'.+decClass :: Quad -> DecClass+decClass = DecClass . unaryGet unsafe'c'decQuadClass++-- | Compares two 'Quad' numerically. The result might be @-1@, @0@,+-- @1@, or NaN, where @-1@ means x is less than y, @0@ indicates+-- numerical equality, @1@ means y is greater than x. NaN is+-- returned only if x or y is an NaN.+--+-- Thus, this function does not return an 'Ordering' because the+-- result might be an NaN.+--+compare :: Quad -> Quad -> Ctx Quad+compare = binary unsafe'c'decQuadCompare++-- | Wrapper for 'compare' that returns an 'Ordering' rather than a+-- 'Quad'. Returns @Just LT@ rather than -1, @Just EQ@ rather than+-- 0, and @Just GT@ rather than 1, and @Nothing@ rather than NaN.+-- This is a pure function; it does not affect the 'Ctx'.++compareOrd :: Quad -> Quad -> Maybe Ordering+compareOrd x y = evalCtx $ do+ c <- compare x y+ let r | isNaN c = Nothing+ | isNegative c = Just LT+ | isZero c = Just EQ+ | isPositive c = Just GT+ | otherwise = error "compareOrd: unknown result"+ return r++-- | Same as 'compare', but a quietNaN is treated like a signaling+-- NaN (sets 'invalidOperation').+compareSignal :: Quad -> Quad -> Ctx Quad+compareSignal = binary unsafe'c'decQuadCompareSignal++-- | Compares using an IEEE 754 total ordering, which takes into+-- account the exponent. IEEE 754 says that this function might+-- return different results depending upon whether the operands are+-- canonical; 'Quad' are always canonical so you don't need to worry+-- about that here.+compareTotal :: Quad -> Quad -> Ordering+compareTotal x y =+ let c = binaryCtxFree unsafe'c'decQuadCompareTotal x y+ r | isNegative c = LT+ | isZero c = EQ+ | isPositive c = GT+ | otherwise = error "compareTotal: unknown result"+ in r++-- | Same as 'compareTotal' but compares the absolute value of the+-- two arguments.+compareTotalMag :: Quad -> Quad -> Ordering+compareTotalMag x y =+ let c = binaryCtxFree unsafe'c'decQuadCompareTotalMag x y+ r | isNegative c = LT+ | isZero c = EQ+ | isPositive c = GT+ | otherwise = error "compareTotalMag: unknown result"+ in r+++-- decNumber's CopySign copies the contents from pS to PN, except+-- that the sign is copied from pP to pN++-- | @copySign x y@ returns @z@, which is a copy of @x@ but has the+-- sign of @y@. This function never raises any signals.+copySign :: Quad -> Quad -> Quad+copySign s p = unsafePerformIO $+ newQuad >>= \n ->+ withForeignPtr (unQuad n) $ \pN ->+ withForeignPtr (unQuad s) $ \pS ->+ withForeignPtr (unQuad p) $ \pP ->+ unsafe'c'decQuadCopySign pN pS pP >>+ return n++-- | Number of significant digits. If zero or infinite, returns 1.+-- If NaN, returns number of digits in the payload.+digits :: Quad -> Int+digits = fromIntegral . unaryGet unsafe'c'decQuadDigits++divide :: Quad -> Quad -> Ctx Quad+divide = binary unsafe'c'decQuadDivide++-- | @divideInteger x y@ returns the integer part of the result+-- (rounded toward zero), with an exponent of 0. If the the result+-- would not fit because it has too many digits,+-- 'divisionImpossible' is set.+divideInteger :: Quad -> Quad -> Ctx Quad+divideInteger = binary unsafe'c'decQuadDivideInteger++-- | Fused multiply add; @fma x y z@ calculates @x * y + z@. The+-- multiply is carried out first and is exact, so the result has+-- only one final rounding.+fma :: Quad -> Quad -> Quad -> Ctx Quad+fma = ternary unsafe'c'decQuadFMA++fromInt32 :: C'int32_t -> Quad+fromInt32 i = unsafePerformIO $+ newQuad >>= \r ->+ withForeignPtr (unQuad r) $ \pR ->+ unsafe'c'decQuadFromInt32 pR i+ >> return r++-- | Reads a ByteString, which can be in scientific, engineering, or+-- \"regular\" decimal notation. Also reads NaN, Infinity, etc.+-- Will return a signaling NaN and set 'invalidOperation' if the+-- string given is invalid.+--+-- In the decNumber C library, this function was called+-- @fromString@; the name was changed here because it doesn't take a+-- regular Haskell 'String'.+fromByteString :: BS8.ByteString -> Ctx Quad+fromByteString s = Ctx $ \pC ->+ newQuad >>= \r ->+ withForeignPtr (unQuad r) $ \pR ->+ BS8.useAsCString s $ \pS ->+ unsafe'c'decQuadFromString pR pS pC >>+ return r++fromUInt32 :: C'uint32_t -> Quad+fromUInt32 i = unsafePerformIO $+ newQuad >>= \r ->+ withForeignPtr (unQuad r) $ \pR ->+ unsafe'c'decQuadFromUInt32 pR i >>+ return r++-- | Digit-wise logical inversion. The operand must be:+--+-- * zero or positive+--+-- * integers+--+-- * comprise only zeroes and/or ones+--+-- If not, 'invalidOperation' is set.+invert :: Quad -> Ctx Quad+invert = unary unsafe'c'decQuadInvert++-- | True if @x@ is neither infinite nor a NaN.+isFinite :: Quad -> Bool+isFinite = boolean unsafe'c'decQuadIsFinite++-- | True for infinities.+isInfinite :: Quad -> Bool+isInfinite = boolean unsafe'c'decQuadIsInfinite++-- | True if @x@ is finite and has exponent of @0@; False otherwise.+-- This tests the exponent, not the /adjusted/ exponent. This can+-- lead to results you may not expect:+--+-- >>> isInteger . evalCtx . fromByteString . pack $ "3.00e2"+-- True+--+-- >>> isInteger . evalCtx . fromByteString . pack $ "3e2"+-- False+--+-- >>> isInteger . evalCtx . fromByteString . pack $ "3.00e0"+-- False+isInteger :: Quad -> Bool+isInteger = boolean unsafe'c'decQuadIsInteger++-- | True only if @x@ is zero or positive, an integer (finite with+-- exponent of 0), and the coefficient is only zeroes and/or ones.+isLogical :: Quad -> Bool+isLogical = boolean unsafe'c'decQuadIsLogical++-- | True for NaNs.+isNaN :: Quad -> Bool+isNaN = boolean unsafe'c'decQuadIsNaN++-- | True only if @x@ is less than zero and is not an NaN.+isNegative :: Quad -> Bool+isNegative = boolean unsafe'c'decQuadIsNegative++-- | True only if @x@ is finite, non-zero, and not subnormal.+isNormal :: Quad -> Bool+isNormal = boolean unsafe'c'decQuadIsNormal++-- | True only if @x@ is greater than zero and is not an NaN.+isPositive :: Quad -> Bool+isPositive = boolean unsafe'c'decQuadIsPositive++-- | True only if @x@ is a signaling NaN.+isSignaling :: Quad -> Bool+isSignaling = boolean unsafe'c'decQuadIsSignaling++-- | True only if @x@ has a sign of 1. Note that zeroes and NaNs+-- may have sign of 1.+isSigned :: Quad -> Bool+isSigned = boolean unsafe'c'decQuadIsSigned++-- | True only if @x@ is subnormal - that is, finite, non-zero, and+-- with a magnitude less than 10 ^ emin.+isSubnormal :: Quad -> Bool+isSubnormal = boolean unsafe'c'decQuadIsSubnormal++-- | True only if @x@ is a zero.+isZero :: Quad -> Bool+isZero = boolean unsafe'c'decQuadIsZero++-- | @logB x@ Returns the adjusted exponent of x, according to IEEE+-- 754 rules. If @x@ is infinite, returns +Infinity. If @x@ is+-- zero, the result is -Infinity, and 'divisionByZero' is set. If+-- @x@ is less than zero, the absolute value of @x@ is used. If @x@+-- is one, the result is 0. NaNs are propagated as for arithmetic+-- operations.+logB :: Quad -> Ctx Quad+logB = unary unsafe'c'decQuadLogB++-- | @max x y@ returns the larger argument; if either (but not both)+-- @x@ or @y@ is a quiet NaN then the other argument is the result;+-- otherwise, NaNs, are handled as for arithmetic operations.+max :: Quad -> Quad -> Ctx Quad+max = binary unsafe'c'decQuadMax++-- | Like 'max' but the absolute values of the arguments are used.+maxMag :: Quad -> Quad -> Ctx Quad+maxMag = binary unsafe'c'decQuadMaxMag++-- | @min x y@ returns the smaller argument; if either (but not both)+-- @x@ or @y@ is a quiet NaN then the other argument is the result;+-- otherwise, NaNs, are handled as for arithmetic operations.+min :: Quad -> Quad -> Ctx Quad+min = binary unsafe'c'decQuadMin++-- | Like 'min' but the absolute values of the arguments are used.+minMag :: Quad -> Quad -> Ctx Quad+minMag = binary unsafe'c'decQuadMinMag++-- | Negation. Result has the same effect as @0 - x@ when the+-- exponent of the zero is the same as that of @x@, if @x@ is+-- finite.+minus :: Quad -> Ctx Quad+minus = unary unsafe'c'decQuadMinus++multiply :: Quad -> Quad -> Ctx Quad+multiply = binary unsafe'c'decQuadMultiply++-- | Decrements toward negative infinity.+nextMinus :: Quad -> Ctx Quad+nextMinus = unary unsafe'c'decQuadNextMinus++-- | Increments toward positive infinity.+nextPlus :: Quad -> Ctx Quad+nextPlus = unary unsafe'c'decQuadNextPlus++-- | @nextToward x y@ returns the next 'Quad' in the direction of+-- @y@.+nextToward :: Quad -> Quad -> Ctx Quad+nextToward = binary unsafe'c'decQuadNextToward++-- | Digit wise logical inclusive Or. Operands must be:+--+-- * zero or positive+--+-- * integers+--+-- * comprise only zeroes and/or ones+--+-- If not, 'invalidOperation' is set.+or :: Quad -> Quad -> Ctx Quad+or = binary unsafe'c'decQuadOr++-- | Same effect as @0 + x@ where the exponent of the zero is the+-- same as that of @x@ if @x@ is finite). NaNs are handled as for+-- arithmetic operations.+plus :: Quad -> Ctx Quad+plus = unary unsafe'c'decQuadPlus++-- | @quantize x y@ returns @z@ which is @x@ set to have the same+-- quantum as @y@; that is, numerically the same value but rounded+-- or padded if necessary to have the same exponent as @y@. Useful+-- for rounding monetary quantities.+quantize :: Quad -> Quad -> Ctx Quad+quantize = binary unsafe'c'decQuadQuantize++-- | Reduces coefficient to its shortest possible form without+-- changing the value of the result by removing all possible+-- trailing zeroes.+reduce :: Quad -> Ctx Quad+reduce = unary unsafe'c'decQuadReduce++-- | Remainder from integer division. If the intermediate integer+-- does not fit within a Quad, 'divisionImpossible' is raised.+remainder :: Quad -> Quad -> Ctx Quad+remainder = binary unsafe'c'decQuadRemainder++-- | Like 'remainder' but the nearest integer is used for for the+-- intermediate result instead of the result from 'divideInteger'.+remainderNear :: Quad -> Quad -> Ctx Quad+remainderNear = binary unsafe'c'decQuadRemainderNear++-- | @rotate x y@ rotates the digits of x to the left (if @y@ is+-- positive) or right (if @y@ is negative) without adjusting the+-- exponent or sign of @x@. @y@ is the number of positions to+-- rotate and must be in the range @negate 'coefficientLen'@ to+-- @'coefficentLen'@.+--+-- NaNs are propagated as usual. No status is set unless @y@ is+-- invalid or an operand is an NaN.+rotate :: Quad -> Quad -> Ctx Quad+rotate = binary unsafe'c'decQuadRotate++-- | True only if both operands have the same exponent or are both+-- NaNs (quiet or signaling) or both infinite.+sameQuantum :: Quad -> Quad -> Bool+sameQuantum x y = unsafePerformIO $+ withForeignPtr (unQuad x) $ \pX ->+ withForeignPtr (unQuad y) $ \pY ->+ unsafe'c'decQuadSameQuantum pX pY >>= \r ->+ return $ case r of+ 1 -> True+ 0 -> False+ _ -> error "sameQuantum: error: invalid result"++-- | @scaleB x y@ calculates @x * 10 ^ y@. @y@ must be an integer+-- (finite with exponent of 0) in the range of plus or minus @2 *+-- 'coefficientLen' + 'coefficientLen')@, typically resulting from+-- 'logB'. Underflow and overflow might occur; NaNs propagate as+-- usual.+scaleB :: Quad -> Quad -> Ctx Quad+scaleB = binary unsafe'c'decQuadScaleB++-- | @shift x y@ shifts digits the digits of x to the left (if @y@+-- is positive) or right (if @y@ is negative) without adjusting the+-- exponent or sign of @x@. Any digits shifted in from the left or+-- right will be 0.+--+-- @y@ is a count of positions to shift; it must be a finite+-- integer in the range @negate 'coefficientLen'@ to+-- 'coefficientLen'. NaNs propagate as usual. If @x@ is infinite+-- the result is an infinity of the same sign. No status is set+-- unless y is invalid or the operand is an NaN.+shift :: Quad -> Quad -> Ctx Quad+shift = binary unsafe'c'decQuadShift++-- omitted: Show++subtract :: Quad -> Quad -> Ctx Quad+subtract = binary unsafe'c'decQuadSubtract++-- | Returns a string in engineering notation.+--+-- In the decNumber C library, this is called @toEngString@; the+-- name is changed here because the function does not return a+-- regular Haskell 'String'.+toEngByteString :: Quad -> BS8.ByteString+toEngByteString = mkString unsafe'c'decQuadToEngString++-- | Uses the rounding method given rather than the one in the+-- 'Ctx'. If the operand is infinite, an NaN, or if the result of+-- rounding is outside the range of a 'C'int32_t', then+-- 'invalidOperation' is set. 'inexact' is not set even if rounding+-- occurred.+toInt32 :: Round -> Quad -> Ctx C'int32_t+toInt32 = getRounded unsafe'c'decQuadToInt32++-- | Like 'toInt32' but if rounding removes non-zero digits then+-- 'inexact' is set.+toInt32Exact :: Round -> Quad -> Ctx C'int32_t+toInt32Exact = getRounded unsafe'c'decQuadToInt32Exact++-- | Rounds to an integral using the rounding mode set in the 'Ctx'.+-- If the operand is infinite, an infinity of the same sign is+-- returned. If the operand is an NaN, the result is the same as+-- for other arithmetic operations. If rounding removes non-zero+-- digits then 'inexact' is set.+toIntegralExact :: Quad -> Ctx Quad+toIntegralExact = unary unsafe'c'decQuadToIntegralExact++-- | @toIntegralValue r x@ returns an integral value of @x@ using+-- the rounding mode @r@ rather than the one specified in the 'Ctx'.+-- If the operand is an NaN, the result is the same as for other+-- arithmetic operations. 'inexact' is not set even if rounding+-- occurred.+toIntegralValue :: Round -> Quad -> Ctx Quad+toIntegralValue (Round rnd) d = Ctx $ \pC ->+ withForeignPtr (unQuad d) $ \pD ->+ newQuad >>= \r ->+ withForeignPtr (unQuad r) $ \pR ->+ unsafe'c'decQuadToIntegralValue pR pD pC rnd >>+ return r++-- toByteString - moved to Internal so that Quad can Show in a+-- non-orphan instance++-- | @toUInt32 r x@ returns the value of @x@, rounded to an integer+-- if necessary using the rounding mode @r@ rather than the one+-- given in the 'Ctx'. If @x@ is infinite, or outside of the range+-- of a 'C'uint32_t', then 'invalidOperation' is set. 'inexact' is+-- not set even if rounding occurs.+--+-- The negative zero converts to 0 and is valid, but negative+-- numbers are not valid.+toUInt32 :: Round -> Quad -> Ctx C'uint32_t+toUInt32 = getRounded unsafe'c'decQuadToUInt32++-- | Same as 'toUInt32' but if rounding removes non-zero digits then+-- 'inexact' is set.+toUInt32Exact :: Round -> Quad -> Ctx C'uint32_t+toUInt32Exact = getRounded unsafe'c'decQuadToUInt32Exact++-- | Identifies the version of the decNumber C library.+version :: BS8.ByteString+version = unsafePerformIO $+ unsafe'c'decQuadVersion >>= BS8.packCString++-- | Digit-wise logical exclusive or. Operands must be:+--+-- * zero or positive+--+-- * integers+--+-- * comprise only zeroes and/or ones+--+-- If not, 'invalidOperation' is set.++xor :: Quad -> Quad -> Ctx Quad+xor = binary unsafe'c'decQuadXor++-- | A Quad whose coefficient, exponent, and sign are all 0.+zero :: Quad+zero = unsafePerformIO $+ newQuad >>= \d ->+ withForeignPtr (unQuad d) $ \pD ->+ unsafe'c'decQuadZero pD >>+ return d++-- | A Quad with coefficient 'D1', exponent 0, and sign 'Sign0'.+one :: Quad+one = fromBCD+ $ Decoded Sign0 (Finite (Coefficient [D1]) (Exponent 0))++-- # Conversions++data Sign+ = Sign0+ -- ^ The number is positive or is zero+ | Sign1+ -- ^ The number is negative or the negative zero+ deriving (Eq, Ord, Show, Enum, Bounded)++data NaN+ = Quiet+ | Signaling+ deriving (Eq, Ord, Show, Enum, Bounded)++-- Decimal Arithmetic Specification version 1.70, page 10, says that+-- the minimum and maximum adjusted exponent is given by+--+-- @-x - (c - 1) + 1@ and @x - (c - 1)@+--+-- where @x@ the upper limit on the absolute value of exponent, and+-- @c@ is the length of the coefficient in decimal digits.+--+-- However, the lower bound of the above formula only accounts for+-- normal numbers. When subnormal numbers are enabled (as they are+-- here), the lower bound on exponents is+--+-- @m - (p - 1)@+--+-- where @m@ is the smallest possible adjusted exponent for normal+-- numbers (called Emin), and p is the working precision.+--+-- Also, the upper bound is different too, becuase decQuad is+-- clamped; see decNumber manual, page 23. This means the maximum+-- exponent is limited to+--+-- @t - (p - 1)@+--+-- where @t@ is the maximum possible adjusted exponent and p is the+-- working precision.+--+-- The function below uses the minimum and maximum accounting for+-- the clamp and the subnormals.++-- | The minimum and maximum possible exponent.+minMaxExp :: (Int, Int)+minMaxExp = (l, h)+ where+ l = c'DECQUAD_Emin - c'DECQUAD_Pmax + 1+ h = c'DECQUAD_Emax - c'DECQUAD_Pmax + 1++-- | The smallest possible adjusted exponent that is still normal.+-- Adjusted exponents smaller than this are subnormal.+minNormalAdj :: AdjustedExp+minNormalAdj = AdjustedExp c'DECQUAD_Emin++-- | Like 'minNormalAdj', but returns the size of the regular exponent+-- rather than the adjusted exponent.+minNormalExp :: Coefficient -> Exponent+minNormalExp c = adjustedToExponent c $ minNormalAdj++-- | The signed integer which indicates the power of ten by which+-- the coefficient is multiplied.+newtype Exponent = Exponent { unExponent :: Int }+ deriving (Eq, Ord, Show)++instance Bounded Exponent where+ minBound = Exponent . fst $ minMaxExp+ maxBound = Exponent . snd $ minMaxExp++instance Enum Exponent where+ toEnum i+ | r < minBound = error e+ | r > maxBound = error e+ | otherwise = r+ where+ r = Exponent i+ e = "Deka.Exponent.toEnum: integer out of range"++ fromEnum (Exponent i) = i++-- | Ensures that the exponent is within the range allowed by+-- 'minMaxExp'.+exponent :: Int -> Maybe Exponent+exponent i+ | i < l = Nothing+ | i > h = Nothing+ | otherwise = Just . Exponent $ i+ where+ (l, h) = minMaxExp++-- | An Exponent whose value is 0.+zeroExponent :: Exponent+zeroExponent = Exponent 0++data Value+ = Finite Coefficient Exponent+ | Infinite+ | NaN NaN Payload+ deriving (Eq, Ord, Show)++-- | A pure Haskell type which holds information identical to that+-- in a 'Quad'.+data Decoded = Decoded+ { dSign :: Sign+ , dValue :: Value+ } deriving (Eq, Ord, Show)+++-- | Decodes a 'Quad' to a pure Haskell type which holds identical+-- information.+toBCD :: Quad -> Decoded+toBCD d = unsafePerformIO $+ withForeignPtr (unQuad d) $ \pD ->+ allocaBytes c'DECQUAD_Pmax $ \pArr ->+ alloca $ \pExp ->+ unsafe'c'decQuadToBCD pD pExp pArr >>= \sgn ->+ peek pExp >>= \ex ->+ peekArray c'DECQUAD_Pmax pArr >>= \coef ->+ return (getDecoded sgn ex coef)++-- | Encodes a new 'Quad'.+fromBCD :: Decoded -> Quad+fromBCD dcd = unsafePerformIO $+ newQuad >>= \d ->+ withForeignPtr (unQuad d) $ \pD ->+ let (expn, digs, sgn) = toDecNumberBCD dcd in+ withArray digs $ \pArr ->+ unsafe'c'decQuadFromBCD pD expn pArr sgn >>+ return d+++-- ## Decoding and encoding helpers++toDecNumberBCD :: Decoded -> (C'int32_t, [C'uint8_t], C'int32_t)+toDecNumberBCD (Decoded s v) = (e, ds, sgn)+ where+ sgn = case s of { Sign0 -> 0; Sign1 -> c'DECFLOAT_Sign }+ (e, ds) = case v of+ Infinite -> (c'DECFLOAT_Inf, replicate c'DECQUAD_Pmax 0)+ NaN n (Payload ps) -> (ns, np)+ where+ ns = case n of+ Quiet -> c'DECFLOAT_qNaN+ Signaling -> c'DECFLOAT_sNaN+ np = pad ++ map digitToInt ps+ pad = replicate (c'DECQUAD_Pmax - length ps) 0+ Finite (Coefficient digs) (Exponent ex) ->+ ( fromIntegral ex, pad ++ map digitToInt digs )+ where+ pad = replicate (c'DECQUAD_Pmax - length digs) 0++getDecoded+ :: C'int32_t+ -- ^ Sign. Zero if sign is zero; non-zero if sign is not zero+ -- (that is, is negavite.)+ -> C'int32_t+ -- ^ Exponent+ -> [C'uint8_t]+ -- ^ Coefficient+ -> Decoded+getDecoded sgn ex coef = Decoded s v+ where+ s = if sgn == 0 then Sign0 else Sign1+ v | ex == c'DECFLOAT_qNaN = NaN Quiet pld+ | ex == c'DECFLOAT_sNaN = NaN Signaling pld+ | ex == c'DECFLOAT_Inf = Infinite+ | otherwise = Finite coe (Exponent $ fromIntegral ex)+ where+ pld = Payload . toDigs . tail $ coef+ coe = Coefficient . toDigs $ coef+ toDigs c = case dropWhile (== D0) . map intToDigit $ c of+ [] -> [D0]+ xs -> xs++-- ## Decoded to scientific and ordinary notation++-- | Converts a Decoded to scientific notation. Unlike+-- 'toByteString' this will always use scientific notation. For+-- NaNs and infinities, the notation is identical to that of+-- decNumber (see Decimal Arithmetic Specification page 19). This+-- means that a quiet NaN is @NaN@ while a signaling NaN is @sNaN@,+-- and infinity is @Infinity@.+--+-- Like decQuadToString, the payload of an NaN is not shown if it is+-- zero.++scientific :: Decoded -> String+scientific d = sign ++ rest+ where+ sign = case dSign d of+ Sign0 -> ""+ Sign1 -> "-"+ rest = case dValue d of+ Infinite -> "Infinity"+ Finite c e -> sciFinite c e+ NaN n p -> sciNaN n p++sciFinite :: Coefficient -> Exponent -> String+sciFinite c e = sCoe ++ 'E':sExp+ where+ sCoe = case unCoefficient c of+ x:xs -> digitToChar x : case xs of+ [] -> []+ _ -> '.' : map digitToChar xs+ [] -> error "sciFinite: empty coefficient"+ sExp = show . unAdjustedExp . adjustedExp c $ e++sciNaN :: NaN -> Payload -> String+sciNaN n p = nStr ++ pStr+ where+ nStr = case n of { Quiet -> "NaN"; Signaling -> "sNaN" }+ pStr = case unPayload p of+ [D0] -> ""+ xs -> map digitToChar xs++-- | Converts Decoded to ordinary decimal notation. For NaNs and+-- infinities, the notation is identical to that of 'scientific'.+-- Unlike 'scientific', though the result can always be converted back+-- to a 'Quad' using 'fromByteString', the number of significant+-- digits might change. For example, though @1.2E3@ has two+-- significant digits, using @ordinary@ on this value and then+-- reading it back in with @fromByteString@ will give you @1200E0@,+-- which has four significant digits.++ordinary :: Decoded -> String+ordinary d = sign ++ rest+ where+ sign = case dSign d of+ Sign0 -> ""+ Sign1 -> "-"+ rest = case dValue d of+ Infinite -> "Infinity"+ Finite c e -> onyFinite c e+ NaN n p -> sciNaN n p++onyFinite :: Coefficient -> Exponent -> String+onyFinite c e+ | coe == [D0] = "0"+ | ex >= 0 = map digitToChar coe ++ replicate ex '0'+ | aex < lCoe =+ let (lft, rt) = splitAt (lCoe - aex) coe+ in map digitToChar lft ++ "." ++ map digitToChar rt+ | otherwise =+ let numZeroes = aex - lCoe+ in "0." ++ replicate numZeroes '0' ++ map digitToChar coe+ where+ ex = unExponent e+ coe = unCoefficient c+ aex = Prelude.abs ex+ lCoe = length coe++-- | Converts a Decoded to a Rational. Returns Nothing if the+-- Decoded is not finite.+decodedToRational :: Decoded -> Maybe Rational+decodedToRational d = case dValue d of+ (Finite c e) ->+ let int = digitsToInteger . unCoefficient $ c+ ex = unExponent e+ mkSgn = if dSign d == Sign0 then id else negate+ mult = if ex < 0 then 1 % (10 ^ Prelude.abs ex) else 10 ^ ex+ in Just . mkSgn $ fromIntegral int * mult+ _ -> Nothing++-- ## Digits++-- | A single decimal digit.+data Digit = D0 | D1 | D2 | D3 | D4 | D5 | D6 | D7 | D8 | D9+ deriving (Eq, Ord, Show, Enum, Bounded)++digitToInt :: Integral a => Digit -> a+digitToInt d = case d of+ { D0 -> 0; D1 -> 1; D2 -> 2; D3 -> 3; D4 -> 4; D5 -> 5;+ D6 -> 6; D7 -> 7; D8 -> 8; D9 -> 9 }++intToDigit :: Integral a => a -> Digit+intToDigit i = case i of+ { 0 -> D0; 1 -> D1; 2 -> D2; 3 -> D3; 4 -> D4;+ 5 -> D5; 6 -> D6; 7 -> D7; 8 -> D8; 9 -> D9;+ _ -> error "intToDigit: integer out of range" }++digitToChar :: Digit -> Char+digitToChar d = case d of+ { D0 -> '0'; D1 -> '1'; D2 -> '2'; D3 -> '3'; D4 -> '4';+ D5 -> '5'; D6 -> '6'; D7 -> '7'; D8 -> '8'; D9 -> '9' }+++-- | A list of digits, less than or equal to 'coefficientLen' long.+-- Corresponds only to finite numbers.+newtype Coefficient = Coefficient { unCoefficient :: [Digit] }+ deriving (Eq, Ord, Show)++instance Bounded Coefficient where+ minBound = Coefficient [D0]+ maxBound = Coefficient $ replicate coefficientLen D9++instance Enum Coefficient where+ toEnum i+ | i < 0 = error $ "Deka.Quad.Coefficient.toEnum: argument "+ ++ "out of range; is negative"+ | length r > coefficientLen = error $ "Deka.Quad.Coefficient."+ ++ "toEnum: argument too large"+ | otherwise = Coefficient r+ where+ r = integralToDigits i++ fromEnum i+ | r > (fromIntegral (maxBound :: Int)) =+ error $ "Deka.Quad.Coefficient.fromEnum:"+ ++ " argument too large to fit into Int"+ | otherwise = fromIntegral r+ where+ r = digitsToInteger . unCoefficient $ i++-- | Creates a 'Coefficient'. Checks to ensure it is not null and+-- that it is not longer than 'coefficientLen' and that it does not+-- have leading zeroes (if it is 0, a single 'D0' is allowed).+coefficient :: [Digit] -> Maybe Coefficient+coefficient ls+ | null ls = Nothing+ | length ls > 1 && head ls == D0 = Nothing+ | length ls > coefficientLen = Nothing+ | otherwise = Just . Coefficient $ ls++-- | Coefficient of 'D0'+zeroCoefficient :: Coefficient+zeroCoefficient = Coefficient [D0]++-- | Coefficient of 'D1'+oneCoefficient :: Coefficient+oneCoefficient = Coefficient [D1]++-- | A list of digits, less than or equal to 'payloadLen'+-- long. Accompanies an NaN, potentially with diagnostic+-- information (I do not know if decNumber actually makes use of+-- this.)+newtype Payload = Payload { unPayload :: [Digit] }+ deriving (Eq, Ord, Show)++instance Bounded Payload where+ minBound = Payload [D0]+ maxBound = Payload $ replicate payloadLen D9++instance Enum Payload where+ toEnum i+ | i < 0 = error $ "Deka.Quad.Payload.toEnum: argument "+ ++ "out of range; is negative"+ | length r > payloadLen = error $ "Deka.Quad.Payload."+ ++ "toEnum: argument too large"+ | otherwise = Payload r+ where+ r = integralToDigits i++ fromEnum i+ | r > (fromIntegral (maxBound :: Int)) =+ error $ "Deka.Quad.Payload.fromEnum:"+ ++ " argument too large to fit into Int"+ | otherwise = fromIntegral r+ where+ r = digitsToInteger . unPayload $ i++-- | Creates a 'Payload'. Checks to ensure it is not null, not+-- longer than 'payloadLen' and that it does not have leading zeroes+-- (if it is 0, a single 'D0' is allowed).+payload :: [Digit] -> Maybe Payload+payload ds+ | null ds = Nothing+ | length ds > 1 && head ds == D0 = Nothing+ | length ds > payloadLen = Nothing+ | otherwise = Just . Payload $ ds++-- | Payload of [D0]+zeroPayload :: Payload+zeroPayload = Payload [D0]+++-- | The most significant digit is at the head of the list.+digitsToInteger :: [Digit] -> Integer+digitsToInteger ls = go (length ls - 1) 0 ls+ where+ go c t ds = case ds of+ [] -> t+ x:xs -> let m = digitToInt x * 10 ^ c+ t' = m + t+ c' = c - 1+ _types = c :: Int+ in go c' t' xs++-- | The most significant digit is at+-- the head of the list. Sign of number is not relevant.+integralToDigits :: Integral a => a -> [Digit]+integralToDigits = reverse . go . Prelude.abs+ where+ go i+ | i == 0 = []+ | otherwise =+ let (d, m) = i `divMod` 10+ in intToDigit m : go d++-- | Maximum number of digits in a coefficient.+coefficientLen :: Int+coefficientLen = c'DECQUAD_Pmax++-- | Maximum number of digits in a payload.+payloadLen :: Int+payloadLen = c'DECQUAD_Pmax - 1++-- # Decoded predicates++dIsFinite :: Decoded -> Bool+dIsFinite (Decoded _ v) = case v of+ Finite _ _ -> True+ _ -> False++dIsInfinite :: Decoded -> Bool+dIsInfinite (Decoded _ v) = case v of+ Infinite -> True+ _ -> False++dIsInteger :: Decoded -> Bool+dIsInteger (Decoded _ v) = case v of+ Finite _ e -> unExponent e == 0+ _ -> False++-- | True only if @x@ is zero or positive, an integer (finite with+-- exponent of 0), and the coefficient is only zeroes and/or ones.+-- The sign must be Sign0 (that is, you cannot have a negative+-- zero.)+dIsLogical :: Decoded -> Bool+dIsLogical (Decoded s v) = fromMaybe False $ do+ guard $ s == Sign0+ (d, e) <- case v of+ Finite ds ex -> return (ds, ex)+ _ -> Nothing+ guard $ e == zeroExponent+ return+ . all (\x -> x == D0 || x == D1)+ . unCoefficient $ d++dIsNaN :: Decoded -> Bool+dIsNaN (Decoded _ v) = case v of+ NaN _ _ -> True+ _ -> False++-- | True only if @x@ is less than zero and is not an NaN. It's not+-- enough for the sign to be Sign1; the coefficient (if finite) must+-- be greater than zero.+dIsNegative :: Decoded -> Bool+dIsNegative (Decoded s v) = fromMaybe False $ do+ guard $ s == Sign1+ return $ case v of+ Finite d _ -> any (/= D0) . unCoefficient $ d+ Infinite -> True+ _ -> False++dIsNormal :: Decoded -> Bool+dIsNormal (Decoded _ v) = case v of+ Finite d e+ | adjustedExp d e < minNormalAdj -> False+ | otherwise -> any (/= D0) . unCoefficient $ d+ _ -> False++dIsPositive :: Decoded -> Bool+dIsPositive (Decoded s v)+ | s == Sign1 = False+ | otherwise = case v of+ Finite d _ -> any (/= D0) . unCoefficient $ d+ Infinite -> True+ _ -> False++dIsSignaling :: Decoded -> Bool+dIsSignaling (Decoded _ v) = case v of+ NaN Signaling _ -> True+ _ -> False+++dIsSigned :: Decoded -> Bool+dIsSigned (Decoded s _) = s == Sign1++dIsSubnormal :: Decoded -> Bool+dIsSubnormal (Decoded _ v) = case v of+ Finite d e -> adjustedExp d e < minNormalAdj+ _ -> False++-- | True for any zero (negative or positive zero).+dIsZero :: Decoded -> Bool+dIsZero (Decoded _ v) = case v of+ Finite d _ -> all (== D0) . unCoefficient $ d+ _ -> False++-- | The number of significant digits. Zero returns 1.+dDigits :: Coefficient -> Int+dDigits (Coefficient ds) = case dropWhile (== D0) ds of+ [] -> 1+ rs -> length rs++-- | An adjusted exponent is the value of an exponent of a number+-- when that number is expressed as though in scientific notation+-- with one digit before any decimal point. This is the finite+-- exponent + (number of significant digits - 1).+newtype AdjustedExp = AdjustedExp { unAdjustedExp :: Int }+ deriving (Eq, Show, Ord)++instance Bounded AdjustedExp where+ minBound = AdjustedExp $ fst minMaxExp+ maxBound = AdjustedExp $ snd minMaxExp + coefficientLen - 1++instance Enum AdjustedExp where+ toEnum i+ | r < minBound = error e+ | r > maxBound = error e+ | otherwise = r+ where+ r = AdjustedExp i+ e = "Deka.AdjustedExp.toEnum: integer out of range"++ fromEnum (AdjustedExp i) = i++adjustedExp :: Coefficient -> Exponent -> AdjustedExp+adjustedExp ds e = AdjustedExp $ unExponent e+ + dDigits ds - 1++adjustedToExponent :: Coefficient -> AdjustedExp -> Exponent+adjustedToExponent ds e = Exponent $ unAdjustedExp e -+ dDigits ds + 1++-- # DecClass-like Decoded predicates++dIsSNaN :: Decoded -> Bool+dIsSNaN d = case dValue d of+ NaN n _ -> n == Signaling+ _ -> False++dIsQNaN :: Decoded -> Bool+dIsQNaN d = case dValue d of+ NaN n _ -> n == Quiet+ _ -> False++dIsNegInf :: Decoded -> Bool+dIsNegInf d+ | dSign d == Sign0 = False+ | otherwise = dValue d == Infinite++dIsNegNormal :: Decoded -> Bool+dIsNegNormal d+ | dSign d == Sign0 = False+ | otherwise = case dValue d of+ Finite c e -> e >= minNormalExp c+ _ -> False++dIsNegSubnormal :: Decoded -> Bool+dIsNegSubnormal d+ | dSign d == Sign0 = False+ | otherwise = case dValue d of+ Finite c e -> e < minNormalExp c+ _ -> False++dIsNegZero :: Decoded -> Bool+dIsNegZero d+ | dSign d == Sign0 = False+ | otherwise = case dValue d of+ Finite c _ -> unCoefficient c == [D0]+ _ -> False++dIsPosZero :: Decoded -> Bool+dIsPosZero d+ | dSign d == Sign1 = False+ | otherwise = case dValue d of+ Finite c _ -> unCoefficient c == [D0]+ _ -> False++dIsPosSubnormal :: Decoded -> Bool+dIsPosSubnormal d+ | dSign d == Sign1 = False+ | otherwise = case dValue d of+ Finite c e -> e < minNormalExp c+ _ -> False++dIsPosNormal :: Decoded -> Bool+dIsPosNormal d+ | dSign d == Sign1 = False+ | otherwise = case dValue d of+ Finite c e -> e >= minNormalExp c+ _ -> False++dIsPosInf :: Decoded -> Bool+dIsPosInf d+ | dSign d == Sign1 = False+ | otherwise = dValue d == Infinite+++-- # decQuad functions not recreated here:++-- skipped: classString - not needed+-- skipped: copy - not needed+-- skipped: copyAbs - use abs instead+-- skipped: copyNegate - use negate instead+-- skipped: fromNumber - not needed+-- skipped: fromPacked - use fromPackedChecked instead+-- skipped: fromWider - not needed+-- skipped: getExponent, setExponent - use toBCD, fromBCD+-- skipped: getCoefficient, setCoefficient - use toBCD, fromBCD+-- skipped: isCanonical - not needed+-- skipped: radix - not needed+-- skipped: toNumber - not needed+-- skipped: toPacked - use decode function instead+-- skipped: toWider - not needed+-- skipped: show - not needed; impure
+ test/DataDir.hs view
@@ -0,0 +1,12 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module DataDir where++import Test.Tasty+import qualified DataDir.DekaDir+import qualified DataDir.DekaTest++tests = testGroup "DataDir"+ [ DataDir.DekaDir.tests+ , DataDir.DekaTest.tests+ ]
+ test/DataDir/DekaDir.hs view
@@ -0,0 +1,10 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module DataDir.DekaDir where++import Test.Tasty+import qualified DataDir.DekaDir.QuadTest++tests = testGroup "DekaDir"+ [ DataDir.DekaDir.QuadTest.tests+ ]
+ test/DataDir/DekaDir/QuadTest.hs view
@@ -0,0 +1,1422 @@+-- | Tests for the Quad module.+--+-- The object of these tests is not to test decNumber but, rather,+-- to test Deka to ensure there are no transposed arguments or other+-- glaring errors. Also, ensures that the FFI binding behaves as it+-- should and that there are no side effects where there shouldn't+-- be any.+--+-- Every function that takes a Quad as an argument is tested to+-- ensure it does not modify that Quad.+--+-- encoding and decoding must also be thoroughly tested as this can+-- be quite error prone.+module DataDir.DekaDir.QuadTest where++import Control.Applicative+import Control.Exception (evaluate)+import qualified Data.ByteString.Char8 as BS8+import Control.Monad+import Test.Tasty+import qualified Data.Deka.Quad as E+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck hiding (maxSize)+import Test.QuickCheck.Monadic+import Data.Deka.Internal+import Data.Deka.Decnumber+import Data.Maybe+import Foreign++isLeft :: Either a b -> Bool+isLeft e = case e of { Left _ -> True; _ -> False }++isRight :: Either a b -> Bool+isRight e = case e of { Right _ -> True; _ -> False }++lenCoeff :: E.Decoded -> Maybe Int+lenCoeff dcd = fmap length . fmap E.unCoefficient+ $ case E.dValue dcd of+ E.Finite c _ -> Just c+ _ -> Nothing++-- | Maximum Integer for testing purposes.+maxInteger :: Integer+maxInteger = 10 ^ (100 :: Int)++-- | Minimum Integer for testing purposes.+minInteger :: Integer+minInteger = negate (10 ^ (100 :: Int))++-- | The largest number with the given number of digits.+biggestDigs :: Int -> Integer+biggestDigs i = 10 ^ i - 1++-- | The smallest positive number with the given number of digits.+smallestDigs :: Int -> Integer+smallestDigs i = 10 ^ (i - 1)++maxSize :: Int -> Gen a -> Gen a+maxSize s g = sized $ \o -> resize (min o s) g++numDigits :: (Num a, Show a) => a -> Int+numDigits = length . show . abs++increaseAbs :: E.Quad -> E.Ctx E.Quad+increaseAbs q = do+ let neg = E.isNegative q+ if neg+ then E.nextMinus q+ else E.nextPlus q++decreaseAbs :: E.Quad -> E.Ctx E.Quad+decreaseAbs q = do+ let neg = E.isNegative q+ if neg+ then E.nextPlus q+ else E.nextMinus q++-- # Generators++genSign :: Gen E.Sign+genSign = elements [ minBound..maxBound ]++genBinaryMSD :: Gen E.Digit+genBinaryMSD = return E.D1++genBinaryNonMSD :: Gen E.Digit+genBinaryNonMSD = elements [E.D0, E.D1]++binaryDigs :: (Gen E.Digit, Gen E.Digit)+binaryDigs = (genBinaryMSD, genBinaryNonMSD)++genDecimalMSD :: Gen E.Digit+genDecimalMSD = elements [ E.D1, E.D2, E.D3, E.D4, E.D5,+ E.D6, E.D7, E.D8, E.D9 ]++genDecimalNonMSD :: Gen E.Digit+genDecimalNonMSD = elements+ [ E.D0, E.D1, E.D2, E.D3, E.D4, E.D5,+ E.D6, E.D7, E.D8, E.D9 ]++decimalDigs :: (Gen E.Digit, Gen E.Digit)+decimalDigs = (genDecimalMSD, genDecimalNonMSD)++-- | Given a length, generate a list of digits. All lists generated+-- will be exactly the length given.+genDigits+ :: Int+ -- ^ Length+ -> (Gen E.Digit, Gen E.Digit)+ -- ^ Generate MSD, remaining digits+ -> Gen [E.Digit]+genDigits l (gm, gr) = do+ msd <- gm+ rs <- vectorOf (l - 1) gr+ return $ msd : rs++-- | Given a maximum length, generate lists of digits that are no+-- longer than the length given. The list will be of a random+-- length, but it will be no longer than the larger of the size+-- parameter and the given maximum length. The list will always be+-- at least one element long regardless of the maximum length passed+-- in.+sizedDigits+ :: Int+ -- ^ Maximum length. (Size parameter determines the maximum+ -- length, but it will not exceed this amount.)+ -> (Gen E.Digit, Gen E.Digit)+ -- ^ Generate MSD, remaining digits+ -> Gen [E.Digit]+sizedDigits m (gm, gr) = sized $ \s -> do+ let sz = max 1 s+ maxLen = min sz m+ len <- choose (1, maxLen)+ genDigits len (gm, gr)++-- ## Finite number generators++coeffDigits :: (Gen E.Digit, Gen E.Digit) -> Gen [E.Digit]+coeffDigits p = sized f+ where+ f x | x == 0 = oneof [ sizedDigits 0 p, return [E.D0] ]+ | otherwise = sizedDigits E.coefficientLen p++genFiniteDcd+ :: Gen E.Sign+ -> Gen [E.Digit]+ -- ^ Generate coefficient+ -> (E.Coefficient -> Gen Int)+ -- ^ Generate exponent+ -> Gen E.Decoded+genFiniteDcd gs gc ge = do+ s <- gs+ ds <- gc+ let coe = case E.coefficient ds of+ Nothing -> error "genFinite: coefficient failed"+ Just r -> r+ e <- ge coe+ let ex = case E.exponent e of+ Nothing -> error "genFiniteDcd: exponent failed"+ Just r -> r+ return $ E.Decoded s (E.Finite coe ex)++rangedExponent+ :: (Int, Int)+ -- ^ Minimum and maximum exponent. Exponent will never exceed+ -- allowable values.+ -> Gen Int+rangedExponent (em, ex) = do+ let (mPE, xPE) = E.minMaxExp+ (mR, xR) = (max em mPE, min ex xPE)+ choose (mR, xR)++sizedExponent :: Gen Int+sizedExponent = sized $ \s ->+ let x = s ^ (2 :: Int)+ in rangedExponent (negate x, x)++fullExpRange :: Gen Int+fullExpRange = rangedExponent E.minMaxExp++-- ## Infinite number generators++genInfinite :: Gen E.Sign -> Gen E.Decoded+genInfinite gs = do+ s <- gs+ return $ E.Decoded s E.Infinite++-- ## NaN number generators++payloadDigits :: (Gen E.Digit, Gen E.Digit) -> Gen [E.Digit]+payloadDigits = sizedDigits E.payloadLen++genNaN :: Gen E.NaN+genNaN = elements [ E.Quiet, E.Signaling ]++genNaNDcd+ :: Gen E.Sign+ -> Gen E.NaN+ -> Gen [E.Digit]+ -- ^ Generate payload+ -> Gen E.Decoded+genNaNDcd gs gn gd = do+ s <- gs+ ds <- gd+ n <- gn+ let pay = case E.payload ds of+ Nothing -> error "genNaNDcd: payload failed"+ Just r -> r+ return $ E.Decoded s (E.NaN n pay)++-- ## Decoded generators++-- | Most general Decoded generator. Generates throughout the+-- possible range of Decoded. Depends on the size parameter.+genDecoded :: Gen E.Decoded+genDecoded = frequency [(4, genFinite), (1, inf), (1, nan)]+ where+ inf = genInfinite genSign+ nan = genNaNDcd genSign genNaN (payloadDigits decimalDigs)++-- | Generates finite decoded numbers.+genFinite :: Gen E.Decoded+genFinite = genFiniteDcd genSign (coeffDigits decimalDigs)+ (const sizedExponent)+ ++-- ## Specialized finite generators++-- | Generates positive and negative zeroes.+genZero :: Gen E.Decoded+genZero = genFiniteDcd genSign (return [E.D0]) (const fullExpRange)++genNegZero :: Gen E.Decoded+genNegZero = genFiniteDcd (return E.Sign1) (return [E.D0])+ (const fullExpRange)++genPosZero :: Gen E.Decoded+genPosZero = genFiniteDcd (return E.Sign0) (return [E.D0])+ (const fullExpRange)++-- | Generates positive one.+genOne :: Gen E.Decoded+genOne = genFiniteDcd (return E.Sign0) gDigs gExp+ where+ gDigs = sizedDigits E.coefficientLen (return E.D1, return E.D0)+ gExp co = return . negate $ length (E.unCoefficient co) - 1++genSmallFinite :: Gen E.Decoded+genSmallFinite = maxSize 5 genFinite++-- | Generates two values that are equivalent, but with+-- different exponents.++genEquivalent :: Gen (E.Decoded, E.Decoded)+genEquivalent = do+ let genCoeff1 = sizedDigits (E.coefficientLen - 1) decimalDigs+ genExp1 c =+ let (l, h) = E.minMaxExp+ l' = l + (E.coefficientLen - (length . E.unCoefficient $ c))+ in choose (l', h)+ d1 <- genFiniteDcd genSign genCoeff1 genExp1+ let (c1, e1) = case E.dValue d1 of+ E.Finite c e -> (E.unCoefficient c, E.unExponent e)+ _ -> error "genEquivalent failed"+ maxMore = E.coefficientLen - length c1+ more <- choose (1, maxMore)+ let coeff2 = case E.coefficient (c1 ++ replicate more E.D0) of+ Nothing -> error "genEquivalent: coefficient failed"+ Just r -> r+ exp2 = case E.exponent (e1 - more) of+ Nothing -> error "genEquivalent: exponent failed"+ Just r -> r+ d2 = E.Decoded (E.dSign d1) (E.Finite coeff2 exp2)+ b <- arbitrary+ let r = if b then (d1, d2) else (d2, d1)+ return r++++genNonZeroSmallFinite :: Gen E.Decoded+genNonZeroSmallFinite = maxSize 5 $ genFiniteDcd genSign+ gd ge+ where+ gd = sizedDigits E.coefficientLen decimalDigs+ ge = (const sizedExponent)++genInteger :: Gen E.Decoded+genInteger = genFiniteDcd genSign+ (coeffDigits decimalDigs) (const . return $ 0)++genLogical :: Gen E.Decoded+genLogical = genFiniteDcd (return E.Sign0)+ (coeffDigits binaryDigs) (const . return $ 0)++genNormal :: Gen E.Sign -> Gen [E.Digit] -> Gen E.Decoded+genNormal gs gc = genFiniteDcd gs gc ge+ where+ ge c = do+ let minNrml = E.unExponent $ E.minNormalExp c+ maxE = snd E.minMaxExp+ choose (minNrml, maxE)++genSubnormal :: Gen E.Sign -> Gen [E.Digit] -> Gen E.Decoded+genSubnormal gs gd = genFiniteDcd gs gd ge+ where+ ge c =+ let minNrml = E.unExponent . E.minNormalExp $ c+ minE = fst E.minMaxExp+ f | minE > minNrml - 1 = error "genSubnormal failed"+ | otherwise = choose (minE, minNrml - 1)+ in f++genPositive :: Gen E.Decoded+genPositive = genFiniteDcd (return E.Sign0) gd ge+ where+ gd = sizedDigits E.coefficientLen decimalDigs+ ge = (const sizedExponent)++genNegative :: Gen E.Decoded+genNegative = genFiniteDcd (return E.Sign1) gd ge+ where+ gd = sizedDigits E.coefficientLen decimalDigs+ ge = (const sizedExponent)++-- ## Specialized other generators++genSignaling :: Gen E.Decoded+genSignaling = genNaNDcd genSign (return E.Signaling)+ (payloadDigits decimalDigs)++genSigned :: Gen E.Decoded+genSigned = oneof+ [ genFiniteDcd (return E.Sign1) (coeffDigits decimalDigs) (const sizedExponent)+ , genNaNDcd (return E.Sign1) genNaN (payloadDigits decimalDigs)+ , genInfinite (return E.Sign1)+ ]++-- ## Other generators++genRound :: Gen E.Round+genRound = elements [ E.roundCeiling, E.roundUp, E.roundHalfUp,+ E.roundHalfEven, E.roundHalfDown, E.roundDown, E.roundFloor,+ E.round05Up ]++allFlags :: [E.Flag]+allFlags = [ E.divisionUndefined, E.divisionByZero,+ E.divisionImpossible, E.invalidOperation, E.inexact,+ E.underflow, E.overflow, E.conversionSyntax ]++genFlag :: Gen E.Flag+genFlag = elements allFlags++onePointFive :: E.Quad+onePointFive = E.evalCtx . E.fromByteString . BS8.pack $ "1.5"++-- # Test builders++associativity+ :: String+ -- ^ Name+ -> (E.Quad -> E.Quad -> E.Ctx E.Quad)+ -> TestTree+associativity n f = testProperty desc $+ forAll genSmallFinite $ \ dx ->+ forAll genSmallFinite $ \ dy ->+ forAll genSmallFinite $ \ dz ->+ let (noFlags, resIsZero) = E.evalCtx $ do+ let x = E.fromBCD dx+ y = E.fromBCD dy+ z = E.fromBCD dz+ r1 <- f x y >>= f z+ r2 <- f y z >>= f x+ let c = E.evalCtx $ E.compare r1 r2+ isZ = E.isZero c+ fl <- E.getStatus+ return (fl == E.emptyFlags, isZ)+ in noFlags ==> resIsZero+ where+ desc = n ++ " is associative on finite numbers"++commutativity+ :: String+ -- ^ Name+ -> (E.Quad -> E.Quad -> E.Ctx E.Quad)+ -> TestTree+commutativity n f = testProperty desc $+ forAll genSmallFinite $ \dx ->+ forAll genSmallFinite $ \dy ->+ let (noFlags, resIsZero) = E.evalCtx $ do+ let x = E.fromBCD dx+ y = E.fromBCD dy+ r1 <- f x y+ r2 <- f y x+ let isZ = E.compareTotal r1 r2 == EQ+ fl <- E.getStatus+ return (fl == E.emptyFlags, isZ)+ in noFlags ==> resIsZero+ where+ desc = n ++ " is commutative where there are no flags"++-- # Immutability test builders+++inContext :: (Ptr C'decContext -> IO Bool) -> PropertyM IO Bool+inContext f =+ run $ alloca $ \pCtx -> do+ _ <- unsafe'c'decContextDefault pCtx c'DEC_INIT_DECQUAD+ f pCtx++{- Also for below, consider this code snippet:++module Main where++import Control.Exception (evaluate)+import System.IO.Unsafe (unsafePerformIO)++myThing :: String -> Int+myThing s = unsafePerformIO $ putStrLn s >> return 2++main :: IO ()+main = do+ x <- return . Just $ myThing "this will NOT be printed"+ _ <- evaluate x+ y <- return $ myThing "this will be printed"+ _ <- evaluate y+ _ <- evaluate $ myThing "this will be printed too"+ putStrLn "Done"++-}++-- | These functions assume that reducing the return type of the+-- subject function to WHNF will force any associated IO to occur.+-- For example, imuUni will work as intended if you apply it+-- like so:+--+-- > imuUni "okay" (fmap (fmap return) E.decClass)+--+-- In this case, the function passed as an argument to imuUni is+-- run, and the result (Quad) is reduced to WHNF. This works as+-- intended because it forces the underlying function to perform its+-- IO.+--+-- This would not work, even though it is well-typed:+--+-- > imuUni "broken" (fmap (fmap (return . Just)))+--+-- because in this case, the value returned from the computation is+-- a Ctx Maybe. Reducing the Maybe to WHNF will not force any+-- underlying IO to occurr, as this just gives you either a Maybe+-- data constructor or _|_.+imuUni+ :: String+ -- ^ Name+ -> (E.Quad -> E.Ctx a)+ -> TestTree+imuUni n f = testProperty desc $+ forAll genDecoded $ \dx ->+ monadicIO $+ let k cPtr = do+ d <- evaluate $ E.fromBCD dx+ dcd1 <- withForeignPtr (unQuad d) peek+ x <- unCtx (f d) cPtr+ _ <- evaluate x+ dcd2 <- withForeignPtr (unQuad d) peek+ return $ dcd1 == dcd2+ in inContext k >>= assert+ where+ desc = n ++ " (unary function) does not mutate only argument"+++imuBinary1st+ :: Show a+ => String+ -- ^ Name+ -> (Gen a, a -> c)+ -> (E.Quad -> c -> E.Ctx b)+ -> TestTree+imuBinary1st n (genA, getC) f = testProperty desc $+ forAll genDecoded $ \dx ->+ forAll genA $ \a ->+ monadicIO $+ let k cPtr = do + d <- evaluate $ E.fromBCD dx+ dcd1 <- withForeignPtr (unQuad d) peek+ x <- unCtx (f d (getC a)) cPtr+ _ <- evaluate x+ dcd2 <- withForeignPtr (unQuad d) peek+ return $ dcd1 == dcd2+ in inContext k >>= assert+ where+ desc = n ++ " (binary function) does not mutate first argument"++imuBinary2nd+ :: Show a+ => String+ -- ^ Name+ -> (Gen a, a -> c)+ -> (c -> E.Quad -> E.Ctx b)+ -> TestTree+imuBinary2nd n (genA, getC) f = testProperty desc $+ forAll genDecoded $ \dx ->+ forAll genA $ \a ->+ monadicIO $+ let k cPtr = do+ d <- evaluate $ E.fromBCD dx+ dcd1 <- withForeignPtr (unQuad d) peek+ x <- unCtx (f (getC a) d) cPtr+ _ <- evaluate x+ dcd2 <- withForeignPtr (unQuad d) peek+ return $ dcd1 == dcd2+ in inContext k >>= assert+ where+ desc = n ++ " (binary function) does not mutate second argument"++imuBinary+ :: String+ -> (E.Quad -> E.Quad -> E.Ctx a)+ -> TestTree+imuBinary n f = testGroup ("immutability - " ++ n)+ [ imuBinary1st n (genDecoded, E.fromBCD) f+ , imuBinary2nd n (genDecoded, E.fromBCD) f+ ]++imuTernary+ :: String+ -> (E.Quad -> E.Quad -> E.Quad -> E.Ctx a)+ -> TestTree+imuTernary n f = testGroup (n ++ " (ternary function) - immutability")+ [ testProperty "first argument" $+ forAll gen3 $ \(ga, gb, gc) ->+ monadicIO $+ let k cPtr = do+ a <- evaluate $ E.fromBCD ga+ b <- evaluate $ E.fromBCD gb+ c <- evaluate $ E.fromBCD gc + dcd1 <- withForeignPtr (unQuad a) peek+ x <- unCtx (f a b c) cPtr+ _ <- evaluate x+ dcd2 <- withForeignPtr (unQuad a) peek+ return $ dcd1 == dcd2+ in inContext k >>= assert++ , testProperty "second argument" $+ forAll gen3 $ \(ga, gb, gc) ->+ monadicIO $+ let k cPtr = do+ a <- evaluate $ E.fromBCD ga+ b <- evaluate $ E.fromBCD gb+ c <- evaluate $ E.fromBCD gc + dcd1 <- withForeignPtr (unQuad b) peek+ x <- unCtx (f a b c) cPtr+ _ <- evaluate x+ dcd2 <- withForeignPtr (unQuad b) peek+ return $ dcd1 == dcd2+ in inContext k >>= assert++ , testProperty "third argument" $+ forAll gen3 $ \(ga, gb, gc) ->+ monadicIO $+ let k cPtr = do+ a <- evaluate $ E.fromBCD ga+ b <- evaluate $ E.fromBCD gb+ c <- evaluate $ E.fromBCD gc + dcd1 <- withForeignPtr (unQuad c) peek+ x <- unCtx (f a b c) cPtr+ _ <- evaluate x+ dcd2 <- withForeignPtr (unQuad c) peek+ return $ dcd1 == dcd2+ in inContext k >>= assert+ ]+ where+ gen3 = (,,) <$> genDecoded <*> genDecoded <*> genDecoded++identity+ :: String+ -- ^ Name of thing that is identity (e.g. zero)+ -> Gen E.Decoded+ -> (E.Quad -> E.Quad -> E.Ctx E.Quad)+ -> TestTree+identity n g f = testProperty name $+ forAll genFinite $ \ad ->+ forAll g $ \bd -> E.evalCtx $ do+ let a = E.fromBCD ad+ b = E.fromBCD bd+ r <- f a b+ c <- E.compare a r+ return $ E.isZero c+ where+ name = n ++ " is the identity for finite numbers"++eitherToOrd :: Either E.Quad Ordering -> Ordering+eitherToOrd = either toOrd id+ where+ toOrd x | E.isNegative x = LT+ | E.isZero x = EQ+ | E.isPositive x = GT+ | otherwise = error "eitherToOrd: unrecognized value"++comparison+ :: String+ -- ^ Name of function+ -> (E.Quad -> E.Ctx E.Quad)+ -- ^ How to make a larger Quad+ -> (E.Quad -> E.Ctx E.Quad)+ -- ^ How to make a smaller Quad+ -> (E.Quad -> E.Quad -> E.Ctx (Either E.Quad Ordering))+ -> TestTree++comparison n fB fS fC = testGroup (n ++ " comparisons")+ [ testProperty "x > y" $ forAll genNonZeroSmallFinite $+ \da -> E.evalCtx $ do+ let a = E.fromBCD da+ b <- fB a+ c <- fC b a+ return $ eitherToOrd c == GT++ , testProperty "x < y" $ forAll genNonZeroSmallFinite $+ \da -> E.evalCtx $ do+ let a = E.fromBCD da+ b <- fS a+ c <- fC b a+ return $ eitherToOrd c == LT++ , testProperty "x == x" $ forAll genNonZeroSmallFinite $+ \da -> E.evalCtx $ do+ let a = E.fromBCD da+ c <- fC a a+ return $ eitherToOrd c == EQ++ , testProperty "transitive" $ forAll genNonZeroSmallFinite $+ \da ->+ forAll genNonZeroSmallFinite $ \db -> E.evalCtx $ do+ let a = E.fromBCD da+ b = E.fromBCD db+ c <- fC a b+ case eitherToOrd c of+ EQ -> do+ c' <- fC b a+ return $ eitherToOrd c' == EQ+ o -> do+ c' <- fC b a+ let cOrd = eitherToOrd c'+ return $ case cOrd of+ LT -> o == GT+ GT -> o == LT+ EQ -> False+ ]++testMinMax+ :: String+ -> Bool+ -- ^ True if testing absolute values+ -> (E.Quad -> E.Quad -> E.Ctx E.Quad)+ -> TestTree+testMinMax n ab f = testProperty (n ++ " and compare") $+ forAll genSmallFinite $ \da ->+ forAll genSmallFinite $ \db -> E.evalCtx $ do+ let aa = E.fromBCD da+ bb = E.fromBCD db+ (a, b) <- if ab+ then do+ aaa <- E.abs aa+ bbb <- E.abs bb+ return $ (aaa, bbb)+ else return (aa, bb)+ r <- E.compare a b+ m <- f a b+ let z = E.isZero r+ if z+ then do+ r' <- E.compare m a+ r'' <- E.compare m b+ let zr' = E.isZero r'+ zr'' = E.isZero r''+ return $ zr' && zr''+ else do+ nw <- f b a+ r' <- E.compare nw m+ return $ E.isZero r' +++decodedSameQuantum :: E.Decoded -> E.Decoded -> Bool+decodedSameQuantum x y = case (E.dValue x, E.dValue y) of+ (E.Finite _ e1, E.Finite _ e2) -> e1 == e2+ (E.Infinite, E.Infinite) -> True+ (E.NaN _ _, E.NaN _ _) -> True+ _ -> False++-- | Tests that a boolean function succeeds and fails as it should.++testBoolean+ :: String+ -- ^ Name+ -> Gen E.Decoded+ -- ^ Generates decodes that should succeed+ -> (E.Decoded -> Bool)+ -- ^ This predicate returns True on successful decodes+ -> (E.Quad -> Bool)+ -- ^ Function to test+ -> TestTree+testBoolean n g pd f = testGroup n+ [ testProperty "predicate returns true on generated decodes" $+ forAll g $ \d -> pd d+ + , testProperty "succeeds when it should" $+ forAll g $ \dcd ->+ let q = E.fromBCD dcd+ in f q++ , testProperty "fails when it should" $+ forAll (genDecoded `suchThat` (not . pd)) $ \dcd ->+ let q = E.fromBCD dcd+ in not $ f q++ , testProperty "decNumber and Deka predicate return same result"+ $ forAll genDecoded $ \dcd ->+ let q = E.fromBCD dcd+ b = f q+ in b == pd dcd+ ]++-- | Tests functions that deal with DecClass.+testDecClass+ :: E.DecClass+ -- ^ Class being tested+ -> Gen E.Decoded+ -- ^ Generates Decoded that are in this class+ -> (E.Decoded -> Bool)+ -- ^ This function should return True on Decoded that are in the+ -- class+ -> TestTree++testDecClass c ge f = testGroup (show c)+ [ testProperty "predicate returns True on generated decodes" $+ forAll ge f++ , testProperty "decClass returns matching class" $+ forAll ge $ \dcd -> let q = E.fromBCD dcd in E.decClass q == c++ , testProperty "decClass does not return matching class otherwise" $+ forAll (genDecoded `suchThat` (not . f)) $ \dcd ->+ let q = E.fromBCD dcd in E.decClass q /= c+ ]++genInt32 :: Gen C'int32_t+genInt32 = choose (minBound, maxBound)++genUInt32 :: Gen C'uint32_t+genUInt32 = choose (minBound, maxBound)++intConversion+ :: (Show a, Eq a)+ => String+ -- ^ Name+ -> Gen a+ -> (a -> E.Quad)+ -- ^ Convert from C int+ -> (E.Round -> E.Quad -> E.Ctx a)+ -- ^ Convert to C int+ -> TestTree+intConversion n gen fr to = testGroup (n ++ " conversions")+ [ testProperty "convert from C integer to Quad and back" $+ forAll genRound $ \r ->+ forAll gen $ \i ->+ let q = fr i+ (i', fl) = E.runCtx $ to r q+ in fl == E.emptyFlags && i' == i+ ]++-- | Tests that what is returned by an operation has the same+-- exponent and sign of the first operand.+sameSignExp+ :: (E.Quad -> E.Quad -> E.Ctx E.Quad)+ -> TestTree+sameSignExp f = testProperty+ "result has same sign and exponent as first argument" $+ forAll genFinite $ \d -> E.evalCtx $ do+ let x = E.fromBCD d+ r <- f x E.one+ let d' = E.toBCD r+ sameExp = case (E.dValue d, E.dValue d') of+ (E.Finite _ e, E.Finite _ e') -> e == e'+ _ -> False+ return $ E.dSign d == E.dSign d' && sameExp++-- # Tests++tests :: TestTree+tests = testGroup "Quad"+ [ testGroup "helper functions"+ [ testGroup "biggestDigs"+ [ testProperty "generates correct number of digits" $+ forAll (choose (1, 500)) $ \i ->+ numDigits (biggestDigs i) == i++ , testProperty "adding one increases number of digits" $+ forAll (choose (1, 500)) $ \i ->+ let r = biggestDigs i+ n = numDigits r+ n' = numDigits (r + 1)+ in n' == n + 1+ ]++ , testGroup "smallestDigs"+ [ testProperty "generates correct number of digits" $+ forAll (choose (1, 500)) $ \i ->+ numDigits (smallestDigs i) == i++ , testProperty "subtracting one decreases number of digits" $+ forAll (choose (1, 500)) $ \i ->+ let r = smallestDigs i+ in r > 1 ==> numDigits r - 1 == numDigits (r - 1)+ ]+ ]+++ , testGroup "immutability"+ [ testGroup "conversions"+ [ imuUni "decClass" (fmap return E.decClass)+ , imuUni "toBCD" (fmap return E.toBCD)+ , imuUni "toByteString" (fmap return E.toByteString)+ , imuUni "toEngByteString" (fmap return E.toEngByteString)+ , imuBinary2nd "toInt32" (genRound, id) E.toInt32+ , imuBinary2nd "toInt32Exact" (genRound, id) E.toInt32Exact+ , imuBinary2nd "toUInt32" (genRound, id) E.toUInt32+ , imuBinary2nd "toUInt32Exact" (genRound, id) E.toUInt32Exact+ , imuUni "toIntegralExact" E.toIntegralExact+ , imuBinary2nd "toIntegralValue" (genRound, id) E.toIntegralValue+ ]++ , testGroup "arithmetic"+ [ imuBinary "add" E.add+ , imuBinary "subtract" E.subtract+ , imuBinary "multiply" E.multiply+ , imuTernary "fma" E.fma+ , imuBinary "divide" E.divide+ , imuBinary "divideInteger" E.divideInteger+ , imuBinary "remainder" E.remainder+ , imuBinary "remainderNear" E.remainderNear+ ]++ , testGroup "exponent and coefficient adjustment"+ [ imuBinary "quantize" E.quantize+ , imuUni "reduce" E.reduce+ ]++ , testGroup "comparisons"+ [ imuBinary "compare" E.compare+ , imuBinary "compareSignal" E.compareSignal+ , imuBinary "compareTotal"+ (fmap (fmap return) E.compareTotal)+ , imuBinary "compareTotalMag"+ (fmap (fmap return) E.compareTotalMag)+ , imuBinary "max" E.max+ , imuBinary "maxMag" E.maxMag+ , imuBinary "min" E.min+ , imuBinary "minMag" E.minMag+ , imuBinary "sameQuantum"+ (fmap (fmap return) E.sameQuantum)+ ]++ , let f s k = imuUni s (fmap return k) in+ testGroup "tests"+ [ f "isFinite" E.isFinite+ , f "isInfinite" E.isInfinite+ , f "isInteger" E.isInteger+ , f "isLogical" E.isLogical+ , f "isNaN" E.isNaN+ , f "isNegative" E.isNegative+ , f "isNormal" E.isNormal+ , f "isPositive" E.isPositive+ , f "isSignaling" E.isSignaling+ , f "isSigned" E.isSigned+ , f "isSubnormal" E.isSubnormal+ , f "isZero" E.isZero+ ]++ , testGroup "signs"+ [ imuUni "plus" E.plus+ , imuUni "minus" E.minus+ , imuUni "abs" E.abs+ , imuBinary "copySign" (fmap (fmap return) E.copySign)+ ]++ , testGroup "increment and decrement"+ [ imuUni "nextMinus" E.nextMinus+ , imuUni "nextPlus" E.nextPlus+ , imuBinary "nextToward" E.nextToward+ ]++ , testGroup "logical, bitwise, digit shifting"+ [ imuBinary "and" E.and+ , imuBinary "or" E.or+ , imuBinary "shift" E.shift+ , imuBinary "xor" E.xor+ , imuBinary "rotate" E.rotate+ , imuUni "invert" E.invert+ ]++ , testGroup "log and scale"+ [ imuUni "logB" E.logB+ , imuBinary "scaleB" E.scaleB+ ]++ , testGroup "attributes"+ [ imuUni "digits" (fmap return E.digits)+ ]+ ] -- immutability++ , testGroup "rounding"+ [ testProperty "default rounding is half even" $+ once . E.evalCtx $ do+ r <- E.getRound+ return $ r == E.roundHalfEven++ , testProperty "setRound works" $+ forAll genRound $ \r -> E.evalCtx $ do+ E.setRound r+ r' <- E.getRound+ return $ r == r'++ ] -- rounding++ , testGroup "flags"+ [ testProperty "no flags set initially" . once+ . E.evalCtx $ do+ fl <- E.getStatus+ return $ fl == E.emptyFlags+ ]++ , testGroup "classes"+ [ testDecClass E.sNan+ (genNaNDcd genSign (return E.Signaling) (payloadDigits decimalDigs))+ E.dIsNaN++ , testDecClass E.qNan+ (genNaNDcd genSign (return E.Quiet) (payloadDigits decimalDigs))+ E.dIsNaN++ , testDecClass E.negInf+ (genInfinite (return E.Sign1)) E.dIsNegInf++ , testDecClass E.negNormal+ (genNormal (return E.Sign1)+ (sizedDigits E.coefficientLen decimalDigs)) E.dIsNegNormal++ , testDecClass E.negSubnormal+ (genSubnormal (return E.Sign1)+ (sizedDigits (E.coefficientLen - 1) decimalDigs))+ E.dIsNegSubnormal++ , testDecClass E.negZero genNegZero E.dIsNegZero+ , testDecClass E.posZero genPosZero E.dIsPosZero++ , testDecClass E.posSubnormal+ (genSubnormal (return E.Sign0)+ (sizedDigits (E.coefficientLen - 1) decimalDigs))+ E.dIsPosSubnormal++ , testDecClass E.posNormal+ (genNormal (return E.Sign0)+ (sizedDigits E.coefficientLen decimalDigs)) E.dIsPosNormal++ , testDecClass E.posInf+ (genInfinite (return E.Sign0)) E.dIsPosInf++ ] -- classes++ , testGroup "string conversions"+ [ testProperty ("Decoded -> Quad -> ByteString"+ ++ " -> Quad -> Decoded") $+ forAll genDecoded $ \d ->+ let q = E.fromBCD d+ bs = E.toByteString q+ q' = E.evalCtx $ E.fromByteString bs+ d' = E.toBCD q'+ desc = "toByteString: " ++ BS8.unpack bs+ ++ " toBCD: " ++ show d'+ in printTestCase desc $ d' == d++ , testProperty ("fromBCD and (fromByteString . scientific) "+ ++ "give same result") $+ forAll genDecoded $ \d ->+ let qD = E.fromBCD d+ (qS, fl) = E.runCtx . E.fromByteString+ . BS8.pack . E.scientific $ d+ compared = E.compareTotal qD qS == EQ+ in compared && fl == E.emptyFlags++ , testProperty ("fromBCD and (fromByteString . ordinary) "+ ++ "give results that compare equal") $+ forAll genDecoded $ \d ->+ let qD = E.fromBCD d+ str = E.ordinary d+ (qS, fl) = E.runCtx . E.fromByteString+ . BS8.pack $ str+ cmpResult + | E.isNormal qD = E.compareOrd qD qS == Just EQ+ | otherwise = E.compareTotal qD qS == EQ+ noFlags f = f == E.emptyFlags+ desc = "string: " ++ str+ ++ " fromByteString result: " ++ show qS+ in noFlags fl ==> printTestCase desc cmpResult++ , testProperty "toByteString -> fromByteString" $+ forAll genDecoded $ \d ->+ let q = E.fromBCD d+ bs = E.toByteString q+ (q', fl) = E.runCtx . E.fromByteString $ bs+ cmpRes = E.compareTotal q q' == EQ+ in cmpRes && fl == E.emptyFlags++ , testProperty "toEngByteString -> fromByteString" $+ forAll genDecoded $ \d ->+ let q = E.fromBCD d+ bs = E.toEngByteString q+ (q', fl) = E.runCtx . E.fromByteString $ bs+ cmpRes = E.compareOrd q q' == Just EQ+ cmpResTot = E.compareTotal q q' == EQ+ res = if E.isFinite q then cmpRes else cmpResTot+ in fl == E.emptyFlags ==> res+ ] -- string conversions++ , testGroup "integer conversions"+ [ intConversion "int32" genInt32 E.fromInt32 E.toInt32+ , intConversion "uint32" genUInt32 E.fromUInt32 E.toUInt32+ , intConversion "int32 exact" genInt32 E.fromInt32 E.toInt32Exact+ , intConversion "uint32 exact" genUInt32 E.fromUInt32 E.toUInt32Exact+ ] -- integer conversions++ , testGroup "arithmetic"+ [ testGroup "add"+ [ associativity "add" E.add+ , commutativity "add" E.add+ , identity "zero" genZero E.add+ ]++ , testGroup "multiply"+ [ associativity "multiply" E.multiply+ , commutativity "multiply" E.multiply+ , identity "one" genOne E.multiply+ ]++ , testGroup "subtract"+ [ testProperty "is the inverse of add" $+ forAll genSmallFinite $ \da ->+ forAll genSmallFinite $ \db ->+ let (r, fl) = E.runCtx $ do+ let a = E.fromBCD da+ b = E.fromBCD db+ r1 <- E.add a b+ r2 <- E.subtract r1 b+ c <- E.compare r2 a+ return $ E.isZero c+ in fl == E.emptyFlags ==> r++ , identity "zero" genZero E.subtract+ ]++ , testGroup "fused multiply add"+ [ testProperty "is same as multiply and add" $+ forAll genSmallFinite $ \da ->+ forAll genSmallFinite $ \db ->+ forAll genSmallFinite $ \dc ->+ let (r, fl) = E.runCtx $ do+ let a = E.fromBCD da+ b = E.fromBCD db+ c = E.fromBCD dc+ r1 <- E.multiply a b+ r2 <- E.add r1 c+ r2' <- E.fma a b c+ cm <- E.compare r2 r2'+ return $ E.isZero cm+ in fl == E.emptyFlags ==> r+ ]++ , testGroup "divide"+ [ identity "one" genOne E.divide ]++ , testGroup "divideInteger"+ [ testProperty "result has exponent 0" $+ forAll genSmallFinite $ \da ->+ forAll genSmallFinite $ \db ->+ let (e, fl) = E.runCtx $ do+ let a = E.fromBCD da+ b = E.fromBCD db+ c <- E.divideInteger a b+ return $ E.isInteger c+ in fl == E.emptyFlags ==> e+ ]++ , testGroup "remainder"+ [ testProperty "x = int * y + rem" $+ forAll genSmallFinite $ \dx ->+ forAll genSmallFinite $ \dy ->+ let (r, fl) = E.runCtx $ do+ let x = E.fromBCD dx+ y = E.fromBCD dy+ it <- E.divideInteger x y+ rm <- E.remainder x y+ i1 <- E.multiply it y+ i2 <- E.add i1 rm+ c <- E.compare i2 x+ return $ E.isZero c+ in fl == E.emptyFlags ==> r+ ]+ -- remainderNear - no test - not sure I understand the+ -- semantics++ ] -- arithmetic++ , testGroup "exponent and coefficient adjustment"+ [ testGroup "quantize"+ [ testProperty "result has same quantum" $+ forAll genSmallFinite $ \dx ->+ forAll genSmallFinite $ \dy ->+ let (r, fl) = E.runCtx $ do+ let x = E.fromBCD dx+ y = E.fromBCD dy+ c <- E.quantize x y+ let getExp a = do+ let dcd = E.toBCD a+ return $ case E.dValue dcd of+ E.Finite _ e -> Just e+ _ -> Nothing+ exC <- getExp c+ exY <- getExp y+ let fin = E.isFinite c+ return $ fin && exC == exY+ in fl == E.emptyFlags ==> r+ ]++ , testGroup "reduce"+ [ testProperty "result is equivalent" $+ forAll genSmallFinite $ \dx -> E.evalCtx $ do+ let x = E.fromBCD dx+ r <- E.reduce x+ c <- E.compare r x+ return $ E.isZero c++ , testProperty "result has no trailing zeroes" $+ forAll genSmallFinite $ \dx -> E.evalCtx $ do+ let x = E.fromBCD dx+ r <- E.reduce x+ let dcd = E.toBCD r+ return $ case E.dValue dcd of+ E.Infinite -> False+ E.NaN _ _ -> False+ E.Finite c _ ->+ let digs = E.unCoefficient c+ in all (== E.D0) digs || last digs /= E.D0+ ]+ ] -- exponent and coefficient adjustment++ , testGroup "comparisons"+ [ comparison "compare" E.nextPlus E.nextMinus+ (fmap (fmap (fmap Left)) E.compare)++ , comparison "compareSignal" E.nextPlus+ E.nextMinus (fmap (fmap (fmap Left )) E.compareSignal)++ , comparison "compareTotal" E.nextPlus E.nextMinus+ (fmap (fmap (return . Right)) E.compareTotal)++ , comparison "compareTotalMag" increaseAbs decreaseAbs+ (fmap (fmap (return . Right)) E.compareTotalMag)++ , testMinMax "min" False E.min+ , testMinMax "max" False E.max+ , testMinMax "maxMag" True E.maxMag+ , testMinMax "minMag" True E.minMag++ , testGroup "sameQuantum"+ [ testProperty "is true for same Decoded" $+ forAll genDecoded $ \d ->+ let x = E.fromBCD d+ in E.sameQuantum x x++ , testProperty "is false for different Decoded" $+ forAll ( liftM2 (,) genDecoded genDecoded+ `suchThat` (not . uncurry decodedSameQuantum))+ $ \p -> let qx = E.fromBCD . fst $ p+ qy = E.fromBCD . snd $ p+ in not $ E.sameQuantum qx qy+ ]+ ] -- comparisons++ , testGroup "tests"+ [ testBoolean "isFinite" genFinite E.dIsFinite E.isFinite++ , testBoolean "isInfinite" (genInfinite genSign)+ E.dIsInfinite E.isInfinite++ , testGroup "isInteger"+ [ testBoolean "isInteger" genInteger E.dIsInteger E.isInteger++ , let e = fromMaybe (error "isInteger exponent failed")+ . E.exponent $ 2+ c = fromMaybe (error "isInteger coefficient failed")+ . E.coefficient $ [E.D3]+ dcd = E.Decoded E.Sign0 (E.Finite c e)+ d = E.fromBCD dcd+ in testProperty "returns False on 3 * 10 ^ 2" . once+ . not . E.isInteger $ d+ ]++ , testBoolean "isLogical" genLogical+ E.dIsLogical E.isLogical++ , testBoolean "isNaN"+ (genNaNDcd genSign genNaN (payloadDigits decimalDigs))+ E.dIsNaN E.isNaN++ , testBoolean "isNegative" genNegative+ E.dIsNegative E.isNegative++ , testBoolean "isNormal"+ (genNormal genSign (sizedDigits E.coefficientLen decimalDigs))+ E.dIsNormal E.isNormal++ , testBoolean "isPositive" genPositive+ E.dIsPositive E.isPositive++ , testBoolean "isSignaling" genSignaling+ E.dIsSignaling E.isSignaling++ , testBoolean "isSigned" genSigned+ E.dIsSigned E.isSigned++ , testBoolean "isSubnormal"+ (genSubnormal genSign (sizedDigits (E.coefficientLen - 1) decimalDigs))+ E.dIsSubnormal E.isSubnormal++ , testBoolean "isZero" genZero E.dIsZero E.isZero++ ] -- tests++ , testGroup "signs"+ [ testGroup "plus"+ [ testProperty "same as 0 + x where 0 has same exponent" $+ forAll genDecoded $ \d ->+ let e = case E.dValue d of+ E.Finite _ ex -> ex+ _ -> E.zeroExponent+ z = E.fromBCD $ E.Decoded E.Sign0+ (E.Finite E.zeroCoefficient e)+ q = E.fromBCD d+ rAdd = E.evalCtx $ E.add z q+ rPlus = E.evalCtx $ E.plus q+ in E.compareTotal rAdd rPlus == EQ+ ]++ , testGroup "minus"+ [ testProperty "same as 0 - x where 0 has same exponent" $+ forAll genDecoded $ \d ->+ let e = case E.dValue d of+ E.Finite _ ex -> ex+ _ -> E.zeroExponent+ z = E.fromBCD $ E.Decoded E.Sign0+ (E.Finite E.zeroCoefficient e)+ q = E.fromBCD d+ rSubt = E.evalCtx $ E.subtract z q+ rMinus = E.evalCtx $ E.minus q+ in E.compareTotal rSubt rMinus == EQ+ ]++ , testGroup "abs"+ [ testProperty "sign is correctly set" $+ forAll genDecoded $ \d ->+ let expected = case E.dValue d of+ E.Finite _ _ -> E.Sign0+ E.Infinite -> E.Sign0+ E.NaN _ _ -> E.dSign d+ q = E.fromBCD d+ actual = E.dSign . E.toBCD . E.evalCtx . E.abs $ q+ in actual == expected+ ]++ , testGroup "copySign"+ [ testProperty "z is copy of x with sign of y" $+ forAll genDecoded $ \dx ->+ forAll genDecoded $ \dy ->+ let expected = dx { E.dSign = E.dSign dy }+ (x, y) = (E.fromBCD dx, E.fromBCD dy)+ r = E.toBCD $ E.copySign x y+ in r == expected+ ]+ ] -- signs++ , testGroup "increment and decrement"+ [ testProperty "nextMinus returns smaller result" $+ forAll genFinite $ \d ->+ let q = E.fromBCD d+ (r, fl) = E.runCtx $ E.nextMinus q+ cmp = E.evalCtx $ E.compare r q+ in fl == E.emptyFlags ==> E.isNegative cmp++ , testProperty "nextPlus returns larger result" $+ forAll genFinite $ \d ->+ let q = E.fromBCD d+ (r, fl) = E.runCtx $ E.nextPlus q+ cmp = E.evalCtx $ E.compare r q+ in fl == E.emptyFlags ==> E.isPositive cmp++ , testProperty "nextToward does not change sign of comparison" $+ forAll genFinite $ \dx ->+ forAll genFinite $ \dy ->+ let x = E.fromBCD dx+ y = E.fromBCD dy+ cmp1 = E.evalCtx $ E.compare x y+ x' = E.evalCtx $ E.nextToward x y+ cmp2 = E.evalCtx $ E.compare x' y+ r | E.isNegative cmp1 = E.isNegative cmp2 || E.isZero cmp2+ | E.isZero cmp1 = E.isZero cmp2+ | otherwise = E.isPositive cmp2 || E.isZero cmp2+ in r++ ] -- increment and decrement++ , testGroup "digit-wise"+ [ testGroup "and"+ [ testProperty "x & 0 == 0" $+ forAll genLogical $ \d ->+ let q = E.fromBCD d+ r = E.evalCtx $ E.and q E.zero+ in E.isZero r+ ]++ , testGroup "or"+ [ testProperty "x | 0 == x" $+ forAll genLogical $ \d ->+ let r = E.evalCtx $ E.or x E.zero+ x = E.fromBCD d+ in E.compareOrd x r == Just EQ++ , testProperty "x | x == x" $+ forAll genLogical $ \d ->+ let r = E.evalCtx $ E.or x x+ cmp = E.compareTotal r x+ x = E.fromBCD d+ in cmp == EQ+ ]++ , testGroup "xor"+ [ testProperty "x XOR 0 == x" $+ forAll genLogical $ \d ->+ let r = E.evalCtx $ E.xor x E.zero+ cmp = E.compareTotal r x+ x = E.fromBCD d+ in cmp == EQ++ , testProperty "x XOR x == 0" $+ forAll genLogical $ \d ->+ let r = E.evalCtx $ E.xor x x+ x = E.fromBCD d+ in E.isZero r++ ]++ , testGroup "invert"+ [ testProperty "invert twice is idempotent" $+ forAll genLogical $ \d -> E.evalCtx $ do+ let q = E.fromBCD d+ r1 <- E.invert q+ r2 <- E.invert r1+ return $ E.compareOrd r2 q == Just EQ+ ]++ , testGroup "shift"+ [ sameSignExp E.shift+ ] -- shift++ , testGroup "rotate"+ [ sameSignExp E.rotate+ ]+ ] -- digit-wise++ , testGroup "log and scale"+ [ testGroup "logB"+ [ testProperty "returns adjusted exponent of finite numbers" $+ forAll genFinite $ \d -> E.evalCtx $ do+ let q = E.fromBCD d+ lg <- E.logB q+ i <- E.toInt32 E.roundUp lg+ let e = fromIntegral i+ r = case E.dValue d of+ E.Finite c ex ->+ E.unAdjustedExp (E.adjustedExp c ex) == e+ _ -> False+ return r+ ]++ , testGroup "scaleB"+ [ testProperty "scaleB x 0 == x" $+ forAll genFinite $ \d -> E.evalCtx $ do+ let q = E.fromBCD d+ b <- E.scaleB q E.zero+ return $ E.compareOrd q b == Just EQ+ ]+ ] -- log and scale++ , testGroup "attributes"+ [ testGroup "digits"+ [ testProperty "gets same result as length of decoded coeff" $+ forAll genFinite $ \d ->+ let digs = E.digits . E.fromBCD $ d+ in case E.dValue d of+ E.Finite c _ -> length (E.unCoefficient c) == digs+ _ -> False+ ]+ ] -- attributes++ , testGroup "conversions"+ [ testGroup "decode and encode"+ [ testProperty "round trip from Decoded" $+ forAll genDecoded $ \d ->+ let r = E.toBCD . E.fromBCD $ d+ in printTestCase ("result: " ++ show r) (r == d)+ ]+ ] -- conversions++ ] -- Quad
+ test/DataDir/DekaTest.hs view
@@ -0,0 +1,81 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}++module DataDir.DekaTest where++import Data.Maybe+import Control.Exception+import Test.Tasty+import Test.Tasty.QuickCheck (testProperty)+import Test.QuickCheck+import Test.QuickCheck.Monadic+import qualified Test.QuickCheck.Monadic as Q+import DataDir.DekaDir.QuadTest+import Data.Deka.Quad+import Data.Deka+import qualified Data.ByteString.Char8 as BS8++-- | Tests that a binary operator never produces non-finite values.+noNonFinite+ :: String+ -- ^ Name+ -> (Deka -> Deka -> Deka)+ -> TestTree+noNonFinite n f = testProperty+ (n ++ " does not produce non-finite values") prop+ where+ prop =+ forAll genFinite $ \d1 ->+ forAll genFinite $ \d2 ->+ monadicIO $ do+ mayR <- run (doCalc d1 d2)+ case mayR of+ Nothing -> Q.assert True+ Just r -> Q.assert . isFinite . unDeka $ r+ doCalc x y =+ let (xD, yD) = (toDeka x, toDeka y)+ outer = do+ r <- evaluate $ f xD yD+ return . Just $ r+ catcher e = let _types = e :: DekaError in return Nothing+ in catch outer catcher++-- | Puts finite Quad into a Deka. Calls "error" if it fails.++toDeka :: Decoded -> Deka+toDeka = fromMaybe (error "toDeka failed") . quadToDeka . fromBCD++tests = testGroup "Deka"+ [ testGroup "integralToDeka"+ [ testProperty "succeeds when <= Pmax digits" $+ let r = (negate i, i)+ i = biggestDigs coefficientLen+ in forAll (choose r) $ \int -> isJust (integralToDeka int)+ ]++ , testGroup "strToDeka"+ [ testProperty "fails on non-finite strings; succeeds on finites" $+ forAll genDecoded $ \d ->+ let r = strToDeka . BS8.unpack . toByteString . fromBCD $ d+ in case dValue d of+ Finite _ _ -> isJust r+ _ -> isNothing r+ ]++ , testGroup "quadToDeka"+ [ testProperty "fails and succeeds as it should" $+ forAll genDecoded $ \d ->+ let r = quadToDeka $ fromBCD d+ in if dIsFinite d then isJust r else isNothing r+ ]+ + , testGroup "Deka"+ [ testProperty "equivalent Deka are Eq" $+ forAll genEquivalent $ \(d1, d2) ->+ let (q1, q2) = (toDeka d1, toDeka d2)+ in q1 == q2++ , noNonFinite "+" (+)+ , noNonFinite "-" (-)+ , noNonFinite "*" (*)+ ]+ ]
+ test/tasty-test.hs view
@@ -0,0 +1,13 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Main where++import Test.Tasty++import qualified DataDir++tests :: TestTree+tests = testGroup "tasty-test"+ [ DataDir.tests+ ]++main = defaultMain tests