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)
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"
newQuad :: IO Quad
newQuad = fmap Quad mallocForeignPtr
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
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
newtype Quad = Quad { unQuad :: ForeignPtr C'decQuad }
instance Eq Quad where
x == y = case compareTotal x y of
EQ -> True
_ -> False
instance Ord Quad where
compare = compareTotal
instance Show Quad where
show = BS8.unpack . toByteString
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
compareTotal :: Quad -> Quad -> Ordering
compareTotal x y
| isNegative c = LT
| isZero c = EQ
| isPositive c = GT
| otherwise = error "compareTotal: unknown result"
where
c = binaryCtxFree unsafe'c'decQuadCompareTotal x y
isNegative :: Quad -> Bool
isNegative = boolean unsafe'c'decQuadIsNegative
isZero :: Quad -> Bool
isZero = boolean unsafe'c'decQuadIsZero
isPositive :: Quad -> Bool
isPositive = boolean unsafe'c'decQuadIsPositive