@@ -0,0 +1,99 @@
1+{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-}
2+
3+-- Module: Data.Aeson.Encode.Number
4+-- Copyright: (c) 2011 MailRank, Inc.
5+-- License: Apache
6+-- Maintainer: Bryan O'Sullivan <bos@mailrank.com>
7+-- Stability: experimental
8+-- Portability: portable
9+--
10+-- Efficiently serialize a Double as a lazy 'L.ByteString'.
11+
12+module Data.Aeson.Encode.Double
13+ (
14+ double
15+ ) where
16+
17+import GHC.Float
18+
19+import Data.ByteString.Char8 ()
20+import Data.Monoid
21+import Data.Aeson.Encode.Int
22+import Blaze.ByteString.Builder
23+import Blaze.ByteString.Builder.Char8
24+
25+double :: Double -> Builder
26+double = showpGFloat Nothing
27+
28+-- | Show a signed RealFloat value using decimal notation when the
29+-- absolute value lies between 0.1 and 9,999,999, and scientific
30+-- notation otherwise. The optional integer can be used to specify
31+-- precision.
32+showpGFloat :: RealFloat a => Maybe Int -> a -> Builder
33+showpGFloat = putFormattedFloat FFGeneric
34+
35+-- | Show a signed RealFloat value using decimal notation. The optional
36+-- integer can be used to specify precision.
37+showpFFloat :: RealFloat a => Maybe Int -> a -> Builder
38+showpFFloat = putFormattedFloat FFFixed
39+
40+-- | Show a signed RealFloat value using scientific (exponential) notation.
41+-- The optional integer can be used to specify precision.
42+showpEFloat :: RealFloat a => Maybe Int -> a -> Builder
43+showpEFloat = putFormattedFloat FFExponent
44+
45+putFormattedFloat :: RealFloat a => FFFormat -> Maybe Int -> a -> Builder
46+putFormattedFloat fmt decs f
47+ | isNaN f = fromChar 'N' `mappend` fromChar 'a' `mappend` fromChar 'N'
48+ | isInfinite f = fromByteString (if f < 0 then "-Infinity" else "Infinity")
49+ | f < 0 || isNegativeZero f = fromChar '-' `mappend` go fmt (floatToDigits (toInteger base) (-f))
50+ | otherwise = go fmt (floatToDigits (toInteger base) f)
51+ where
52+ base = 10
53+
54+ go FFGeneric p@(_,e)
55+ | e < 0 || e > 7 = go FFExponent p
56+ | otherwise = go FFFixed p
57+ go FFExponent (is, e) =
58+ case decs of
59+ Nothing -> case is of
60+ [] -> error "putFormattedFloat"
61+ [0] -> fromByteString "0.0e0"
62+ [d] -> digit d `mappend` fromByteString ".0e" `mappend` int (e-1)
63+ (d:ds) -> digit d `mappend` fromChar '.' `mappend` mconcat (map digit ds)
64+ `mappend` fromChar 'e' `mappend` int (e-1)
65+ Just dec ->
66+ let dec' = max dec 1 in
67+ case is of
68+ [0] -> fromChar '0' `mappend` fromChar '.' `mappend` mconcat (replicate dec' (fromChar '0'))
69+ `mappend` fromChar 'e' `mappend` fromChar '0'
70+ _ ->
71+ let (ei, is') = roundTo base (dec'+1) is
72+ (d:ds) = if ei > 0 then init is' else is'
73+ in digit d `mappend` fromChar '.' `mappend` mconcat (map digit ds)
74+ `mappend` fromChar 'e' `mappend` int (e - 1 + ei)
75+ go FFFixed (is, e) = case decs of
76+ Nothing
77+ | e <= 0 -> fromChar '0' `mappend` fromChar '.' `mappend` mconcat (replicate (-e) (fromChar '0'))
78+ `mappend` mconcat (map digit is)
79+ | otherwise -> let g 0 rs = fromChar '.' `mappend` mk0 rs
80+ g n [] = fromChar '0' `mappend` g (n-1) []
81+ g n (r:rs) = digit r `mappend` g (n-1) rs
82+ in g e is
83+ Just dec ->
84+ let dec' = max dec 0 in
85+ if e >= 0 then
86+ let (ei, is') = roundTo base (dec' + e) is
87+ (ls,rs) = splitAt (e+ei) is'
88+ in if null ls
89+ then mk0 ls
90+ else mk0 ls `mappend` (fromChar '.' `mappend` mconcat (map digit rs))
91+ else
92+ let (ei, is') = roundTo base dec' (replicate (-e) 0 ++ is)
93+ d:ds = if ei > 0 then is' else 0:is'
94+ in if null ds
95+ then digit d
96+ else digit d `mappend` (fromChar '.' `mappend` mconcat (map digit ds))
97+
98+ mk0 [] = fromChar '0'
99+ mk0 rs = mconcat (map digit rs)