module Data.Deka.Quad
(
Quad
, Round
, roundCeiling
, roundUp
, roundHalfUp
, roundHalfEven
, roundHalfDown
, roundDown
, roundFloor
, round05Up
, Flag
, divisionUndefined
, divisionByZero
, divisionImpossible
, invalidOperation
, inexact
, underflow
, overflow
, conversionSyntax
, Flags
, unFlags
, setFlag
, clearFlag
, checkFlag
, emptyFlags
, Ctx
, getStatus
, setStatus
, mapStatus
, getRound
, setRound
, runCtx
, evalCtx
, DecClass
, sNan
, qNan
, negInf
, negNormal
, negSubnormal
, negZero
, posZero
, posSubnormal
, posNormal
, posInf
, decClass
, fromByteString
, toByteString
, toEngByteString
, C'int32_t
, C'uint32_t
, fromInt32
, fromUInt32
, toInt32
, toInt32Exact
, toUInt32
, toUInt32Exact
, add
, subtract
, multiply
, fma
, divide
, divideInteger
, remainder
, remainderNear
, quantize
, reduce
, compare
, compareOrd
, compareSignal
, compareTotal
, compareTotalMag
, max
, maxMag
, min
, minMag
, sameQuantum
, isFinite
, isInfinite
, isInteger
, isLogical
, isNaN
, isNegative
, isNormal
, isPositive
, isSignaling
, isSigned
, isSubnormal
, isZero
, plus
, minus
, abs
, copySign
, nextMinus
, nextPlus
, nextToward
, and
, or
, xor
, invert
, shift
, rotate
, logB
, scaleB
, digits
, toIntegralExact
, toIntegralValue
, zero
, one
, version
, Digit(..)
, digitToInt
, intToDigit
, digitToChar
, digitsToInteger
, integralToDigits
, coefficientLen
, payloadLen
, Coefficient
, coefficient
, unCoefficient
, zeroCoefficient
, oneCoefficient
, Payload
, payload
, unPayload
, zeroPayload
, Exponent
, exponent
, unExponent
, zeroExponent
, minMaxExp
, AdjustedExp
, adjustedExp
, unAdjustedExp
, minNormalAdj
, minNormalExp
, adjustedToExponent
, Sign(..)
, NaN(..)
, Value(..)
, Decoded(..)
, fromBCD
, toBCD
, scientific
, ordinary
, decodedToRational
, dIsFinite
, dIsInfinite
, dIsInteger
, dIsLogical
, dIsNaN
, dIsNegative
, dIsNormal
, dIsPositive
, dIsSignaling
, dIsSigned
, dIsSubnormal
, dIsZero
, dDigits
, dIsSNaN
, dIsQNaN
, dIsNegInf
, dIsNegNormal
, dIsNegSubnormal
, dIsNegZero
, dIsPosZero
, dIsPosSubnormal
, dIsPosNormal
, dIsPosInf
) where
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
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"
roundCeiling :: Round
roundCeiling = Round c'DEC_ROUND_CEILING
roundUp :: Round
roundUp = Round c'DEC_ROUND_UP
roundHalfUp :: Round
roundHalfUp = Round c'DEC_ROUND_HALF_UP
roundHalfEven :: Round
roundHalfEven = Round c'DEC_ROUND_HALF_EVEN
roundHalfDown :: Round
roundHalfDown = Round c'DEC_ROUND_HALF_DOWN
roundDown :: Round
roundDown = Round c'DEC_ROUND_DOWN
roundFloor :: Round
roundFloor = Round c'DEC_ROUND_FLOOR
round05Up :: Round
round05Up = Round c'DEC_ROUND_05UP
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"
divisionUndefined :: Flag
divisionUndefined = Flag c'DEC_Division_undefined
divisionByZero :: Flag
divisionByZero = Flag c'DEC_Division_by_zero
divisionImpossible :: Flag
divisionImpossible = Flag c'DEC_Division_impossible
invalidOperation :: Flag
invalidOperation = Flag c'DEC_Invalid_operation
inexact :: Flag
inexact = Flag c'DEC_Inexact
underflow :: Flag
underflow = Flag c'DEC_Underflow
overflow :: Flag
overflow = Flag c'DEC_Overflow
conversionSyntax :: Flag
conversionSyntax = Flag c'DEC_Conversion_syntax
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]
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)
checkFlag :: Flag -> Flags -> Bool
checkFlag (Flag f1) (Flags fA) = (f1 .&. fA) /= 0
emptyFlags :: Flags
emptyFlags = Flags 0
getStatus :: Ctx Flags
getStatus = Ctx $ \cPtr -> do
let pSt = p'decContext'status cPtr
fmap Flags . peek $ pSt
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'
getRound :: Ctx Round
getRound = Ctx $ \cPtr -> do
let pR = p'decContext'round cPtr
fmap Round . peek $ pR
setRound :: Round -> Ctx ()
setRound r = Ctx $ \cPtr -> do
let pR = p'decContext'round cPtr
poke pR . unRound $ r
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')
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
newtype DecClass = DecClass C'decClass
deriving (Eq, Ord)
sNan :: DecClass
sNan = DecClass c'DEC_CLASS_SNAN
qNan :: DecClass
qNan = DecClass c'DEC_CLASS_QNAN
negInf :: DecClass
negInf = DecClass c'DEC_CLASS_NEG_INF
negNormal :: DecClass
negNormal = DecClass c'DEC_CLASS_NEG_NORMAL
negSubnormal :: DecClass
negSubnormal = DecClass c'DEC_CLASS_NEG_SUBNORMAL
negZero :: DecClass
negZero = DecClass c'DEC_CLASS_NEG_ZERO
posZero :: DecClass
posZero = DecClass c'DEC_CLASS_POS_ZERO
posSubnormal :: DecClass
posSubnormal = DecClass c'DEC_CLASS_POS_SUBNORMAL
posNormal :: DecClass
posNormal = DecClass c'DEC_CLASS_POS_NORMAL
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"
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 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 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
abs :: Quad -> Ctx Quad
abs = unary unsafe'c'decQuadAbs
add :: Quad -> Quad -> Ctx Quad
add = binary unsafe'c'decQuadAdd
and :: Quad -> Quad -> Ctx Quad
and = binary unsafe'c'decQuadAnd
decClass :: Quad -> DecClass
decClass = DecClass . unaryGet unsafe'c'decQuadClass
compare :: Quad -> Quad -> Ctx Quad
compare = binary unsafe'c'decQuadCompare
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
compareSignal :: Quad -> Quad -> Ctx Quad
compareSignal = binary unsafe'c'decQuadCompareSignal
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
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
digits :: Quad -> Int
digits = fromIntegral . unaryGet unsafe'c'decQuadDigits
divide :: Quad -> Quad -> Ctx Quad
divide = binary unsafe'c'decQuadDivide
divideInteger :: Quad -> Quad -> Ctx Quad
divideInteger = binary unsafe'c'decQuadDivideInteger
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
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
invert :: Quad -> Ctx Quad
invert = unary unsafe'c'decQuadInvert
isFinite :: Quad -> Bool
isFinite = boolean unsafe'c'decQuadIsFinite
isInfinite :: Quad -> Bool
isInfinite = boolean unsafe'c'decQuadIsInfinite
isInteger :: Quad -> Bool
isInteger = boolean unsafe'c'decQuadIsInteger
isLogical :: Quad -> Bool
isLogical = boolean unsafe'c'decQuadIsLogical
isNaN :: Quad -> Bool
isNaN = boolean unsafe'c'decQuadIsNaN
isNormal :: Quad -> Bool
isNormal = boolean unsafe'c'decQuadIsNormal
isSignaling :: Quad -> Bool
isSignaling = boolean unsafe'c'decQuadIsSignaling
isSigned :: Quad -> Bool
isSigned = boolean unsafe'c'decQuadIsSigned
isSubnormal :: Quad -> Bool
isSubnormal = boolean unsafe'c'decQuadIsSubnormal
logB :: Quad -> Ctx Quad
logB = unary unsafe'c'decQuadLogB
max :: Quad -> Quad -> Ctx Quad
max = binary unsafe'c'decQuadMax
maxMag :: Quad -> Quad -> Ctx Quad
maxMag = binary unsafe'c'decQuadMaxMag
min :: Quad -> Quad -> Ctx Quad
min = binary unsafe'c'decQuadMin
minMag :: Quad -> Quad -> Ctx Quad
minMag = binary unsafe'c'decQuadMinMag
minus :: Quad -> Ctx Quad
minus = unary unsafe'c'decQuadMinus
multiply :: Quad -> Quad -> Ctx Quad
multiply = binary unsafe'c'decQuadMultiply
nextMinus :: Quad -> Ctx Quad
nextMinus = unary unsafe'c'decQuadNextMinus
nextPlus :: Quad -> Ctx Quad
nextPlus = unary unsafe'c'decQuadNextPlus
nextToward :: Quad -> Quad -> Ctx Quad
nextToward = binary unsafe'c'decQuadNextToward
or :: Quad -> Quad -> Ctx Quad
or = binary unsafe'c'decQuadOr
plus :: Quad -> Ctx Quad
plus = unary unsafe'c'decQuadPlus
quantize :: Quad -> Quad -> Ctx Quad
quantize = binary unsafe'c'decQuadQuantize
reduce :: Quad -> Ctx Quad
reduce = unary unsafe'c'decQuadReduce
remainder :: Quad -> Quad -> Ctx Quad
remainder = binary unsafe'c'decQuadRemainder
remainderNear :: Quad -> Quad -> Ctx Quad
remainderNear = binary unsafe'c'decQuadRemainderNear
rotate :: Quad -> Quad -> Ctx Quad
rotate = binary unsafe'c'decQuadRotate
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 :: Quad -> Quad -> Ctx Quad
scaleB = binary unsafe'c'decQuadScaleB
shift :: Quad -> Quad -> Ctx Quad
shift = binary unsafe'c'decQuadShift
subtract :: Quad -> Quad -> Ctx Quad
subtract = binary unsafe'c'decQuadSubtract
toEngByteString :: Quad -> BS8.ByteString
toEngByteString = mkString unsafe'c'decQuadToEngString
toInt32 :: Round -> Quad -> Ctx C'int32_t
toInt32 = getRounded unsafe'c'decQuadToInt32
toInt32Exact :: Round -> Quad -> Ctx C'int32_t
toInt32Exact = getRounded unsafe'c'decQuadToInt32Exact
toIntegralExact :: Quad -> Ctx Quad
toIntegralExact = unary unsafe'c'decQuadToIntegralExact
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
toUInt32 :: Round -> Quad -> Ctx C'uint32_t
toUInt32 = getRounded unsafe'c'decQuadToUInt32
toUInt32Exact :: Round -> Quad -> Ctx C'uint32_t
toUInt32Exact = getRounded unsafe'c'decQuadToUInt32Exact
version :: BS8.ByteString
version = unsafePerformIO $
unsafe'c'decQuadVersion >>= BS8.packCString
xor :: Quad -> Quad -> Ctx Quad
xor = binary unsafe'c'decQuadXor
zero :: Quad
zero = unsafePerformIO $
newQuad >>= \d ->
withForeignPtr (unQuad d) $ \pD ->
unsafe'c'decQuadZero pD >>
return d
one :: Quad
one = fromBCD
$ Decoded Sign0 (Finite (Coefficient [D1]) (Exponent 0))
data Sign
= Sign0
| Sign1
deriving (Eq, Ord, Show, Enum, Bounded)
data NaN
= Quiet
| Signaling
deriving (Eq, Ord, Show, Enum, Bounded)
minMaxExp :: (Int, Int)
minMaxExp = (l, h)
where
l = c'DECQUAD_Emin c'DECQUAD_Pmax + 1
h = c'DECQUAD_Emax c'DECQUAD_Pmax + 1
minNormalAdj :: AdjustedExp
minNormalAdj = AdjustedExp c'DECQUAD_Emin
minNormalExp :: Coefficient -> Exponent
minNormalExp c = adjustedToExponent c $ minNormalAdj
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
exponent :: Int -> Maybe Exponent
exponent i
| i < l = Nothing
| i > h = Nothing
| otherwise = Just . Exponent $ i
where
(l, h) = minMaxExp
zeroExponent :: Exponent
zeroExponent = Exponent 0
data Value
= Finite Coefficient Exponent
| Infinite
| NaN NaN Payload
deriving (Eq, Ord, Show)
data Decoded = Decoded
{ dSign :: Sign
, dValue :: Value
} deriving (Eq, Ord, Show)
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)
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
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
-> C'int32_t
-> [C'uint8_t]
-> 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
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
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
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
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' }
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
coefficient :: [Digit] -> Maybe Coefficient
coefficient ls
| null ls = Nothing
| length ls > 1 && head ls == D0 = Nothing
| length ls > coefficientLen = Nothing
| otherwise = Just . Coefficient $ ls
zeroCoefficient :: Coefficient
zeroCoefficient = Coefficient [D0]
oneCoefficient :: Coefficient
oneCoefficient = Coefficient [D1]
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
payload :: [Digit] -> Maybe Payload
payload ds
| null ds = Nothing
| length ds > 1 && head ds == D0 = Nothing
| length ds > payloadLen = Nothing
| otherwise = Just . Payload $ ds
zeroPayload :: Payload
zeroPayload = Payload [D0]
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
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
coefficientLen :: Int
coefficientLen = c'DECQUAD_Pmax
payloadLen :: Int
payloadLen = c'DECQUAD_Pmax 1
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
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
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
dIsZero :: Decoded -> Bool
dIsZero (Decoded _ v) = case v of
Finite d _ -> all (== D0) . unCoefficient $ d
_ -> False
dDigits :: Coefficient -> Int
dDigits (Coefficient ds) = case dropWhile (== D0) ds of
[] -> 1
rs -> length rs
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
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