{-
 - Copyright (C) 2009 Nick Bowler.
 -
 - License BSD2:  2-clause BSD license.  See LICENSE for full terms.
 - This is free software: you are free to change and redistribute it.
 - There is NO WARRANTY, to the extent permitted by law.
 -}

{-# LANGUAGE ForeignFunctionInterface, MagicHash, UnboxedTuples #-}
{-# INCLUDE <stdlib.h> <math.h> "cfloat.h" #-}
module Data.Floating.Double (
    Double
) where

import Prelude hiding (Double, Floating(..), RealFloat(..), Ord(..))
import Control.Applicative
import Control.Monad
import Data.Maybe
import Data.Ratio
import Data.Poset

import GHC.Exts hiding (Double(..))
import GHC.Integer
import GHC.Prim

import Foreign
import Foreign.C
import System.IO.Unsafe

import Data.Floating.Types
import Data.Floating.Classes
import Data.Floating.CMath

foreign import ccall unsafe "double_format"
    double_format :: CString -> CString -> CDouble -> IO CInt
foreign import ccall unsafe "double_signum"
    double_signum :: CDouble -> CDouble
foreign import ccall unsafe "double_classify"
    double_classify :: CDouble -> CInt
foreign import ccall unsafe "double_compare"
    double_compare :: CDouble -> CDouble -> CInt
foreign import ccall unsafe "strtod"
    c_strtod :: CString -> Ptr CString -> IO CDouble

instance Show Double where
    show x = unsafePerformIO . withCString "%a" $ \fmt -> do
        size <- double_format nullPtr fmt (toFloating x)
        allocaArray0 (fromIntegral size) $ \buf -> do
            double_format buf fmt (toFloating x)
            peekCString buf

instance Read Double where
    readsPrec _ s = unsafePerformIO . withCString s $ \str -> do
        alloca $ \endbuf -> do
            val <- toFloating <$> c_strtod str endbuf
            end <- peek endbuf
            if end == str
                then return []
                else peekCString end >>= \rem -> return [(val, rem)]

instance Eq Double where
    D# x == D# y = x ==## y
    D# x /= D# y = x /=## y

instance Num Double where
    D# x + D# y = D# (x +## y)
    D# x - D# y = D# (x -## y)
    D# x * D# y = D# (x *## y)
    negate (D# x) = D# (negateDouble# x)
    fromInteger = toFloating
    signum      = libmDouble double_signum
    abs         = libmDouble c_fabs

instance Enum Double where
    pred x   = nextafter x (-infinity)
    succ x   = nextafter x infinity
    toEnum   = toFloating
    fromEnum = fromJust . toIntegral

instance Poset Double where
    compare a b = toEnum . fromIntegral $ double_compare a' b' where
        a' = toFloating a
        b' = toFloating b
    D# x <  D# y = x <##  y
    D# x <= D# y = x <=## y
    D# x >= D# y = x >=## y
    D# x >  D# y = x >##  y

instance Sortable Double where
    isOrdered = not . ((== FPNaN) . classify)
    max = libmDouble2 c_fmax
    min = libmDouble2 c_fmin

instance Fractional Double where
    (D# x) / (D# y) = D# (x /## y)
    fromRational = liftM2 (/)
        (fromInteger . numerator)
        (fromInteger . denominator)

-- | Internal function which discards the fractional component of a Double.
-- The results are meaningful only for finite input.
dropFrac :: Double -> Integer
dropFrac (D# x)
    | e >= 0    = s * 2^e
    | otherwise = quot s (2^(negate e))
    where
        (# s, e# #) = decodeDoubleInteger x
        e = I# e#

instance Roundable Double where
    toIntegral x = case classify x of
        FPInfinite -> Nothing
        FPNaN      -> Nothing
        otherwise  -> Just . fromInteger . dropFrac $ x
    floor    = libmDouble c_floor
    ceiling  = libmDouble c_ceil
    truncate = libmDouble c_trunc
    round    = libmDouble c_round

instance Floating Double where
    (D# x) ** (D# y) = D# (x **## y)
    sqrt (D# x) = D# (sqrtDouble# x)
    acos (D# x) = D# (acosDouble# x)
    asin (D# x) = D# (asinDouble# x)
    atan (D# x) = D# (atanDouble# x)
    cos  (D# x) = D# (cosDouble#  x)
    sin  (D# x) = D# (sinDouble#  x)
    tan  (D# x) = D# (tanDouble#  x)
    cosh (D# x) = D# (coshDouble#  x)
    sinh (D# x) = D# (sinhDouble#  x)
    tanh (D# x) = D# (tanhDouble#  x)
    exp  (D# x) = D# (expDouble#  x)
    log  (D# x) = D# (logDouble#  x)
    acosh = libmDouble c_acosh
    asinh = libmDouble c_asinh
    atanh = libmDouble c_atanh

instance RealFloat Double where
    fma       = libmDouble3 c_fma
    copysign  = libmDouble2 c_copysign
    nextafter = libmDouble2 c_nextafter
    fmod      = libmDouble2 c_fmod
    frem      = libmDouble2 c_remainder
    atan2     = libmDouble2 c_atan2
    hypot     = libmDouble2 c_hypot
    cbrt      = libmDouble  c_cbrt
    exp2      = libmDouble  c_exp2
    expm1     = libmDouble  c_expm1
    log10     = libmDouble  c_log10
    log1p     = libmDouble  c_log1p
    log2      = libmDouble  c_log2
    logb      = libmDouble  c_logb
    erf       = libmDouble  c_erf
    erfc      = libmDouble  c_erfc
    lgamma    = libmDouble  c_lgamma
    tgamma    = libmDouble  c_tgamma
    classify  = toEnum . fromIntegral . double_classify . toFloating

    fquotRem x y = unsafePerformIO . alloca $ \quotPtr -> do
        rem  <- c_remquo (toFloating x) (toFloating y) quotPtr
        quot <- peek quotPtr
        return (fromIntegral quot, toFloating rem)