diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,6 +5,12 @@ `small-bytearray-builder` is now just a compatibility shim to ease the migration process. +## 0.3.8.0 -- 2020-??-?? + +* Fix `doubleDec`, which was encoding small numbers incorrectly. +* Add `runByteString` for producing `ByteString` from bounded builders. +* Correct the required length calculation for json string encoding. + ## 0.3.7.0 -- 2020-11-06 * Fix build error in test suite. diff --git a/bytebuild.cabal b/bytebuild.cabal --- a/bytebuild.cabal +++ b/bytebuild.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: bytebuild -version: 0.3.7.0 +version: 0.3.8.0 synopsis: Serialize to a small byte arrays description: This is similar to the builder facilities provided by @@ -44,7 +44,7 @@ Data.Bytes.Chunks build-depends: , base >=4.12.0.0 && <5 - , byteslice >=0.2 && <0.3 + , byteslice >=0.2.5 && <0.3 , bytestring >=0.10.8.2 && <0.11 , integer-logarithms >=1.0.3 && <1.1 , natural-arithmetic >=0.1 && <0.2 @@ -60,6 +60,7 @@ ghc-options: -Wall -O2 hs-source-dirs: src default-language: Haskell2010 + c-sources: cbits/bytebuild_custom.c test-suite test default-language: Haskell2010 diff --git a/cbits/bytebuild_custom.c b/cbits/bytebuild_custom.c new file mode 100644 --- /dev/null +++ b/cbits/bytebuild_custom.c @@ -0,0 +1,11 @@ +#include "Rts.h" +#include +#include + +HsInt bytebuild_paste_double(char *s0, HsInt off, double n) { + char* start = s0 + off; + memset(start,0,32); + sprintf(s0 + off,"%.14g", n); + size_t r = strlen(start); + return (HsInt)r; +} diff --git a/src/Data/Bytes/Builder.hs b/src/Data/Bytes/Builder.hs --- a/src/Data/Bytes/Builder.hs +++ b/src/Data/Bytes/Builder.hs @@ -345,7 +345,7 @@ (# sX, bufX, 0#, 4080#, Mutable buf0 off0 cs0 #) _ -> (# s0, buf0, off0, len0, cs0 #) in case f buf1 off1 s1 of - (# s2, off2 #) -> (# s2, buf1, off2, len1 -# (off2 -# off1), cs1 #) + (# s2, _ #) -> (# s2, buf1, off1 +# 1#, len1 -# 1#, cs1 #) -- | Create a builder from an unsliced byte sequence. Implemented with 'bytes'. byteArray :: ByteArray -> Builder @@ -669,7 +669,9 @@ pure (doffRes + 1) where slen0 = I# slen0# - reqLen = (2 * slen0) + 2 + -- We multiply by 6 because, in the worst case, everything might be in the + -- unprintable ASCII range. The plus 2 is for the quotes on the ends. + reqLen = (6 * slen0) + 2 -- | Constructor for 'Builder' that works on a function with lifted -- arguments instead of unlifted ones. This is just as unsafe as the diff --git a/src/Data/Bytes/Builder/Bounded.hs b/src/Data/Bytes/Builder/Bounded.hs --- a/src/Data/Bytes/Builder/Bounded.hs +++ b/src/Data/Bytes/Builder/Bounded.hs @@ -9,6 +9,7 @@ {-# language TypeApplications #-} {-# language TypeOperators #-} {-# language UnboxedTuples #-} +{-# language UnliftedFFITypes #-} -- | The functions in this module are explict about the maximum number -- of bytes they require. @@ -17,6 +18,7 @@ Builder -- * Execute , run + , runByteString , pasteGrowST -- * Combine , empty @@ -103,9 +105,10 @@ import Arithmetic.Types (type (<=), type (:=:)) import Control.Monad.Primitive (primitive_) import Control.Monad.ST (ST) -import Control.Monad.ST.Run (runByteArrayST) +import Control.Monad.ST.Run (runByteArrayST,runIntByteArrayST) import Data.Bits import Data.Bytes.Builder.Bounded.Unsafe (Builder(..)) +import Data.ByteString (ByteString) import Data.Char (ord) import Data.Primitive (MutableByteArray(..),ByteArray,writeByteArray) import Data.Primitive (readByteArray,newByteArray,unsafeFreezeByteArray) @@ -113,13 +116,16 @@ import Data.WideWord (Word128(Word128),Word256(Word256)) import GHC.Exts import GHC.Int (Int64(I64#),Int32(I32#),Int16(I16#),Int8(I8#)) +import GHC.IO (unsafeIOToST) import GHC.ST (ST(ST)) import GHC.TypeLits (type (+)) import GHC.Word (Word8(W8#),Word16(W16#),Word32(W32#),Word64(W64#)) +import Data.Bytes.Types (Bytes(Bytes)) import qualified Arithmetic.Lte as Lte import qualified Arithmetic.Nat as Nat import qualified Arithmetic.Types as Arithmetic +import qualified Data.Bytes as Bytes import qualified Data.Bytes.Builder.Bounded.Unsafe as Unsafe import qualified Data.Primitive as PM @@ -137,6 +143,22 @@ shrinkMutableByteArray arr len unsafeFreezeByteArray arr +-- | Variant of 'run' that puts the result in a pinned buffer and +-- packs it up in a 'ByteString'. +runByteString :: + Arithmetic.Nat n + -> Builder n -- ^ Builder + -> ByteString +{-# inline runByteString #-} +runByteString n b = + let (finalLen,r) = runIntByteArrayST $ do + arr <- PM.newPinnedByteArray (Nat.demote n) + len <- Unsafe.pasteST b arr 0 + shrinkMutableByteArray arr len + arr' <- unsafeFreezeByteArray arr + pure (len,arr') + in Bytes.pinnedToByteString (Bytes r 0 finalLen) + -- | Paste the builder into the byte array starting at offset zero. -- This reallocates the byte array if it cannot accomodate the builder, -- growing it by the minimum amount necessary. @@ -1032,100 +1054,12 @@ -- inaccurate. This is very visible when encoding a number like 2.25, which -- is perfectly represented as an IEEE 754 floating point number but is goofed -- up by this function. --- If you modify this function, please take a took at the resulting core. --- It currently performs no boxing at all, and it would be nice to keep --- it that way. doubleDec# :: forall s. Double# -> MutableByteArray# s -> Int# -> State# s -> (# State# s, Int# #) -{-# noinline doubleDec# #-} -doubleDec# d# marr# off# s0 = unIntST s0 $ do - let marr = MutableByteArray marr# - let d0 = D# d# - let off0 = I# off# - if d0 == 0 - then do - writeByteArray marr off0 (c2w '0') - pure (off0 + 1) - else do - let neg = d0 < 0 - off1 <- if neg - then do - writeByteArray marr off0 (c2w '-') - pure (off0 + 1) - else pure off0 - let d1 = abs d0 - let mag0 = floor (logBase10 d1) :: Int - let useExp = (mag0 >= 14 || (neg && mag0 >= 9) || mag0 <= (-9)) - -- This straightforward adaptation of the C code is awkward - -- in Haskell. Binding the triple where mag1 might not even - -- get used is strange. - let !(!d2,!mag1,!mag0A) = if useExp - then - let mag0' = if mag0 < 0 then mag0 - 1 else mag0 - in (d1 / (10.0 ** fromIntegral @Int @Double mag0'), mag0', 0) - else (d1,0,mag0) - let mag0B = if mag0A < 1 then 0 else mag0A - let goNum :: Double -> Int -> Int -> ST s Int - goNum !dA0 !mag !offA0 = if (dA0 > doublePrecision || mag >= 0) - then do - let weight = 10.0 ** (fromIntegral @Int @Double mag) - -- We should actually check weight with isinf here, - -- but we do not. - (dA1,offA1) <- if weight > 0 - then do - -- TODO: use a better floor function - let digit = ((floor :: Double -> Int) (dA0 / weight)) - let discard = fromIntegral @Int @Double digit * weight - writeByteArray marr offA0 - (fromIntegral @Int @Word8 (digit + ord '0')) - pure (dA0 - discard,offA0 + 1) - else pure (dA0,offA0) - offA2 <- if mag == 0 && dA1 > 0 - then do - writeByteArray marr offA1 (c2w '.') - pure (offA1 + 1) - else pure offA1 - goNum dA1 (mag - 1) offA2 - else pure offA0 - !off2 <- goNum d2 mag0B off1 - off3 <- if useExp - then do - writeByteArray marr off2 (c2w 'e') - !mag2 <- if mag1 > 0 - then do - writeByteArray marr (off2 + 1) (c2w '+') - pure mag1 - else do - writeByteArray marr (off2 + 1) (c2w '-') - pure (-mag1) - let goMag !mag !off = if mag > 0 - then do - let (q,r) = quotRem mag 10 - writeByteArray marr off (fromIntegral @Int @Word8 (ord '0' + r)) - goMag q (off + 1) - else pure off - !off3 <- goMag mag2 (off2 + 2) - reverseBytes marr (off2 + 2) (off3 - 1) - pure off3 - else pure off2 - pure off3 - -doublePrecision :: Double -doublePrecision = 0.00000000000001 - -unIntST :: State# s -> ST s Int -> (# State# s, Int# #) -{-# inline unIntST #-} -unIntST s0 (ST f) = case f s0 of - (# s1, I# i #) -> (# s1, i #) - --- This is slightly inaccurate. I think this can actually cause --- problems in some situations. The log10 function from C would --- be better. The inaccuracy here cause the logarithm to be slightly --- larger than it should be. There might actually be a simple way to --- fix this by just using recursion to compute it. We just floor the --- result anyway. Hmm... -logBase10 :: Double -> Double -logBase10 d = log d / 2.30258509299 +doubleDec# d# marr# off# s0 = + case unsafeIOToST (c_paste_double marr# off# d#) of + ST f -> case f s0 of + (# s1, I# r #) -> (# s1, r #) -- Based on C code from https://stackoverflow.com/a/5558614 -- For numbers less than 1073741829, this gives a correct answer. @@ -1134,3 +1068,7 @@ unsafeWordToWord8 :: Word -> Word8 unsafeWordToWord8 (W# w) = W8# w + +foreign import ccall unsafe "bytebuild_paste_double" c_paste_double :: + MutableByteArray# s -> Int# -> Double# -> IO Int + diff --git a/src/Data/Bytes/Builder/Unsafe.hs b/src/Data/Bytes/Builder/Unsafe.hs --- a/src/Data/Bytes/Builder/Unsafe.hs +++ b/src/Data/Bytes/Builder/Unsafe.hs @@ -209,7 +209,7 @@ s1 -> copyReverseCommits# marr off cs s1 -- | Create a builder from a cons-list of 'Char'. These --- are be UTF-8 encoded. +-- must be UTF-8 encoded. stringUtf8 :: String -> Builder {-# inline stringUtf8 #-} stringUtf8 cs = Builder (goString cs) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,4 +1,5 @@ {-# language BangPatterns #-} +{-# language NumericUnderscores #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} {-# language OverloadedStrings #-} @@ -128,7 +129,7 @@ , THU.testCase "doubleDec-D" $ pack ("-42") @=? runConcat 1 (doubleDec (-42)) , THU.testCase "doubleDec-E" $ - pack ("-8.88888888888888e+14") @=? runConcat 1 (doubleDec (-888888888888888.8888888)) + AsciiByteArray (pack ("-8.8888888888889e+14")) @=? AsciiByteArray (runConcat 1 (doubleDec (-888888888888888.8888888))) , THU.testCase "doubleDec-F" $ pack ("42") @=? runConcat 1 (doubleDec 42) , THU.testCase "doubleDec-G" $ @@ -141,6 +142,18 @@ pack ("999999999") @=? runConcat 1 (doubleDec 999999999) , THU.testCase "doubleDec-K" $ pack ("-99999999") @=? runConcat 1 (doubleDec (-99999999)) + , THU.testCase "doubleDec-L" $ + AsciiByteArray (pack ("6.6666666666667e-12")) @=? AsciiByteArray (runConcat 1 (doubleDec (2 / 300_000_000_000))) + , THU.testCase "doubleDec-M" $ + AsciiByteArray (pack ("6.6666666666667e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 6.666666666666667e-10)) + , THU.testCase "doubleDec-N" $ + AsciiByteArray (pack ("5e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 5.0e-10)) + , THU.testCase "doubleDec-O" $ + AsciiByteArray (pack ("1.6666666666667e-10")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.6666666666666669e-10)) + , THU.testCase "doubleDec-P" $ + AsciiByteArray (pack ("1e-09")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.0e-9)) + , THU.testCase "doubleDec-Q" $ + AsciiByteArray (pack ("1e-08")) @=? AsciiByteArray (runConcat 1 (doubleDec 1.0e-8)) , THU.testCase "shortTextJsonString-A" $ pack ("\"hello\"") @=? runConcat 1 (shortTextJsonString "hello") , THU.testCase "shortTextJsonString-B" $ @@ -315,6 +328,15 @@ c2w :: Char -> Word8 c2w = fromIntegral . ord + +-- Just a wrapper with a show instance that displays as ascii when possible. +newtype AsciiByteArray = AsciiByteArray ByteArray + deriving (Eq) + +instance Show AsciiByteArray where + show (AsciiByteArray b) = if Bytes.all (\w -> w >= 32 && w < 127) (Bytes.fromByteArray b) + then Bytes.toLatinString (Bytes.fromByteArray b) + else show (show b) instance Arbitrary Word128 where arbitrary = liftA2 Word128 TQC.arbitrary TQC.arbitrary