diff --git a/Blaze/Text.hs b/Blaze/Text.hs new file mode 100644 --- /dev/null +++ b/Blaze/Text.hs @@ -0,0 +1,9 @@ +module Blaze.Text + ( + float + , double + , integral + ) where + +import Blaze.Text.Double +import Blaze.Text.Int diff --git a/Blaze/Text/Double.hs b/Blaze/Text/Double.hs new file mode 100644 --- /dev/null +++ b/Blaze/Text/Double.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} + +-- Module: Blaze.Text.Double +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently serialize a Double as a lazy 'L.ByteString'. + +module Blaze.Text.Double + ( + float + , double + ) where + +#ifdef NATIVE +import Blaze.Text.Double.Native +#else +import Blaze.ByteString.Builder (Builder, fromByteString) +import Data.Double.Conversion.ByteString (toShortest) + +float :: Float -> Builder +float = double . realToFrac + +double :: Double -> Builder +double f = fromByteString (toShortest f) +#endif diff --git a/Blaze/Text/Double/Native.hs b/Blaze/Text/Double/Native.hs new file mode 100644 --- /dev/null +++ b/Blaze/Text/Double/Native.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-} + +-- Module: Blaze.Text.Double.Native +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently serialize a Double as a lazy 'L.ByteString'. + +module Blaze.Text.Double.Native + ( + float + , double + ) where + +import Blaze.ByteString.Builder (Builder, fromByteString) +import Blaze.ByteString.Builder.Char8 (fromChar) +import Blaze.Text.Int (digit, integral, 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 + +float :: Float -> Builder +float = double . realToFrac + +double :: Double -> Builder +double f + | isInfinite f = fromByteString $ + if f > 0 then "Infinity" else "-Infinity" + | f < 0 || isNegativeZero f = minus `mappend` goGeneric (floatToDigits (-f)) + | f >= 0 = goGeneric (floatToDigits f) + | otherwise = fromByteString "NaN" + 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` integral (e-1) + (d:ds) -> digit d `mappend` fromChar '.' `mappend` digits ds `mappend` + fromChar 'e' `mappend` integral (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 #-} diff --git a/Blaze/Text/Int.hs b/Blaze/Text/Int.hs new file mode 100644 --- /dev/null +++ b/Blaze/Text/Int.hs @@ -0,0 +1,163 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings, UnboxedTuples #-} + +-- Module: Blaze.Text.Int +-- Copyright: (c) 2011 MailRank, Inc. +-- License: BSD3 +-- Maintainer: Bryan O'Sullivan +-- Stability: experimental +-- Portability: portable +-- +-- Efficiently serialize an integral value as a lazy 'L.ByteString'. + +module Blaze.Text.Int + ( + digit + , integral + , minus + ) where + +import Blaze.ByteString.Builder +import Blaze.ByteString.Builder.Char8 +import Data.ByteString.Char8 () +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Monoid (mappend, mempty) +import Data.Word (Word, Word8, Word16, Word32, Word64) +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 + +integral :: Integral a => a -> Builder +{-# RULES "integral/Int" integral = bounded :: Int -> Builder #-} +{-# RULES "integral/Int8" integral = bounded :: Int8 -> Builder #-} +{-# RULES "integral/Int16" integral = bounded :: Int16 -> Builder #-} +{-# RULES "integral/Int32" integral = bounded :: Int32 -> Builder #-} +{-# RULES "integral/Int64" integral = bounded :: Int64 -> Builder #-} +{-# RULES "integral/Word" integral = nonNegative :: Word -> Builder #-} +{-# RULES "integral/Word8" integral = nonNegative :: Word8 -> Builder #-} +{-# RULES "integral/Word16" integral = nonNegative :: Word16 -> Builder #-} +{-# RULES "integral/Word32" integral = nonNegative :: Word32 -> Builder #-} +{-# RULES "integral/Word64" integral = nonNegative :: Word64 -> Builder #-} +{-# RULES "integral/Integer" integral = integer :: Integer -> Builder #-} + +-- This definition of the function is here PURELY to be used by ghci +-- and those rare cases where GHC is being invoked without +-- optimization, as otherwise the rewrite rules above should fire. The +-- test for "-0" catches an overflow if we render minBound. +integral i + | i >= 0 = nonNegative i + | toByteString b == "-0" = fromString (show i) + | otherwise = b + where b = minus `mappend` nonNegative (-i) + +bounded :: (Bounded a, Integral a) => a -> Builder +{-# SPECIALIZE bounded :: Int -> Builder #-} +{-# SPECIALIZE bounded :: Int8 -> Builder #-} +{-# SPECIALIZE bounded :: Int16 -> Builder #-} +{-# SPECIALIZE bounded :: Int32 -> Builder #-} +{-# SPECIALIZE bounded :: Int64 -> Builder #-} +bounded i + | i >= 0 = nonNegative i + | i > minBound = minus `mappend` nonNegative (-i) + | otherwise = minus `mappend` + nonNegative (negate (k `quot` 10)) `mappend` + digit (negate (k `rem` 10)) + where k = minBound `asTypeOf` i + +nonNegative :: Integral a => a -> Builder +{-# SPECIALIZE nonNegative :: Int -> Builder #-} +{-# SPECIALIZE nonNegative :: Int8 -> Builder #-} +{-# SPECIALIZE nonNegative :: Int16 -> Builder #-} +{-# SPECIALIZE nonNegative :: Int32 -> Builder #-} +{-# SPECIALIZE nonNegative :: Int64 -> Builder #-} +{-# SPECIALIZE nonNegative :: Word -> Builder #-} +{-# SPECIALIZE nonNegative :: Word8 -> Builder #-} +{-# SPECIALIZE nonNegative :: Word16 -> Builder #-} +{-# SPECIALIZE nonNegative :: Word32 -> Builder #-} +{-# SPECIALIZE nonNegative :: Word64 -> Builder #-} +nonNegative = go + where + go n | n < 10 = digit n + | otherwise = go (n `quot` 10) `mappend` digit (n `rem` 10) + +digit :: Integral a => a -> Builder +digit n = fromWord8 $! fromIntegral n + 48 +{-# INLINE digit #-} + +minus :: Builder +minus = fromWord8 45 + +int :: Int -> Builder +int = integral +{-# INLINE int #-} + +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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2011, MailRank, Inc. + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff --git a/README.markdown b/README.markdown new file mode 100644 --- /dev/null +++ b/README.markdown @@ -0,0 +1,72 @@ +# Welcome to blaze-textual + +blaze-textual is a fast Haskell library for rendering common Haskell +datatypes in text form using the +[blaze-builder](http://hackage.haskell.org/package/blaze-builder) +library. + +# Important note for users of GHCi and Template Haskell + +To achieve excellent performance for rendering floating point numbers, +this package uses the +[double-conversion](http://hackage.haskell.org/package/double-conversion) +package. + +Unfortunately, due to bugs in GHC, some uses of GHCi and Template +Haskell can crash if this package is loaded. + +* [5289: Can't use ghci with a library linked against + libstdc++](http://hackage.haskell.org/trac/ghc/ticket/5289) (fixed + in GHC 7.2.1). + +* [5386: GHCi crashes with SIGFPE when using double-conversion + package](http://hackage.haskell.org/trac/ghc/ticket/5386) (not yet + fixed at the time of writing) + +If you are affected by these problems, you should expect the 5289 +crash to look like this: + + Loading package double-conversion-0.2.0.0 ... can't load .so/.DLL for: stdc++ + +The 5386 crash causes GHCi to die with a floating point exception +(SIGFPE). + +To work around these bugs, this package includes an alternative, +slower, floating point conversion that is written in pure Haskell. +Because it is 10 times slower than the double-conversion package, it +is not the default. + +To use it, reinstall this package by passing the `native` flag to +`cabal`: + + cabal install -fnative + +Afterwards, you will also need to reinstall any downstream packages +that depend on this one, e.g. the [aeson JSON +library](http://hackage.haskell.org/package/aeson): + + cabal install aeson --reinstall + +# Join in! + +We are happy to receive bug reports, fixes, documentation +enhancements, and other improvements. + +Please report bugs via the +[github issue tracker](http://github.com/mailrank/blaze-textual/issues). + +Master [git repository](http://github.com/mailrank/blaze-textual): + +* `git clone git://github.com/mailrank/blaze-textual.git` + +There's also a [Mercurial mirror](http://bitbucket.org/bos/blaze-textual): + +* `hg clone http://bitbucket.org/bos/blaze-textual` + +(You can create and contribute changes using either git or Mercurial.) + +Authors +------- + +This library is written and maintained by Bryan O'Sullivan, +. diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/blaze-textual-native.cabal b/blaze-textual-native.cabal new file mode 100644 --- /dev/null +++ b/blaze-textual-native.cabal @@ -0,0 +1,81 @@ +name: blaze-textual-native +version: 0.2.1 +license: BSD3 +license-file: LICENSE +category: Text +copyright: Copyright 2011 MailRank, Inc. +author: Bryan O'Sullivan +maintainer: Bryan O'Sullivan +stability: experimental +synopsis: Fast rendering of common datatypes +cabal-version: >= 1.8 +homepage: http://github.com/mailrank/blaze-textual +bug-reports: http://github.com/mailrank/blaze-textual/issues +build-type: Simple +description: + A library for efficiently rendering Haskell datatypes to + bytestrings. + . + /Note/: if you use GHCi or Template Haskell, please see the + @README@ file for important details about building this package, + and other packages that depend on it: + + +extra-source-files: + README.markdown + tests/*.hs + +flag developer + description: operate in developer mode + default: False + +flag native + description: use slow native code for double conversion + default: True + +library + exposed-modules: + Blaze.Text + Blaze.Text.Double + Blaze.Text.Int + + if flag(native) + other-modules: Blaze.Text.Double.Native + + build-depends: + base == 4.*, + blaze-builder >= 0.2.1.4, + bytestring, + ghc-prim, + old-locale, + text >= 0.11.0.2, + time, + vector + + if !flag(native) + build-depends: + double-conversion >= 0.2.0.1 + + if flag(developer) + ghc-prof-options: -auto-all + + if flag(native) + cpp-options: -DNATIVE + + ghc-options: -Wall + + if impl(ghc >= 6.11) + cpp-options: -DINTEGER_GMP + build-depends: integer-gmp >= 0.2 && < 0.4 + + 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/blaze-textual + +source-repository head + type: mercurial + location: http://bitbucket.org/bos/blaze-textual diff --git a/tests/QC.hs b/tests/QC.hs new file mode 100644 --- /dev/null +++ b/tests/QC.hs @@ -0,0 +1,46 @@ +module Main (main) where + +import Blaze.ByteString.Builder (Builder, toByteString) +import Blaze.Text (double, float, integral) +import Data.Int (Int8, Int16, Int32, Int64) +import Data.Word (Word, Word8, Word16, Word32, Word64) +import Test.Framework (Test, defaultMain, testGroup) +import Test.Framework.Providers.QuickCheck2 (testProperty) +import qualified Data.ByteString.Char8 as B + +-- Integral values should be rendered exactly as Haskell does. +t_integral :: Integral a => a -> a -> Bool +t_integral _ i = toByteString (integral i) == B.pack (show i) + +-- This package doesn't render floating point numbers exactly as +-- Haskell does, but the numbers it renders should read back exactly. +-- So that's the property we check. +t_real :: (RealFloat a, Read a) => (a -> Builder) -> a -> a -> Bool +t_real f i j = + case read (B.unpack . toByteString . f $ ij) of + r | isNaN r -> isNaN ij + | isInfinite r -> isInfinite ij && signum r == signum ij + | otherwise -> r == ij + where ij = i / j + +main :: IO () +main = defaultMain tests + +tests :: [Test] +tests = [ + testGroup "int" [ testProperty "Integer" $ t_integral (undefined::Integer) + , testProperty "Int" $ t_integral (undefined::Int) + , testProperty "Int8" $ t_integral (undefined::Int8) + , testProperty "Int16" $ t_integral (undefined::Int16) + , testProperty "Int32" $ t_integral (undefined::Int32) + , testProperty "Int64" $ t_integral (undefined::Int64) + ] + , testGroup "word" [ testProperty "Word" $ t_integral (undefined::Word) + , testProperty "Word8" $ t_integral (undefined::Word8) + , testProperty "Word16" $ t_integral (undefined::Word16) + , testProperty "Word32" $ t_integral (undefined::Word32) + , testProperty "Word64" $ t_integral (undefined::Word64) + ] + , testProperty "Double" $ t_real double + , testProperty "Float" $ t_real float + ]