-- ---------------------------------------------------------------------------
-- |
-- Module      : Text.Show.ByteString.Float
-- Copyright   : (c) 2008 Dan Doel
-- Maintainer  : Dan Doel
-- Stability   : Experimental
-- Portability : Non-portable (magic hash)
--
-- Putting floating point values.
--
-- The code in this module is heavily based on GHC.Float

module Text.Show.ByteString.Float where

import GHC.Float

import Control.Monad

import Data.Binary

import Text.Show.ByteString.Util
import Text.Show.ByteString.Int

-- | Show a signed RealFloat value using decimal notation when the
-- absolute value lies between 0.1 and 9,999,999, and scientific
-- notation otherwise. The optional integer can be used to specify
-- precision.
showpGFloat :: RealFloat a => Maybe Int -> a -> Put
showpGFloat :: Maybe Int -> a -> Put
showpGFloat = FFFormat -> Maybe Int -> a -> Put
forall a. RealFloat a => FFFormat -> Maybe Int -> a -> Put
putFormattedFloat FFFormat
FFGeneric

-- | Show a signed RealFloat value using decimal notation. The optional
-- integer can be used to specify precision.
showpFFloat :: RealFloat a => Maybe Int -> a -> Put
showpFFloat :: Maybe Int -> a -> Put
showpFFloat = FFFormat -> Maybe Int -> a -> Put
forall a. RealFloat a => FFFormat -> Maybe Int -> a -> Put
putFormattedFloat FFFormat
FFFixed

-- | Show a signed RealFloat value using scientific (exponential) notation.
-- The optional integer can be used to specify precision.
showpEFloat :: RealFloat a => Maybe Int -> a -> Put
showpEFloat :: Maybe Int -> a -> Put
showpEFloat = FFFormat -> Maybe Int -> a -> Put
forall a. RealFloat a => FFFormat -> Maybe Int -> a -> Put
putFormattedFloat FFFormat
FFExponent

putFormattedFloat :: RealFloat a => FFFormat -> Maybe Int -> a -> Put
putFormattedFloat :: FFFormat -> Maybe Int -> a -> Put
putFormattedFloat FFFormat
fmt Maybe Int
decs a
f
  | a -> Bool
forall a. RealFloat a => a -> Bool
isNaN a
f                   = Char -> Put
putAscii Char
'N' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'a' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'N'
  | a -> Bool
forall a. RealFloat a => a -> Bool
isInfinite a
f              = String -> Put
putAsciiStr (if a
f a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 then String
"-Infinity" else String
"Infinity")
  | a
f a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
0 Bool -> Bool -> Bool
|| a -> Bool
forall a. RealFloat a => a -> Bool
isNegativeZero a
f = Char -> Put
putAscii Char
'-' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FFFormat -> ([Int], Int) -> Put
go FFFormat
fmt (Integer -> a -> ([Int], Int)
forall a. RealFloat a => Integer -> a -> ([Int], Int)
floatToDigits (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
base) (-a
f))
  | Bool
otherwise                 = FFFormat -> ([Int], Int) -> Put
go FFFormat
fmt (Integer -> a -> ([Int], Int)
forall a. RealFloat a => Integer -> a -> ([Int], Int)
floatToDigits (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
base) a
f)
 where
 base :: Int
base = Int
10

 go :: FFFormat -> ([Int], Int) -> Put
go FFFormat
FFGeneric p :: ([Int], Int)
p@([Int]
_,Int
e)
   | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 Bool -> Bool -> Bool
|| Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
7 = FFFormat -> ([Int], Int) -> Put
go FFFormat
FFExponent ([Int], Int)
p
   | Bool
otherwise      = FFFormat -> ([Int], Int) -> Put
go FFFormat
FFFixed    ([Int], Int)
p
 go FFFormat
FFExponent ([Int]
is, Int
e) =
   case Maybe Int
decs of
     Maybe Int
