diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + +[![Build Status](https://travis-ci.org/massysett/deka.png?branch=master)](https://travis-ci.org/massysett/deka) + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/deka.cabal b/deka.cabal new file mode 100644 --- /dev/null +++ b/deka.cabal @@ -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 + . + + . + decNumber, in turn, implements the General Decimal Arithmetic + Specification, which is available at + . + + . + 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 + . + + . + For more on deka, please see the Github home page at + . + + +-- 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 + diff --git a/lib/Data/Deka.hs b/lib/Data/Deka.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Deka.hs @@ -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: +-- +-- +-- +-- 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 diff --git a/lib/Data/Deka/Decnumber.hsc b/lib/Data/Deka/Decnumber.hsc new file mode 100644 --- /dev/null +++ b/lib/Data/Deka/Decnumber.hsc @@ -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 +#include +#include + +-- | 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 , +#field emax , +#field emin , +#field round , +#field traps , +#field status , +#field clamp , +#stoptype + +-- decContext +#num DEC_INIT_DECQUAD +#ccall_unsafe decContextDefault , Ptr -> -> IO (Ptr ) + +#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 , +#array_field shorts , +#array_field words , +#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 -> Ptr -> -> IO +#ccall_unsafe decQuadToInt32Exact , Ptr -> Ptr -> -> IO + +#ccall_unsafe decQuadFromInt32 , Ptr -> -> IO (Ptr ) +#ccall_unsafe decQuadFromPacked , Ptr -> -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadFromPackedChecked , Ptr -> -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadFromUInt32 , Ptr -> -> IO (Ptr ) +#ccall_unsafe decQuadFromString , Ptr -> CString -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadGetCoefficient , Ptr -> Ptr -> IO +#ccall_unsafe decQuadGetExponent , Ptr -> IO +#ccall_unsafe decQuadSetCoefficient , Ptr -> Ptr -> -> IO (Ptr ) +#ccall_unsafe decQuadSetExponent , Ptr -> Ptr -> -> IO (Ptr ) +#ccall_unsafe decQuadShow , Ptr -> CString -> IO () +#ccall_unsafe decQuadToEngString , Ptr -> CString -> IO CString +#ccall_unsafe decQuadToString , Ptr -> CString -> IO CString +#ccall_unsafe decQuadToUInt32 , Ptr -> Ptr -> -> IO +#ccall_unsafe decQuadToUInt32Exact , Ptr -> Ptr -> -> IO +#ccall_unsafe decQuadZero , Ptr -> IO (Ptr ) +#ccall_unsafe decQuadAbs , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadAdd , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadAnd , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadDivide , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadDivideInteger , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadFMA , Ptr -> Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadFromBCD , Ptr -> -> Ptr -> -> IO (Ptr ) +#ccall_unsafe decQuadInvert , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadLogB , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadMax , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadMaxMag , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadMin , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadMinMag , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadMinus , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadMultiply , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadNextMinus , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadNextPlus , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadNextToward , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadOr , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadPlus , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadQuantize , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadReduce , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadRemainder , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadRemainderNear , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadRotate , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadScaleB , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadShift , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadSubtract , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadToBCD , Ptr -> Ptr -> Ptr -> IO +#ccall_unsafe decQuadToIntegralValue , Ptr -> Ptr -> Ptr -> -> IO (Ptr ) +#ccall_unsafe decQuadToIntegralExact , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadXor , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) + +-- Comparisons + +#ccall_unsafe decQuadCompare , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadCompareSignal , Ptr -> Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadCompareTotal , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadCompareTotalMag , Ptr -> Ptr -> Ptr -> IO (Ptr ) + +-- Copies +#ccall_unsafe decQuadCanonical , Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadCopyAbs , Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadCopyNegate , Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadCopySign , Ptr -> Ptr -> Ptr -> IO (Ptr ) +#ccall_unsafe decQuadCopy , Ptr -> Ptr -> IO (Ptr ) + +-- Non-computational + +#ccall_unsafe decQuadClass , Ptr -> IO +#ccall_unsafe decQuadClassString , Ptr -> IO CString +#ccall_unsafe decQuadDigits , Ptr -> IO +#ccall_unsafe decQuadIsCanonical , Ptr -> IO +#ccall_unsafe decQuadIsFinite , Ptr -> IO +#ccall_unsafe decQuadIsInteger , Ptr -> IO +#ccall_unsafe decQuadIsLogical , Ptr -> IO +#ccall_unsafe decQuadIsInfinite , Ptr -> IO +#ccall_unsafe decQuadIsNaN , Ptr -> IO +#ccall_unsafe decQuadIsNegative , Ptr -> IO +#ccall_unsafe decQuadIsNormal , Ptr -> IO +#ccall_unsafe decQuadIsPositive , Ptr -> IO +#ccall_unsafe decQuadIsSignaling , Ptr -> IO +#ccall_unsafe decQuadIsSigned , Ptr -> IO +#ccall_unsafe decQuadIsSubnormal , Ptr -> IO +#ccall_unsafe decQuadIsZero , Ptr -> IO +#ccall_unsafe decQuadRadix , Ptr -> IO +#ccall_unsafe decQuadSameQuantum , Ptr -> Ptr -> IO +#ccall_unsafe decQuadVersion , IO CString diff --git a/lib/Data/Deka/Docs.hs b/lib/Data/Deka/Docs.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Deka/Docs.hs @@ -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 +-- +-- +-- +-- 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: +-- +-- + +module Data.Deka.Docs where diff --git a/lib/Data/Deka/Docs/Examples.lhs b/lib/Data/Deka/Docs/Examples.lhs new file mode 100644 --- /dev/null +++ b/lib/Data/Deka/Docs/Examples.lhs @@ -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: +> -- +> -- +> 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! + +> }; diff --git a/lib/Data/Deka/Internal.hs b/lib/Data/Deka/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Deka/Internal.hs @@ -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 + diff --git a/lib/Data/Deka/Quad.hs b/lib/Data/Deka/Quad.hs new file mode 100644 --- /dev/null +++ b/lib/Data/Deka/Quad.hs @@ -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: +-- +-- +-- +-- +-- +-- +-- +-- 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 + -- + -- + , Round + , roundCeiling + , roundUp + , roundHalfUp + , roundHalfEven + , roundHalfDown + , roundDown + , roundFloor + , round05Up + + -- * Flags + -- + -- | For more on possible flags, see + -- + -- + , 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 +-- +-- +-- +-- 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 diff --git a/test/DataDir.hs b/test/DataDir.hs new file mode 100644 --- /dev/null +++ b/test/DataDir.hs @@ -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 + ] diff --git a/test/DataDir/DekaDir.hs b/test/DataDir/DekaDir.hs new file mode 100644 --- /dev/null +++ b/test/DataDir/DekaDir.hs @@ -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 + ] diff --git a/test/DataDir/DekaDir/QuadTest.hs b/test/DataDir/DekaDir/QuadTest.hs new file mode 100644 --- /dev/null +++ b/test/DataDir/DekaDir/QuadTest.hs @@ -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 diff --git a/test/DataDir/DekaTest.hs b/test/DataDir/DekaTest.hs new file mode 100644 --- /dev/null +++ b/test/DataDir/DekaTest.hs @@ -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 "*" (*) + ] + ] diff --git a/test/tasty-test.hs b/test/tasty-test.hs new file mode 100644 --- /dev/null +++ b/test/tasty-test.hs @@ -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