Permalink
Browse files

Port a bunch of code over to blaze-textual for reuse.

  • Loading branch information...
1 parent 2d11e99 commit 758da068b5882bd019fb28bff01162076484c73a @bos committed Apr 28, 2011
Showing with 8 additions and 269 deletions.
  1. +6 −1 Data/Aeson/Encode.hs
  2. +0 −120 Data/Aeson/Encode/Double.hs
  3. +0 −34 Data/Aeson/Encode/Int.hs
  4. +0 −100 Data/Aeson/Encode/Number.hs
  5. +2 −14 aeson.cabal
View
@@ -18,10 +18,11 @@ module Data.Aeson.Encode
import Blaze.ByteString.Builder
import Blaze.ByteString.Builder.Char.Utf8
-import Data.Aeson.Encode.Number (fromNumber)
+import Data.Attoparsec.Number (Number(..))
import Data.Aeson.Types (ToJSON(..), Value(..))
import Data.Monoid (mappend)
import Numeric (showHex)
+import Blaze.Text (double, integral)
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.Map as M
import qualified Data.Text as T
@@ -66,6 +67,10 @@ string s = fromChar '"' `mappend` quote s `mappend` fromChar '"'
| otherwise = fromChar c
where h = showHex (fromEnum c) ""
+fromNumber :: Number -> Builder
+fromNumber (I i) = integral i
+fromNumber (D d) = double d
+
-- | Efficiently serialize a JSON value as a lazy 'L.ByteString'.
encode :: ToJSON a => a -> L.ByteString
encode = toLazyByteString . fromValue . toJSON
View
@@ -1,120 +0,0 @@
-{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-}
-
--- Module: Data.Aeson.Encode.Number
--- Copyright: (c) 2011 MailRank, Inc.
--- License: Apache
--- Maintainer: Bryan O'Sullivan <bos@mailrank.com>
--- Stability: experimental
--- Portability: portable
---
--- Efficiently serialize a Double as a lazy 'L.ByteString'.
-
-module Data.Aeson.Encode.Double
- (
- double
- ) where
-
-import Blaze.ByteString.Builder (Builder, fromByteString)
-import Blaze.ByteString.Builder.Char8 (fromChar)
-import Data.Aeson.Encode.Int (digit, int, minus)
-import Data.ByteString.Char8 ()
-import Data.Monoid (mappend, mconcat, mempty)
-import qualified Data.Vector as V
-
--- The code below is originally from GHC.Float, but has been optimised
--- in quite a few ways.
-
-data T = T [Int] {-# UNPACK #-} !Int
-
-double :: Double -> Builder
-double f
- | isNaN f || isInfinite f = fromByteString "null"
- | f < 0 || isNegativeZero f = minus `mappend` goGeneric (floatToDigits (-f))
- | otherwise = goGeneric (floatToDigits f)
- where
- goGeneric p@(T _ e)
- | e < 0 || e > 7 = goExponent p
- | otherwise = goFixed p
- goExponent (T is e) =
- case is of
- [] -> error "putFormattedFloat"
- [0] -> fromByteString "0.0e0"
- [d] -> digit d `mappend` fromByteString ".0e" `mappend` int (e-1)
- (d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend`
- fromChar 'e' `mappend` int (e-1)
- goFixed (T is e)
- | e <= 0 = fromChar '0' `mappend` fromChar '.' `mappend`
- mconcat (replicate (-e) (fromChar '0')) `mappend`
- digits is
- | otherwise = let g 0 rs = fromChar '.' `mappend` mk0 rs
- g n [] = fromChar '0' `mappend` g (n-1) []
- g n (r:rs) = digit r `mappend` g (n-1) rs
- in g e is
- mk0 [] = fromChar '0'
- mk0 rs = digits rs
-
-digits :: [Int] -> Builder
-digits (d:ds) = digit d `mappend` digits ds
-digits _ = mempty
-{-# INLINE digits #-}
-
-floatToDigits :: Double -> T
-floatToDigits 0 = T [0] 0
-floatToDigits x = T (reverse rds) k
- where
- (f0, e0) = decodeFloat x
- (minExp0, _) = floatRange (undefined::Double)
- p = floatDigits x
- b = floatRadix x
- minExp = minExp0 - p -- the real minimum exponent
- -- Haskell requires that f be adjusted so denormalized numbers
- -- will have an impossibly low exponent. Adjust for this.
- (# f, e #) =
- let n = minExp - e0 in
- if n > 0 then (# f0 `div` (b^n), e0+n #) else (# f0, e0 #)
- (# r, s, mUp, mDn #) =
- if e >= 0
- then let be = b^ e
- in if f == b^(p-1)
- then (# f*be*b*2, 2*b, be*b, b #)
- else (# f*be*2, 2, be, be #)
- else if e > minExp && f == b^(p-1)
- then (# f*b*2, b^(-e+1)*2, b, 1 #)
- else (# f*2, b^(-e)*2, 1, 1 #)
- k = fixup k0
- where
- k0 | b == 2 = (p - 1 + e0) * 3 `div` 10
- -- logBase 10 2 is slightly bigger than 3/10 so the following
- -- will err on the low side. Ignoring the fraction will make
- -- it err even more. Haskell promises that p-1 <= logBase b f
- -- < p.
- | otherwise = ceiling ((log (fromInteger (f+1) :: Double) +
- fromIntegral e * log (fromInteger b)) / log 10)
- fixup n
- | n >= 0 = if r + mUp <= exp10 n * s then n else fixup (n+1)
- | otherwise = if exp10 (-n) * (r + mUp) <= s then n else fixup (n+1)
-
- gen ds !rn !sN !mUpN !mDnN =
- let (dn0, rn') = (rn * 10) `divMod` sN
- mUpN' = mUpN * 10
- mDnN' = mDnN * 10
- !dn = fromInteger dn0
- !dn' = dn + 1
- in case (# rn' < mDnN', rn' + mUpN' > sN #) of
- (# True, False #) -> dn : ds
- (# False, True #) -> dn' : ds
- (# True, True #) -> if rn' * 2 < sN then dn : ds else dn' : ds
- (# False, False #) -> gen (dn:ds) rn' sN mUpN' mDnN'
-
- rds | k >= 0 = gen [] r (s * exp10 k) mUp mDn
- | otherwise = gen [] (r * bk) s (mUp * bk) (mDn * bk)
- where bk = exp10 (-k)
-
-exp10 :: Int -> Integer
-exp10 n
- | n >= 0 && n < maxExpt = V.unsafeIndex expts n
- | otherwise = 10 ^ n
- where expts = V.generate maxExpt (10^)
- {-# NOINLINE expts #-}
- maxExpt = 17
-{-# INLINE exp10 #-}
View
@@ -1,34 +0,0 @@
-{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}
-
--- Module: Data.Aeson.Encode.Int
--- Copyright: (c) 2011 MailRank, Inc.
--- License: Apache
--- Maintainer: Bryan O'Sullivan <bos@mailrank.com>
--- Stability: experimental
--- Portability: portable
---
--- Efficiently serialize an integral JSON value as a lazy 'L.ByteString'.
-
-module Data.Aeson.Encode.Int
- (
- digit
- , int
- , minus
- ) where
-
-import Blaze.ByteString.Builder (Builder, fromWord8)
-import Data.Monoid (mappend)
-
-int :: Int -> Builder
-int i
- | i < 0 = minus `mappend` go (-i)
- | otherwise = go i
- where
- go n | n < 10 = digit n
- | otherwise = go (n `quot` 10) `mappend` digit (n `rem` 10)
-
-digit :: Int -> Builder
-digit n = fromWord8 $! fromIntegral n + 48
-
-minus :: Builder
-minus = fromWord8 45
View
@@ -1,100 +0,0 @@
-{-# LANGUAGE BangPatterns, CPP, MagicHash, UnboxedTuples #-}
-
--- Module: Data.Aeson.Encode.Number
--- Copyright: (c) 2011 MailRank, Inc.
--- License: Apache
--- Maintainer: Bryan O'Sullivan <bos@mailrank.com>
--- Stability: experimental
--- Portability: portable
---
--- Efficiently serialize a numeric JSON value as a lazy 'L.ByteString'.
-
-module Data.Aeson.Encode.Number
- (
- fromNumber
- ) where
-
-import Data.Monoid (mappend, mempty)
-import Data.Attoparsec.Number (Number(..))
-import Data.Aeson.Encode.Double
-import Data.Aeson.Encode.Int
-import Blaze.ByteString.Builder
-import GHC.Base (quotInt, remInt)
-import GHC.Num (quotRemInteger)
-import GHC.Types (Int(..))
-
-#ifdef __GLASGOW_HASKELL__
-# if __GLASGOW_HASKELL__ < 611
-import GHC.Integer.Internals
-# else
-import GHC.Integer.GMP.Internals
-# endif
-#endif
-
-#ifdef INTEGER_GMP
-# define PAIR(a,b) (# a,b #)
-#else
-# define PAIR(a,b) (a,b)
-#endif
-
-fromNumber :: Number -> Builder
-fromNumber (I i) = integer i
-fromNumber (D d) = double d
-
-integer :: Integer -> Builder
-integer (S# i#) = int (I# i#)
-integer i
- | i < 0 = minus `mappend` go (-i)
- | otherwise = go i
- where
- go n | n < maxInt = int (fromInteger n)
- | otherwise = putH (splitf (maxInt * maxInt) n)
-
- splitf p n
- | p > n = [n]
- | otherwise = splith p (splitf (p*p) n)
-
- splith p (n:ns) = case n `quotRemInteger` p of
- PAIR(q,r) | q > 0 -> q : r : splitb p ns
- | otherwise -> r : splitb p ns
- splith _ _ = error "splith: the impossible happened."
-
- splitb p (n:ns) = case n `quotRemInteger` p of
- PAIR(q,r) -> q : r : splitb p ns
- splitb _ _ = []
-
-data T = T !Integer !Int
-
-fstT :: T -> Integer
-fstT (T a _) = a
-
-maxInt :: Integer
-maxDigits :: Int
-T maxInt maxDigits =
- until ((>mi) . (*10) . fstT) (\(T n d) -> T (n*10) (d+1)) (T 10 1)
- where mi = fromIntegral (maxBound :: Int)
-
-putH :: [Integer] -> Builder
-putH (n:ns) = case n `quotRemInteger` maxInt of
- PAIR(x,y)
- | q > 0 -> int q `mappend` pblock r `mappend` putB ns
- | otherwise -> int r `mappend` putB ns
- where q = fromInteger x
- r = fromInteger y
-putH _ = error "putH: the impossible happened"
-
-putB :: [Integer] -> Builder
-putB (n:ns) = case n `quotRemInteger` maxInt of
- PAIR(x,y) -> pblock q `mappend` pblock r `mappend` putB ns
- where q = fromInteger x
- r = fromInteger y
-putB _ = mempty
-
-pblock :: Int -> Builder
-pblock = go maxDigits
- where
- go !d !n
- | d == 1 = digit n
- | otherwise = go (d-1) q `mappend` digit r
- where q = n `quotInt` 10
- r = n `remInt` 10
View
@@ -1,5 +1,5 @@
name: aeson
-version: 0.3.2.4
+version: 0.3.2.5
license: BSD3
license-file: LICENSE
category: Text, Web, JSON
@@ -91,21 +91,17 @@ library
Data.Aeson.Types
other-modules:
- Data.Aeson.Encode.Double
- Data.Aeson.Encode.Int
- Data.Aeson.Encode.Number
Data.Aeson.Functions
build-depends:
attoparsec >= 0.8.5.3,
base == 4.*,
blaze-builder >= 0.2.1.4,
+ blaze-textual,
bytestring,
containers,
deepseq,
- ghc-prim,
hashable,
- integer-gmp,
mtl,
old-locale,
syb,
@@ -120,14 +116,6 @@ library
ghc-options: -Wall
- if impl(ghc >= 6.11)
- cpp-options: -DINTEGER_GMP
- build-depends: integer-gmp >= 0.2 && < 0.3
-
- if impl(ghc >= 6.9) && impl(ghc < 6.11)
- cpp-options: -DINTEGER_GMP
- build-depends: integer >= 0.1 && < 0.2
-
source-repository head
type: git
location: http://github.com/mailrank/aeson

0 comments on commit 758da06

Please sign in to comment.