Nothing -> case [Int]
is of
       []     -> String -> Put
forall a. HasCallStack => String -> a
error String
"putFormattedFloat"
       [Int
0]    -> String -> Put
putAsciiStr String
"0.0e0"
       [Int
d]    -> Int -> Put
unsafePutDigit Int
d Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> String -> Put
putAsciiStr String
".0e" Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Put
showpInt (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
       (Int
d:[Int]
ds) -> Int -> Put
unsafePutDigit Int
d Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'.' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> Put
unsafePutDigit [Int]
ds
                                  Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'e' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Put
showpInt (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
     Just Int
dec ->
       let dec' :: Int
dec' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
dec Int
1 in
       case [Int]
is of
         [Int
0] -> Char -> Put
putAscii Char
'0' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'.' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Put -> Put
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
dec' (Char -> Put
putAscii Char
'0')
                  Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'e' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'0'
         [Int]
_   ->
           let (Int
ei, [Int]
is') = Int -> Int -> [Int] -> (Int, [Int])
roundTo Int
base (Int
dec'Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) [Int]
is
               (Int
d:[Int]
ds)    = if Int
ei Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [Int] -> [Int]
forall a. [a] -> [a]
init [Int]
is' else [Int]
is'
           in Int -> Put
unsafePutDigit Int
d Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'.' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> Put
unsafePutDigit [Int]
ds
                Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'e' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Put
showpInt (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
ei)
 go FFFormat
FFFixed ([Int]
is, Int
e) = case Maybe Int
decs of
   Maybe Int
Nothing
     | Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
0    -> Char -> Put
putAscii Char
'0' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Char -> Put
putAscii Char
'.' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> Put -> Put
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ (-Int
e) (Char -> Put
putAscii Char
'0')
                      Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> Put
unsafePutDigit [Int]
is
     | Bool
otherwise -> let g :: a -> [Int] -> Put
g a
0 [Int]
rs     = Char -> Put
putAscii Char
'.' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [Int] -> Put
mk0 [Int]
rs
                        g a
n []     = Char -> Put
putAscii Char
'0' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> [Int] -> Put
g (a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1) []
                        g a
n (Int
r:[Int]
rs) = Int -> Put
unsafePutDigit Int
r Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> a -> [Int] -> Put
g (a
na -> a -> a
forall a. Num a => a -> a -> a
-a
1) [Int]
rs
                    in Int -> [Int] -> Put
forall a. (Eq a, Num a) => a -> [Int] -> Put
g Int
e [Int]
is
   Just Int
dec ->
     let dec' :: Int
dec' = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
dec Int
0 in
     if Int
e Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 then
       let (Int
ei, [Int]
is') = Int -> Int -> [Int] -> (Int, [Int])
roundTo Int
base (Int
dec' Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
e) [Int]
is
           ([Int]
ls,[Int]
rs)   = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
ei) [Int]
is'
       in [Int] -> Put
mk0 [Int]
ls Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
rs) (Char -> Put
putAscii Char
'.' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> Put
unsafePutDigit [Int]
rs)
     else
       let (Int
ei, [Int]
is') = Int -> Int -> [Int] -> (Int, [Int])
roundTo Int
base Int
dec' (Int -> Int -> [Int]
forall a. Int -> a -> [a]
replicate (-Int
e) Int
0 [Int] -> [Int] -> [Int]
forall a. [a] -> [a] -> [a]
++ [Int]
is)
           Int
d:[Int]
ds      = if Int
ei Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then [Int]
is' else Int
0Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
:[Int]
is'
       in Int -> Put
unsafePutDigit Int
d Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Bool -> Put -> Put
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Int] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
ds) (Char -> Put
putAscii Char
'.' Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> Put
unsafePutDigit [Int]
ds)

 mk0 :: [Int] -> Put
mk0 [] = Char -> Put
putAscii Char
'0'
 mk0 [Int]
rs = (Int -> Put) -> [Int] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Int -> Put
unsafePutDigit [Int]
rs