mason (empty) → 0
raw patch · 7 files changed
+1417/−0 lines, 7 filesdep +basedep +bytestringdep +ghc-primsetup-changed
Dependencies added: base, bytestring, ghc-prim, integer-gmp, network, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- cbits/dtoa.c +365/−0
- mason.cabal +30/−0
- src/Mason/Builder.hs +523/−0
- src/Mason/Builder/Internal.hs +462/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for mason++## 0 -- 2019-12-05++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Fumiaki Kinoshita++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * 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.++ * Neither the name of Fumiaki Kinoshita nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND 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 COPYRIGHT+OWNER 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cbits/dtoa.c view
@@ -0,0 +1,365 @@+/*+Copyright https://github.com/juj++Licensed under the Apache License, Version 2.0 (the "License");+you may not use this file except in compliance with the License.+You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++Unless required by applicable law or agreed to in writing, software+distributed under the License is distributed on an "AS IS" BASIS,+WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+See the License for the specific language governing permissions and+limitations under the License.++*/+// modified version of https://github.com/juj/MathGeoLib/blob/master/src/Math/grisu3.c+/* This file is part of an implementation of the "grisu3" double to string+ conversion algorithm described in the research paper+ "Printing Floating-Point Numbers Quickly And Accurately with Integers"+ by Florian Loitsch, available at+ http://www.cs.tufts.edu/~nr/cs257/archive/florian-loitsch/printf.pdf */++#include <stdint.h> // uint64_t etc.+#include <assert.h> // assert+#include <math.h> // ceil+#include <stdio.h> // sprintf++#ifdef _MSC_VER+#pragma warning(disable : 4204) // nonstandard extension used : non-constant aggregate initializer+#endif++#define D64_SIGN 0x8000000000000000ULL+#define D64_EXP_MASK 0x7FF0000000000000ULL+#define D64_FRACT_MASK 0x000FFFFFFFFFFFFFULL+#define D64_IMPLICIT_ONE 0x0010000000000000ULL+#define D64_EXP_POS 52+#define D64_EXP_BIAS 1075+#define DIYFP_FRACT_SIZE 64+#define D_1_LOG2_10 0.30102999566398114 // 1 / lg(10)+#define MIN_TARGET_EXP -60+#define MASK32 0xFFFFFFFFULL++#define CAST_U64(d) (*(uint64_t*)&d)+#define MIN(x,y) ((x) <= (y) ? (x) : (y))+#define MAX(x,y) ((x) >= (y) ? (x) : (y))++#define MIN_CACHED_EXP -348+#define CACHED_EXP_STEP 8++typedef struct diy_fp+{+ uint64_t f;+ int e;+} diy_fp;++typedef struct power+{+ uint64_t fract;+ int16_t b_exp, d_exp;+} power;++static const power pow_cache[] =+{+ { 0xfa8fd5a0081c0288ULL, -1220, -348 },+ { 0xbaaee17fa23ebf76ULL, -1193, -340 },+ { 0x8b16fb203055ac76ULL, -1166, -332 },+ { 0xcf42894a5dce35eaULL, -1140, -324 },+ { 0x9a6bb0aa55653b2dULL, -1113, -316 },+ { 0xe61acf033d1a45dfULL, -1087, -308 },+ { 0xab70fe17c79ac6caULL, -1060, -300 },+ { 0xff77b1fcbebcdc4fULL, -1034, -292 },+ { 0xbe5691ef416bd60cULL, -1007, -284 },+ { 0x8dd01fad907ffc3cULL, -980, -276 },+ { 0xd3515c2831559a83ULL, -954, -268 },+ { 0x9d71ac8fada6c9b5ULL, -927, -260 },+ { 0xea9c227723ee8bcbULL, -901, -252 },+ { 0xaecc49914078536dULL, -874, -244 },+ { 0x823c12795db6ce57ULL, -847, -236 },+ { 0xc21094364dfb5637ULL, -821, -228 },+ { 0x9096ea6f3848984fULL, -794, -220 },+ { 0xd77485cb25823ac7ULL, -768, -212 },+ { 0xa086cfcd97bf97f4ULL, -741, -204 },+ { 0xef340a98172aace5ULL, -715, -196 },+ { 0xb23867fb2a35b28eULL, -688, -188 },+ { 0x84c8d4dfd2c63f3bULL, -661, -180 },+ { 0xc5dd44271ad3cdbaULL, -635, -172 },+ { 0x936b9fcebb25c996ULL, -608, -164 },+ { 0xdbac6c247d62a584ULL, -582, -156 },+ { 0xa3ab66580d5fdaf6ULL, -555, -148 },+ { 0xf3e2f893dec3f126ULL, -529, -140 },+ { 0xb5b5ada8aaff80b8ULL, -502, -132 },+ { 0x87625f056c7c4a8bULL, -475, -124 },+ { 0xc9bcff6034c13053ULL, -449, -116 },+ { 0x964e858c91ba2655ULL, -422, -108 },+ { 0xdff9772470297ebdULL, -396, -100 },+ { 0xa6dfbd9fb8e5b88fULL, -369, -92 },+ { 0xf8a95fcf88747d94ULL, -343, -84 },+ { 0xb94470938fa89bcfULL, -316, -76 },+ { 0x8a08f0f8bf0f156bULL, -289, -68 },+ { 0xcdb02555653131b6ULL, -263, -60 },+ { 0x993fe2c6d07b7facULL, -236, -52 },+ { 0xe45c10c42a2b3b06ULL, -210, -44 },+ { 0xaa242499697392d3ULL, -183, -36 },+ { 0xfd87b5f28300ca0eULL, -157, -28 },+ { 0xbce5086492111aebULL, -130, -20 },+ { 0x8cbccc096f5088ccULL, -103, -12 },+ { 0xd1b71758e219652cULL, -77, -4 },+ { 0x9c40000000000000ULL, -50, 4 },+ { 0xe8d4a51000000000ULL, -24, 12 },+ { 0xad78ebc5ac620000ULL, 3, 20 },+ { 0x813f3978f8940984ULL, 30, 28 },+ { 0xc097ce7bc90715b3ULL, 56, 36 },+ { 0x8f7e32ce7bea5c70ULL, 83, 44 },+ { 0xd5d238a4abe98068ULL, 109, 52 },+ { 0x9f4f2726179a2245ULL, 136, 60 },+ { 0xed63a231d4c4fb27ULL, 162, 68 },+ { 0xb0de65388cc8ada8ULL, 189, 76 },+ { 0x83c7088e1aab65dbULL, 216, 84 },+ { 0xc45d1df942711d9aULL, 242, 92 },+ { 0x924d692ca61be758ULL, 269, 100 },+ { 0xda01ee641a708deaULL, 295, 108 },+ { 0xa26da3999aef774aULL, 322, 116 },+ { 0xf209787bb47d6b85ULL, 348, 124 },+ { 0xb454e4a179dd1877ULL, 375, 132 },+ { 0x865b86925b9bc5c2ULL, 402, 140 },+ { 0xc83553c5c8965d3dULL, 428, 148 },+ { 0x952ab45cfa97a0b3ULL, 455, 156 },+ { 0xde469fbd99a05fe3ULL, 481, 164 },+ { 0xa59bc234db398c25ULL, 508, 172 },+ { 0xf6c69a72a3989f5cULL, 534, 180 },+ { 0xb7dcbf5354e9beceULL, 561, 188 },+ { 0x88fcf317f22241e2ULL, 588, 196 },+ { 0xcc20ce9bd35c78a5ULL, 614, 204 },+ { 0x98165af37b2153dfULL, 641, 212 },+ { 0xe2a0b5dc971f303aULL, 667, 220 },+ { 0xa8d9d1535ce3b396ULL, 694, 228 },+ { 0xfb9b7cd9a4a7443cULL, 720, 236 },+ { 0xbb764c4ca7a44410ULL, 747, 244 },+ { 0x8bab8eefb6409c1aULL, 774, 252 },+ { 0xd01fef10a657842cULL, 800, 260 },+ { 0x9b10a4e5e9913129ULL, 827, 268 },+ { 0xe7109bfba19c0c9dULL, 853, 276 },+ { 0xac2820d9623bf429ULL, 880, 284 },+ { 0x80444b5e7aa7cf85ULL, 907, 292 },+ { 0xbf21e44003acdd2dULL, 933, 300 },+ { 0x8e679c2f5e44ff8fULL, 960, 308 },+ { 0xd433179d9c8cb841ULL, 986, 316 },+ { 0x9e19db92b4e31ba9ULL, 1013, 324 },+ { 0xeb96bf6ebadf77d9ULL, 1039, 332 },+ { 0xaf87023b9bf0ee6bULL, 1066, 340 }+};++static int cached_pow(int exp, diy_fp *p)+{+ int k = (int)ceil((exp+DIYFP_FRACT_SIZE-1) * D_1_LOG2_10);+ int i = (k-MIN_CACHED_EXP-1) / CACHED_EXP_STEP + 1;+ p->f = pow_cache[i].fract;+ p->e = pow_cache[i].b_exp;+ return pow_cache[i].d_exp;+}++static diy_fp minus(diy_fp x, diy_fp y)+{+ diy_fp d; d.f = x.f - y.f; d.e = x.e;+ assert(x.e == y.e && x.f >= y.f);+ return d;+}++static diy_fp multiply(diy_fp x, diy_fp y)+{+ uint64_t a, b, c, d, ac, bc, ad, bd, tmp;+ diy_fp r;+ a = x.f >> 32; b = x.f & MASK32;+ c = y.f >> 32; d = y.f & MASK32;+ ac = a*c; bc = b*c;+ ad = a*d; bd = b*d;+ tmp = (bd >> 32) + (ad & MASK32) + (bc & MASK32);+ tmp += 1U << 31; // round+ r.f = ac + (ad >> 32) + (bc >> 32) + (tmp >> 32);+ r.e = x.e + y.e + 64;+ return r;+}++static diy_fp normalize_diy_fp(diy_fp n)+{+ assert(n.f != 0);+ while(!(n.f & 0xFFC0000000000000ULL)) { n.f <<= 10; n.e -= 10; }+ while(!(n.f & D64_SIGN)) { n.f <<= 1; --n.e; }+ return n;+}++static diy_fp double2diy_fp(double d)+{+ diy_fp fp;+ uint64_t u64 = CAST_U64(d);+ if (!(u64 & D64_EXP_MASK)) { fp.f = u64 & D64_FRACT_MASK; fp.e = 1 - D64_EXP_BIAS; }+ else { fp.f = (u64 & D64_FRACT_MASK) + D64_IMPLICIT_ONE; fp.e = (int)((u64 & D64_EXP_MASK) >> D64_EXP_POS) - D64_EXP_BIAS; }+ return fp;+}++// pow10_cache[i] = 10^(i-1)+static const unsigned int pow10_cache[] = { 0, 1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000 };++static int largest_pow10(uint32_t n, int n_bits, uint32_t *power)+{+ int guess = ((n_bits + 1) * 1233 >> 12) + 1/*skip first entry*/;+ if (n < pow10_cache[guess]) --guess; // We don't have any guarantees that 2^n_bits <= n.+ *power = pow10_cache[guess];+ return guess;+}++static int round_weed(char *buffer, int len, uint64_t wp_W, uint64_t delta, uint64_t rest, uint64_t ten_kappa, uint64_t ulp)+{+ uint64_t wp_Wup = wp_W - ulp;+ uint64_t wp_Wdown = wp_W + ulp;+ while(rest < wp_Wup && delta - rest >= ten_kappa+ && (rest + ten_kappa < wp_Wup || wp_Wup - rest >= rest + ten_kappa - wp_Wup))+ {+ --buffer[len-1];+ rest += ten_kappa;+ }+ if (rest < wp_Wdown && delta - rest >= ten_kappa+ && (rest + ten_kappa < wp_Wdown || wp_Wdown - rest > rest + ten_kappa - wp_Wdown))+ return 0;++ return 2*ulp <= rest && rest <= delta - 4*ulp;+}++static int digit_gen(diy_fp low, diy_fp w, diy_fp high, char *buffer, int *length, int *kappa)+{+ uint64_t unit = 1;+ diy_fp too_low = { low.f - unit, low.e };+ diy_fp too_high = { high.f + unit, high.e };+ diy_fp unsafe_interval = minus(too_high, too_low);+ diy_fp one = { 1ULL << -w.e, w.e };+ uint32_t p1 = (uint32_t)(too_high.f >> -one.e);+ uint64_t p2 = too_high.f & (one.f - 1);+ uint32_t div;+ *kappa = largest_pow10(p1, DIYFP_FRACT_SIZE + one.e, &div);+ *length = 0;++ while(*kappa > 0)+ {+ uint64_t rest;+ int digit = p1 / div;+ buffer[*length] = (char)('0' + digit);+ ++*length;+ p1 %= div;+ --*kappa;+ rest = ((uint64_t)p1 << -one.e) + p2;+ if (rest < unsafe_interval.f) return round_weed(buffer, *length, minus(too_high, w).f, unsafe_interval.f, rest, (uint64_t)div << -one.e, unit);+ div /= 10;+ }++ for(;;)+ {+ int digit;+ p2 *= 10;+ unit *= 10;+ unsafe_interval.f *= 10;+ // Integer division by one.+ digit = (int)(p2 >> -one.e);+ buffer[*length] = (char)('0' + digit);+ ++*length;+ p2 &= one.f - 1; // Modulo by one.+ --*kappa;+ if (p2 < unsafe_interval.f) return round_weed(buffer, *length, minus(too_high, w).f * unit, unsafe_interval.f, p2, one.f, unit);+ }+}++int grisu3(double v, char *buffer, int *length, int *d_exp)+{+ int mk, kappa, success;+ diy_fp dfp = double2diy_fp(v);+ diy_fp w = normalize_diy_fp(dfp);++ // normalize boundaries+ diy_fp t = { (dfp.f << 1) + 1, dfp.e - 1 };+ diy_fp b_plus = normalize_diy_fp(t);+ diy_fp b_minus;+ diy_fp c_mk; // Cached power of ten: 10^-k+ uint64_t u64 = CAST_U64(v);+ assert(v > 0 && v <= 1.7976931348623157e308); // Grisu only handles strictly positive finite numbers.+ if (!(u64 & D64_FRACT_MASK) && (u64 & D64_EXP_MASK) != 0) { b_minus.f = (dfp.f << 2) - 1; b_minus.e = dfp.e - 2;} // lower boundary is closer?+ else { b_minus.f = (dfp.f << 1) - 1; b_minus.e = dfp.e - 1; }+ b_minus.f = b_minus.f << (b_minus.e - b_plus.e);+ b_minus.e = b_plus.e;++ mk = cached_pow(MIN_TARGET_EXP - DIYFP_FRACT_SIZE - w.e, &c_mk);++ w = multiply(w, c_mk);+ b_minus = multiply(b_minus, c_mk);+ b_plus = multiply(b_plus, c_mk);++ success = digit_gen(b_minus, w, b_plus, buffer, length, &kappa);+ *d_exp = kappa - mk;+ return success;+}++static int i_to_str(int val, char *str)+{+ int len, i;+ char *s;+ char *begin = str;+ if (val < 0) { *str++ = '-'; val = -val; }+ s = str;++ for(;;)+ {+ int ni = val / 10;+ int digit = val - ni*10;+ *s++ = (char)('0' + digit);+ if (ni == 0)+ break;+ val = ni;+ }+ *s = '\0';+ len = (int)(s - str);+ for(i = 0; i < len/2; ++i)+ {+ char ch = str[i];+ str[i] = str[len-1-i];+ str[len-1-i] = ch;+ }++ return (int)(s - begin);+}++int dtoa_grisu3(double v, char *dst)+{+ int d_exp, len, decimals, i;++ int success = grisu3(v, dst, &len, &d_exp);+ // If grisu3 was not able to convert the number to a string, then use old sprintf (suboptimal).+ if (!success) return sprintf(dst, "%.17g", v) + (int)(dst - dst);++ // We now have an integer string of form "151324135" and a base-10 exponent for that number.+ // Next, decide the best presentation for that string by whether to use a decimal point, or the scientific exponent notation 'e'.+ // We don't pick the absolute shortest representation, but pick a balance between readability and shortness, e.g.+ // 1.545056189557677e-308 could be represented in a shorter form+ // 1545056189557677e-323 but that would be somewhat unreadable.+ decimals = MIN(-d_exp, MAX(1, len-1));+ if (d_exp < 0 && len > 1) // Add decimal point?+ {+ for(i = 0; i < decimals; ++i) dst[len-i] = dst[len-i-1];+ dst[len++ - decimals] = '.';+ d_exp += decimals;+ // Need scientific notation as well?+ if (d_exp != 0) { dst[len++] = 'e'; len += i_to_str(d_exp, dst+len); }+ }+ else if (d_exp < 0 && d_exp >= -3) // Add decimal point for numbers of form 0.000x where it's shorter?+ {+ for(i = 0; i < len; ++i) dst[len-d_exp-1-i] = dst[len-i-1];+ dst[0] = '.';+ for(i = 1; i < -d_exp; ++i) dst[i] = '0';+ len += -d_exp;+ }+ // Add scientific notation?+ else if (d_exp < 0 || d_exp > 2) { dst[len++] = 'e'; len += i_to_str(d_exp, dst+len); }+ // Add zeroes instead of scientific notation?+ else if (d_exp > 0) { while(d_exp-- > 0) dst[len++] = '0'; }+ // dst[len] = '\0'; // grisu3 doesn't null terminate, so ensure termination.+ return (int)(dst+len-dst);+}
+ mason.cabal view
@@ -0,0 +1,30 @@+cabal-version: 2.4++name: mason+version: 0+synopsis: Fast and extensible bytestring builder+description: See README.md+bug-reports: https://github.com/fumieval/mason/issues+license: BSD-3-Clause+license-file: LICENSE+author: Fumiaki Kinoshita+maintainer: fumiexcel@gmail.com+copyright: 2019 Fumiaki Kinoshita, Don Stewart 2005-2009, Duncan Coutts 2006-2015, David Roundy 2003-2005, Jasper Van der Jeugt 2010, Simon Meier 2010-2013, Ben Gamari 2017+category: Data+extra-source-files: CHANGELOG.md++library+ exposed-modules:+ Mason.Builder+ Mason.Builder.Internal++ c-sources: cbits/dtoa.c+ ghc-options: -Wall -O2+ build-depends: base >= 4.12.0.0 && <5+ , bytestring+ , text+ , network >= 2.7 && <3.2+ , integer-gmp+ , ghc-prim+ hs-source-dirs: src+ default-language: Haskell2010
+ src/Mason/Builder.hs view
@@ -0,0 +1,523 @@+{-# LANGUAGE MagicHash, CPP, UnboxedTuples #-}+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE RankNTypes #-}+module Mason.Builder+ ( Builder+ , BuilderFor+ , Buildable+ -- * Runners+ , toStrictByteString+ , toLazyByteString+ , hPutBuilderLen+ , hPutBuilder+ , sendBuilder+ -- * Raw+ , flush+ , encodeUtf8Builder+ , encodeUtf8BuilderEscaped+ , byteString+ , lazyByteString+ , shortByteString+ , int8+ , word8+ , int16LE+ , int32LE+ , int64LE+ , word16LE+ , word32LE+ , word64LE+ , floatLE+ , doubleLE+ , int16BE+ , int32BE+ , int64BE+ , word16BE+ , word32BE+ , word64BE+ , floatBE+ , doubleBE+ , char7+ , string7+ , char8+ , string8+ , charUtf8+ , stringUtf8+ , floatDec+ , doubleDec+ , word8Dec+ , word16Dec+ , word32Dec+ , word64Dec+ , wordDec+ , int8Dec+ , int16Dec+ , int32Dec+ , int64Dec+ , intDec+ , integerDec+ , word8Hex+ , word16Hex+ , word32Hex+ , word64Hex+ , wordHex+ , int8HexFixed+ , int16HexFixed+ , int32HexFixed+ , int64HexFixed+ , word8HexFixed+ , word16HexFixed+ , word32HexFixed+ , word64HexFixed+ , floatHexFixed+ , doubleHexFixed+ , byteStringHex+ , lazyByteStringHex+ -- * Advanced+ , primFixed+ , primBounded+ , lengthPrefixedWithin+ ) where++import Control.Monad+import Data.Bits+import Data.Word+import Data.Int+import qualified Data.Text as T+import Foreign.C.Types+import Foreign.Ptr (Ptr, plusPtr)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Mason.Builder.Internal as B+import qualified Data.ByteString.Builder.Prim as P+import qualified Data.ByteString.Builder.Prim.Internal as P+import GHC.Integer.GMP.Internals+import GHC.Types (Int(..))+import System.IO (Handle)++-- | Put the content of a 'Builder' to a 'Handle'.+hPutBuilder :: Handle -> BuilderFor PutBuilderEnv -> IO ()+hPutBuilder h b = void $ hPutBuilderLen h b+{-# INLINE hPutBuilder #-}++lazyByteString :: BL.ByteString -> Builder+lazyByteString = foldMap byteString . BL.toChunks+{-# INLINE lazyByteString #-}++------------------------------------------------------------------------------+-- Binary encodings+------------------------------------------------------------------------------++-- | Encode a single signed byte as-is.+--+{-# INLINE int8 #-}+int8 :: Int8 -> Builder+int8 = B.primFixed P.int8++-- | Encode a single unsigned byte as-is.+--+{-# INLINE word8 #-}+word8 :: Word8 -> Builder+word8 = B.primFixed P.word8+++------------------------------------------------------------------------------+-- Binary little-endian encodings+------------------------------------------------------------------------------++-- | Encode an 'Int16' in little endian format.+{-# INLINE int16LE #-}+int16LE :: Int16 -> Builder+int16LE = B.primFixed P.int16LE++-- | Encode an 'Int32' in little endian format.+{-# INLINE int32LE #-}+int32LE :: Int32 -> Builder+int32LE = B.primFixed P.int32LE++-- | Encode an 'Int64' in little endian format.+{-# INLINE int64LE #-}+int64LE :: Int64 -> Builder+int64LE = B.primFixed P.int64LE++-- | Encode a 'Word16' in little endian format.+{-# INLINE word16LE #-}+word16LE :: Word16 -> Builder+word16LE = B.primFixed P.word16LE++-- | Encode a 'Word32' in little endian format.+{-# INLINE word32LE #-}+word32LE :: Word32 -> Builder+word32LE = B.primFixed P.word32LE++-- | Encode a 'Word64' in little endian format.+{-# INLINE word64LE #-}+word64LE :: Word64 -> Builder+word64LE = B.primFixed P.word64LE++-- | Encode a 'Float' in little endian format.+{-# INLINE floatLE #-}+floatLE :: Float -> Builder+floatLE = B.primFixed P.floatLE++-- | Encode a 'Double' in little endian format.+{-# INLINE doubleLE #-}+doubleLE :: Double -> Builder+doubleLE = B.primFixed P.doubleLE+++------------------------------------------------------------------------------+-- Binary big-endian encodings+------------------------------------------------------------------------------++-- | Encode an 'Int16' in big endian format.+{-# INLINE int16BE #-}+int16BE :: Int16 -> Builder+int16BE = B.primFixed P.int16BE++-- | Encode an 'Int32' in big endian format.+{-# INLINE int32BE #-}+int32BE :: Int32 -> Builder+int32BE = B.primFixed P.int32BE++-- | Encode an 'Int64' in big endian format.+{-# INLINE int64BE #-}+int64BE :: Int64 -> Builder+int64BE = B.primFixed P.int64BE++-- | Encode a 'Word16' in big endian format.+{-# INLINE word16BE #-}+word16BE :: Word16 -> Builder+word16BE = B.primFixed P.word16BE++-- | Encode a 'Word32' in big endian format.+{-# INLINE word32BE #-}+word32BE :: Word32 -> Builder+word32BE = B.primFixed P.word32BE++-- | Encode a 'Word64' in big endian format.+{-# INLINE word64BE #-}+word64BE :: Word64 -> Builder+word64BE = B.primFixed P.word64BE++-- | Encode a 'Float' in big endian format.+{-# INLINE floatBE #-}+floatBE :: Float -> Builder+floatBE = B.primFixed P.floatBE++-- | Encode a 'Double' in big endian format.+{-# INLINE doubleBE #-}+doubleBE :: Double -> Builder+doubleBE = B.primFixed P.doubleBE++------------------------------------------------------------------------------+-- ASCII encoding+------------------------------------------------------------------------------++-- | Char7 encode a 'Char'.+{-# INLINE char7 #-}+char7 :: Char -> Builder+char7 = B.primFixed P.char7++-- | Char7 encode a 'String'.+{-# INLINE string7 #-}+string7 :: String -> Builder+string7 = B.primMapListFixed P.char7++------------------------------------------------------------------------------+-- ISO/IEC 8859-1 encoding+------------------------------------------------------------------------------++-- | Char8 encode a 'Char'.+{-# INLINE char8 #-}+char8 :: Char -> Builder+char8 = B.primFixed P.char8++-- | Char8 encode a 'String'.+{-# INLINE string8 #-}+string8 :: String -> Builder+string8 = B.primMapListFixed P.char8++------------------------------------------------------------------------------+-- UTF-8 encoding+------------------------------------------------------------------------------++-- | UTF-8 encode a 'Char'.+{-# INLINE charUtf8 #-}+charUtf8 :: Char -> Builder+charUtf8 = B.primBounded P.charUtf8++-- | Encode 'T.Text' as a UTF-8 byte stream.+encodeUtf8Builder :: T.Text -> Builder+encodeUtf8Builder = B.encodeUtf8BuilderEscaped (P.liftFixedToBounded P.word8)+{-# INLINE encodeUtf8Builder #-}++--------------------+-- Unsigned integers+--------------------++-- | Decimal encoding of a 'Word8' using the ASCII digits.+{-# INLINE word8Dec #-}+word8Dec :: Word8 -> Builder+word8Dec = B.primBounded P.word8Dec++-- | Decimal encoding of a 'Word16' using the ASCII digits.+{-# INLINE word16Dec #-}+word16Dec :: Word16 -> Builder+word16Dec = B.primBounded P.word16Dec++-- | Decimal encoding of a 'Word32' using the ASCII digits.+{-# INLINE word32Dec #-}+word32Dec :: Word32 -> Builder+word32Dec = B.primBounded P.word32Dec++-- | Decimal encoding of a 'Word64' using the ASCII digits.+{-# INLINE word64Dec #-}+word64Dec :: Word64 -> Builder+word64Dec = B.primBounded P.word64Dec++-- | Decimal encoding of a 'Word' using the ASCII digits.+{-# INLINE wordDec #-}+wordDec :: Word -> Builder+wordDec = B.primBounded P.wordDec++-- Floating point numbers+-------------------------++-- | /Currently slow./ Decimal encoding of an IEEE 'Float'.+{-# INLINE floatDec #-}+floatDec :: Float -> Builder+floatDec = string7 . show++-- | Decimal encoding of an IEEE 'Double'.+{-# INLINE doubleDec #-}+doubleDec :: Double -> Builder+doubleDec x+ | isNaN x = string7 "NaN"+ | isInfinite x = if x < 0 then string7 "-Infinity" else string7 "Infinity"+ | x < 0 = char7 '-' <> grisu (-x)+ | isNegativeZero x = string7 "-0.0"+ | x == 0 = string7 "0.0"+ | otherwise = grisu x+ where+ grisu v = B.ensure 24 $ \(B.Buffer end ptr) -> do+ n <- dtoa_grisu3 v ptr+ return $ B.Buffer end $ plusPtr ptr (fromIntegral n)++foreign import ccall unsafe "static dtoa_grisu3"+ dtoa_grisu3 :: Double -> Ptr Word8 -> IO CInt++------------------------------------------------------------------------------+-- Decimal Encoding+------------------------------------------------------------------------------++-- Signed integers+------------------++-- | Decimal encoding of an 'Int8' using the ASCII digits.+--+-- e.g.+--+-- > toLazyByteString (int8Dec 42) = "42"+-- > toLazyByteString (int8Dec (-1)) = "-1"+--+{-# INLINE int8Dec #-}+int8Dec :: Int8 -> Builder+int8Dec = B.primBounded P.int8Dec++-- | Decimal encoding of an 'Int16' using the ASCII digits.+{-# INLINE int16Dec #-}+int16Dec :: Int16 -> Builder+int16Dec = B.primBounded P.int16Dec++-- | Decimal encoding of an 'Int32' using the ASCII digits.+{-# INLINE int32Dec #-}+int32Dec :: Int32 -> Builder+int32Dec = B.primBounded P.int32Dec++-- | Decimal encoding of an 'Int64' using the ASCII digits.+{-# INLINE int64Dec #-}+int64Dec :: Int64 -> Builder+int64Dec = B.primBounded P.int64Dec++-- | Decimal encoding of an 'Int' using the ASCII digits.+{-# INLINE intDec #-}+intDec :: Int -> Builder+intDec = B.primBounded P.intDec++++------------------------------------------------------------------------------+-- Hexadecimal Encoding+------------------------------------------------------------------------------++-- without lead+---------------++-- | Shortest hexadecimal encoding of a 'Word8' using lower-case characters.+{-# INLINE word8Hex #-}+word8Hex :: Word8 -> Builder+word8Hex = B.primBounded P.word8Hex++-- | Shortest hexadecimal encoding of a 'Word16' using lower-case characters.+{-# INLINE word16Hex #-}+word16Hex :: Word16 -> Builder+word16Hex = B.primBounded P.word16Hex++-- | Shortest hexadecimal encoding of a 'Word32' using lower-case characters.+{-# INLINE word32Hex #-}+word32Hex :: Word32 -> Builder+word32Hex = B.primBounded P.word32Hex++-- | Shortest hexadecimal encoding of a 'Word64' using lower-case characters.+{-# INLINE word64Hex #-}+word64Hex :: Word64 -> Builder+word64Hex = B.primBounded P.word64Hex++-- | Shortest hexadecimal encoding of a 'Word' using lower-case characters.+{-# INLINE wordHex #-}+wordHex :: Word -> Builder+wordHex = B.primBounded P.wordHex++-- fixed width; leading zeroes+------------------------------++-- | Encode a 'Int8' using 2 nibbles (hexadecimal digits).+{-# INLINE int8HexFixed #-}+int8HexFixed :: Int8 -> Builder+int8HexFixed = B.primFixed P.int8HexFixed++-- | Encode a 'Int16' using 4 nibbles.+{-# INLINE int16HexFixed #-}+int16HexFixed :: Int16 -> Builder+int16HexFixed = B.primFixed P.int16HexFixed++-- | Encode a 'Int32' using 8 nibbles.+{-# INLINE int32HexFixed #-}+int32HexFixed :: Int32 -> Builder+int32HexFixed = B.primFixed P.int32HexFixed++-- | Encode a 'Int64' using 16 nibbles.+{-# INLINE int64HexFixed #-}+int64HexFixed :: Int64 -> Builder+int64HexFixed = B.primFixed P.int64HexFixed++-- | Encode a 'Word8' using 2 nibbles (hexadecimal digits).+{-# INLINE word8HexFixed #-}+word8HexFixed :: Word8 -> Builder+word8HexFixed = B.primFixed P.word8HexFixed++-- | Encode a 'Word16' using 4 nibbles.+{-# INLINE word16HexFixed #-}+word16HexFixed :: Word16 -> Builder+word16HexFixed = B.primFixed P.word16HexFixed++-- | Encode a 'Word32' using 8 nibbles.+{-# INLINE word32HexFixed #-}+word32HexFixed :: Word32 -> Builder+word32HexFixed = B.primFixed P.word32HexFixed++-- | Encode a 'Word64' using 16 nibbles.+{-# INLINE word64HexFixed #-}+word64HexFixed :: Word64 -> Builder+word64HexFixed = B.primFixed P.word64HexFixed++-- | Encode an IEEE 'Float' using 8 nibbles.+{-# INLINE floatHexFixed #-}+floatHexFixed :: Float -> Builder+floatHexFixed = B.primFixed P.floatHexFixed++-- | Encode an IEEE 'Double' using 16 nibbles.+{-# INLINE doubleHexFixed #-}+doubleHexFixed :: Double -> Builder+doubleHexFixed = B.primFixed P.doubleHexFixed++-- | Encode each byte of a 'S.ByteString' using its fixed-width hex encoding.+{-# NOINLINE byteStringHex #-} -- share code+byteStringHex :: B.ByteString -> Builder+byteStringHex = B.primMapByteStringFixed P.word8HexFixed++-- | Encode each byte of a lazy 'L.ByteString' using its fixed-width hex encoding.+{-# NOINLINE lazyByteStringHex #-} -- share code+lazyByteStringHex :: BL.ByteString -> Builder+lazyByteStringHex = B.primMapLazyByteStringFixed P.word8HexFixed++#define PAIR(a,b) (# a,b #)++-- | Select an implementation depending on the bit-size of 'Word's.+-- Currently, it produces a runtime failure if the bitsize is different.+-- This is detected by the testsuite.+{-# INLINE caseWordSize_32_64 #-}+caseWordSize_32_64 :: a -- Value to use for 32-bit 'Word's+ -> a -- Value to use for 64-bit 'Word's+ -> a+caseWordSize_32_64 f32 f64 =+#if MIN_VERSION_base(4,7,0)+ case finiteBitSize (undefined :: Word) of+#else+ case bitSize (undefined :: Word) of+#endif+ 32 -> f32+ 64 -> f64+ s -> error $ "caseWordSize_32_64: unsupported Word bit-size " ++ show s++maxPow10 :: Integer+maxPow10 = toInteger $ (10 :: Int) ^ caseWordSize_32_64 (9 :: Int) 18++-- | Decimal encoding of an 'Integer' using the ASCII digits.+-- Simon Meier's improved implementation from https://github.com/haskell/bytestring/commit/92f19a5d94761042b44a433d7331107611e4d717+integerDec :: Integer -> Builder+integerDec (S# i#) = intDec (I# i#)+integerDec i+ | i < 0 = B.primFixed P.char8 '-' `mappend` go (-i)+ | otherwise = go ( i)+ where+ errImpossible fun =+ error $ "integerDec: " ++ fun ++ ": the impossible happened."++ go :: Integer -> Builder+ go n | n < maxPow10 = intDec (fromInteger n)+ | otherwise =+ case putH (splitf (maxPow10 * maxPow10) n) of+ (x:xs) -> intDec x `mappend` B.primMapListBounded intDecPadded xs+ [] -> errImpossible "integerDec: go"++ splitf :: Integer -> Integer -> [Integer]+ splitf pow10 n0+ | pow10 > n0 = [n0]+ | otherwise = splith (splitf (pow10 * pow10) n0)+ where+ splith [] = errImpossible "splith"+ splith (n:ns) =+ case n `quotRemInteger` pow10 of+ PAIR(q,r) | q > 0 -> q : r : splitb ns+ | otherwise -> r : splitb ns++ splitb [] = []+ splitb (n:ns) = case n `quotRemInteger` pow10 of+ PAIR(q,r) -> q : r : splitb ns++ putH :: [Integer] -> [Int]+ putH [] = errImpossible "putH"+ putH (n:ns) = case n `quotRemInteger` maxPow10 of+ PAIR(x,y)+ | q > 0 -> q : r : putB ns+ | otherwise -> r : putB ns+ where q = fromInteger x+ r = fromInteger y++ putB :: [Integer] -> [Int]+ putB [] = []+ putB (n:ns) = case n `quotRemInteger` maxPow10 of+ PAIR(q,r) -> fromInteger q : fromInteger r : putB ns++foreign import ccall unsafe "static _hs_bytestring_int_dec_padded9"+ c_int_dec_padded9 :: CInt -> Ptr Word8 -> IO ()++foreign import ccall unsafe "static _hs_bytestring_long_long_int_dec_padded18"+ c_long_long_int_dec_padded18 :: CLLong -> Ptr Word8 -> IO ()++{-# INLINE intDecPadded #-}+intDecPadded :: P.BoundedPrim Int+intDecPadded = P.liftFixedToBounded $ caseWordSize_32_64+ (P.fixedPrim 9 $ c_int_dec_padded9 . fromIntegral)+ (P.fixedPrim 18 $ c_long_long_int_dec_padded18 . fromIntegral)
+ src/Mason/Builder/Internal.hs view
@@ -0,0 +1,462 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE UnboxedTuples #-}+module Mason.Builder.Internal (Builder+ , BuilderFor(..)+ , Buildable(..)+ , GrowingBuffer(..)+ , Buffer(..)+ , byteStringCopy+ , shortByteString+ , toStrictByteString+ , Channel(..)+ , toLazyByteString+ , stringUtf8+ , lengthPrefixedWithin+ , primBounded+ , primFixed+ , primMapListFixed+ , primMapListBounded+ , primMapByteStringFixed+ , primMapLazyByteStringFixed+ , hPutBuilderLen+ , PutBuilderEnv(..)+ , encodeUtf8BuilderEscaped+ , sendBuilder+ , SocketEnv(..)+ , cstring+ , cstringUtf8+ -- * Internal+ , ensure+ , allocateConstant+ , grisu3+ ) where++import Control.Concurrent+import Control.Exception (throw)+import Control.Monad+import Data.Bits ((.&.))+import qualified Data.ByteString as B+import qualified Data.ByteString.Short.Internal as SB+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Internal as BL+import qualified Data.ByteString.Internal as B+import qualified Data.ByteString.Builder.Prim as P+import qualified Data.ByteString.Builder.Prim.Internal as B+import Data.Text.Internal.Unsafe.Shift (shiftR)+import Data.Text.Internal.Unsafe.Char (ord)+import System.IO+import Foreign.C.Types+import Foreign.Ptr+import Foreign.ForeignPtr.Unsafe+import Foreign.ForeignPtr+import Foreign.Marshal.Array (allocaArray)+import Data.IORef+import Data.Word (Word8)+import Data.String+import qualified Foreign.Storable as S+import System.IO.Unsafe+import qualified Data.Text.Array as A+import qualified Data.Text.Internal as T+import qualified Data.Text.Internal.Encoding.Utf16 as U16+import qualified Network.Socket as S+import qualified Network.Socket.ByteString as S+import GHC.Prim (eqWord#, plusAddr#, indexWord8OffAddr#)+import GHC.Ptr (Ptr(..))+import GHC.Word (Word8(..))+import GHC.Types (isTrue#)+import GHC.Base (unpackCString#, unpackCStringUtf8#, unpackFoldrCString#, build)++-- | The Builder type. Requires RankNTypes extension+type Builder = forall s. Buildable s => BuilderFor s++-- | Builder specialised for a backend+newtype BuilderFor s = Builder { unBuilder :: s -> Buffer -> IO Buffer }++class Buildable s where+ -- | Put a 'B.ByteString'.+ byteString :: B.ByteString -> BuilderFor s+ -- | Flush the content of the internal buffer.+ flush :: BuilderFor s+ -- | Allocate a buffer with at least the given length.+ allocate :: Int -> BuilderFor s++-- | Buffer pointers+data Buffer = Buffer+ { bEnd :: {-# UNPACK #-} !(Ptr Word8) -- ^ end of the buffer (next to the last byte)+ , bCur :: {-# UNPACK #-} !(Ptr Word8) -- ^ current position+ }++-- | Copy a 'B.ByteString' to a buffer.+byteStringCopy :: Buildable s => B.ByteString -> BuilderFor s+byteStringCopy = \(B.PS fsrc ofs len) -> ensure len $ \(Buffer end ptr) -> do+ withForeignPtr fsrc $ \src -> B.memcpy ptr (src `plusPtr` ofs) len+ return $ Buffer end (ptr `plusPtr` len)+{-# INLINE byteStringCopy #-}++-- | Copy a 'SB.ShortByteString' to a buffer.+shortByteString :: SB.ShortByteString -> Builder+shortByteString = \src -> let len = SB.length src in ensure len $ \(Buffer end ptr) ->+ Buffer end (ptr `plusPtr` len)+ <$ SB.copyToPtr src 0 ptr len+{-# INLINE shortByteString #-}++-- | Ensure that the given number of bytes is available in the buffer. Subject to semigroup fusions+ensure :: Int -> (Buffer -> IO Buffer) -> Builder+ensure mlen cont = Builder $ \env buf@(Buffer end ptr) ->+ if ptr `plusPtr` mlen >= end+ then do+ buf'@(Buffer end' ptr') <- unBuilder flush env buf+ if mlen <= minusPtr end' ptr'+ then cont buf'+ else unBuilder (allocate mlen) env buf' >>= cont+ else cont buf+{-# INLINE[1] ensure #-}++{-# RULES "<>/ensure" forall m n f g. ensure m f <> ensure n g = ensure (m + n) (f >=> g) #-}++-- | Run a builder within a buffer and prefix it by the length.+lengthPrefixedWithin :: Int -- ^ maximum length+ -> B.BoundedPrim Int -- ^ prefix encoder+ -> BuilderFor () -> Builder+lengthPrefixedWithin maxLen bp builder = ensure (B.sizeBound bp + maxLen) $ \(Buffer end origin) -> do+ let base = origin `plusPtr` B.sizeBound bp+ Buffer _ base' <- unBuilder builder () (Buffer end base)+ let len = minusPtr base' base+ newBase <- B.runB bp len origin+ c_memmove newBase base len+ return $ Buffer end (newBase `plusPtr` len)+{-# INLINE lengthPrefixedWithin #-}++-- | Work with a constant buffer. 'allocate' will always fail.+instance Buildable () where+ byteString = byteStringCopy+ {-# INLINE byteString #-}+ flush = mempty+ {-# INLINE flush #-}+ allocate _ = Builder $ \_ _ -> fail "Mason.Builder.Internal.allocate: can't allocate"+ {-# INLINE allocate #-}++instance Semigroup (BuilderFor s) where+ Builder f <> Builder g = Builder $ \e -> f e >=> g e+ {-# INLINE[1] (<>) #-}++instance Monoid (BuilderFor a) where+ mempty = Builder $ const pure+ {-# INLINE mempty #-}++-- | UTF-8 encode a 'String'.+stringUtf8 :: String -> Builder+stringUtf8 = primMapListBounded P.charUtf8+{-# INLINE [1] stringUtf8 #-}++{-# RULES+"stringUtf8/unpackCStringUtf8#" forall s.+ stringUtf8 (unpackCStringUtf8# s) = cstringUtf8 (Ptr s)++"stringUtf8/unpackCString#" forall s.+ stringUtf8 (unpackCString# s) = cstring (Ptr s)++"stringUtf8/unpackFoldrCString#" forall s.+ stringUtf8 (build (unpackFoldrCString# s)) = cstring (Ptr s)+ #-}++cstring :: Ptr Word8 -> Builder+cstring (Ptr addr0) = Builder $ step addr0+ where+ step addr env br@(Buffer end ptr)+ | isTrue# (ch `eqWord#` 0##) = pure br+ | ptr == end = unBuilder (ensure 3 $ step addr env) env br+ | otherwise = do+ S.poke ptr (W8# ch)+ let br' = Buffer end (ptr `plusPtr` 1)+ step (addr `plusAddr#` 1#) env br'+ where+ !ch = indexWord8OffAddr# addr 0#+{-# INLINE cstring #-}++cstringUtf8 :: Ptr Word8 -> Builder+cstringUtf8 (Ptr addr0) = Builder $ step addr0+ where+ step addr env br@(Buffer end ptr)+ | isTrue# (ch `eqWord#` 0##) = pure br+ | ptr == end = unBuilder (ensure 3 $ step addr env) env br+ -- NULL is encoded as 0xc0 0x80+ | isTrue# (ch `eqWord#` 0xc0##)+ , isTrue# (indexWord8OffAddr# addr 1# `eqWord#` 0x80##) = do+ S.poke ptr 0+ step (addr `plusAddr#` 2#) env (Buffer end (ptr `plusPtr` 1))+ | otherwise = do+ S.poke ptr (W8# ch)+ step (addr `plusAddr#` 1#) env (Buffer end (ptr `plusPtr` 1))+ where+ !ch = indexWord8OffAddr# addr 0#+{-# INLINE cstringUtf8 #-}++instance Buildable s => IsString (BuilderFor s) where+ fromString = stringUtf8+ {-# INLINE fromString #-}++primBounded :: B.BoundedPrim a -> a -> Builder+primBounded bp a = ensure (B.sizeBound bp)+ $ \(Buffer end ptr) -> Buffer end <$> B.runB bp a ptr+{-# INLINE primBounded #-}++primFixed :: B.FixedPrim a -> a -> Builder+primFixed fp a = ensure (B.size fp)+ $ \(Buffer end ptr) -> Buffer end (ptr `plusPtr` B.size fp) <$ B.runF fp a ptr+{-# INLINE primFixed #-}++primMapListFixed :: B.FixedPrim a -> [a] -> Builder+primMapListFixed fp = foldMap (primFixed fp)+{-# INLINE primMapListFixed #-}++primMapListBounded :: B.BoundedPrim a -> [a] -> Builder+primMapListBounded bp = foldMap (primBounded bp)+{-# INLINE primMapListBounded #-}++primMapByteStringFixed :: B.FixedPrim Word8 -> B.ByteString -> Builder+primMapByteStringFixed fp = B.foldr (mappend . primFixed fp) mempty+{-# INLINE primMapByteStringFixed #-}++primMapLazyByteStringFixed :: B.FixedPrim Word8 -> BL.ByteString -> Builder+primMapLazyByteStringFixed fp = BL.foldr (mappend . primFixed fp) mempty+{-# INLINE primMapLazyByteStringFixed #-}++newtype GrowingBuffer = GrowingBuffer (IORef (ForeignPtr Word8))++instance Buildable GrowingBuffer where+ byteString = byteStringCopy+ {-# INLINE byteString #-}+ flush = mempty+ {-# INLINE flush #-}+ allocate len = Builder $ \(GrowingBuffer bufferRef) (Buffer _ dst) -> do+ fptr0 <- readIORef bufferRef+ let ptr0 = unsafeForeignPtrToPtr fptr0+ let !pos = dst `minusPtr` ptr0+ let !size' = pos + max len pos+ fptr <- mallocForeignPtrBytes size'+ let !dst' = unsafeForeignPtrToPtr fptr+ B.memcpy dst' ptr0 pos+ writeIORef bufferRef fptr+ return $ Buffer (dst' `plusPtr` size') (dst' `plusPtr` pos)+ {-# INLINE allocate #-}++toStrictByteString :: BuilderFor GrowingBuffer -> B.ByteString+toStrictByteString b = unsafePerformIO $ do+ fptr0 <- mallocForeignPtrBytes initialSize+ bufferRef <- newIORef fptr0+ let ptr0 = unsafeForeignPtrToPtr fptr0++ Buffer _ pos <- unBuilder b (GrowingBuffer bufferRef)+ $ Buffer (ptr0 `plusPtr` initialSize) ptr0++ fptr <- readIORef bufferRef+ pure $ B.PS fptr 0 (pos `minusPtr` unsafeForeignPtrToPtr fptr)++ where+ initialSize = 128+{-# INLINE toStrictByteString #-}++data Channel = Channel+ { chResp :: !(MVar B.ByteString)+ , chBuffer :: !(IORef (ForeignPtr Word8))+ }++instance Buildable Channel where+ byteString bs+ | B.length bs < 4096 = byteStringCopy bs+ | otherwise = flush <> Builder (\(Channel v _) b -> b <$ putMVar v bs)+ {-# INLINE byteString #-}+ flush = Builder $ \(Channel v ref) (Buffer end ptr) -> do+ ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref+ let len = minusPtr ptr ptr0+ when (len > 0) $ putMVar v $! B.unsafeCreate len $ \dst -> B.memcpy dst ptr0 len+ return $! Buffer end ptr0+ {-# INLINE flush #-}+ allocate = allocateConstant chBuffer+ {-# INLINE allocate #-}++toLazyByteString :: BuilderFor Channel -> BL.ByteString+toLazyByteString body = unsafePerformIO $ do+ resp <- newEmptyMVar++ let initialSize = 4096+ fptr <- mallocForeignPtrBytes initialSize+ ref <- newIORef fptr+ let ptr = unsafeForeignPtrToPtr fptr++ let final (Left e) = throw e+ final (Right _) = putMVar resp B.empty+ _ <- flip forkFinally final $ unBuilder (body <> flush) (Channel resp ref)+ $ Buffer (ptr `plusPtr` initialSize) ptr++ let go _ = unsafePerformIO $ do+ bs <- takeMVar resp+ return $! if B.null bs+ then BL.empty+ else BL.Chunk bs (go ())+ return $ go ()+{-# INLINE toLazyByteString #-}++data PutBuilderEnv = PBE+ { pbHandle :: !Handle+ , pbBuffer :: !(IORef (ForeignPtr Word8))+ , pbTotal :: !(IORef Int)+ }++-- | Allocate a new buffer.+allocateConstant :: (s -> IORef (ForeignPtr Word8)) -> Int -> BuilderFor s+allocateConstant f len = Builder $ \env (Buffer _ _) -> do+ fptr <- mallocForeignPtrBytes len+ writeIORef (f env) fptr+ let ptr1 = unsafeForeignPtrToPtr fptr+ return $! Buffer (ptr1 `plusPtr` len) ptr1+{-# INLINE allocateConstant #-}++instance Buildable PutBuilderEnv where+ byteString bs+ | len > 4096 = mappend flush $ Builder $ \(PBE h _ _) buf -> do+ B.hPut h bs+ return buf+ | otherwise = byteStringCopy bs+ where+ len = B.length bs+ {-# INLINE byteString #-}++ flush = Builder $ \(PBE h ref counter) (Buffer end ptr) -> do+ ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref+ let len = minusPtr ptr ptr0+ modifyIORef' counter (+len)+ hPutBuf h ptr0 len+ return $! Buffer end ptr0+ {-# INLINE flush #-}++ allocate = allocateConstant pbBuffer+ {-# INLINE allocate #-}++-- | Write a 'Builder' into a handle and obtain the number of bytes written.+-- 'flush' does not imply actual disk operations. Set 'NoBuffering' if you want+-- it to write the content immediately.+hPutBuilderLen :: Handle -> BuilderFor PutBuilderEnv -> IO Int+hPutBuilderLen h b = do+ let initialSize = 4096+ fptr <- mallocForeignPtrBytes initialSize+ ref <- newIORef fptr+ let ptr = unsafeForeignPtrToPtr fptr+ counter <- newIORef 0+ _ <- unBuilder (b <> flush) (PBE h ref counter) (Buffer (ptr `plusPtr` initialSize) ptr)+ readIORef counter+{-# INLINE hPutBuilderLen #-}++data SocketEnv = SE+ { seSocket :: !S.Socket+ , seBuffer :: !(IORef (ForeignPtr Word8))+ , seCounter :: !(IORef Int)+ }++sendBufRange :: S.Socket -> Ptr Word8 -> Ptr Word8 -> IO ()+sendBufRange sock ptr0 ptr1 = go ptr0 where+ go p+ | p >= ptr1 = return ()+ | otherwise = do+ sent <- S.sendBuf sock p (minusPtr ptr1 p)+ S.withFdSocket sock $ threadWaitWrite . fromIntegral+ when (sent > 0) $ go $ p `plusPtr` sent++instance Buildable SocketEnv where+ byteString bs+ | len > 4096 = mappend flush $ Builder $ \(SE sock _ _) (Buffer end ptr) -> do+ S.sendAll sock bs+ return $! Buffer end ptr+ | otherwise = byteStringCopy bs+ where+ len = B.length bs+ {-# INLINE byteString #-}++ flush = Builder $ \(SE sock ref counter) (Buffer end ptr1) -> do+ ptr0 <- unsafeForeignPtrToPtr <$> readIORef ref+ sendBufRange sock ptr0 ptr1+ modifyIORef' counter (+minusPtr ptr1 ptr0)+ return $! Buffer end ptr0+ {-# INLINE flush #-}++ allocate = allocateConstant seBuffer++-- | Write a 'Builder' into a handle and obtain the number of bytes written.+sendBuilder :: S.Socket -> BuilderFor SocketEnv -> IO Int+sendBuilder sock b = do+ let initialSize = 4096+ fptr <- mallocForeignPtrBytes initialSize+ ref <- newIORef fptr+ let ptr = unsafeForeignPtrToPtr fptr+ counter <- newIORef 0+ _ <- unBuilder (b <> flush) (SE sock ref counter) (Buffer (ptr `plusPtr` initialSize) ptr)+ readIORef counter+{-# INLINE sendBuilder #-}++{-# INLINE encodeUtf8BuilderEscaped #-}++-- | Encode 'T.Text' with a custom escaping function+encodeUtf8BuilderEscaped :: B.BoundedPrim Word8 -> T.Text -> Builder+encodeUtf8BuilderEscaped be = step where+ bound = max 4 $ B.sizeBound be++ step (T.Text arr off len) = Builder $ loop off where+ iend = off + len+ loop !i0 env !br@(Buffer ope op0)+ | i0 >= iend = return br+ | outRemaining > 0 = goPartial (i0 + min outRemaining inpRemaining)+ | otherwise = unBuilder (ensure bound (loop i0 env)) env br+ where+ outRemaining = (ope `minusPtr` op0) `div` bound+ inpRemaining = iend - i0++ goPartial !iendTmp = go i0 op0+ where+ go !i !op+ | i < iendTmp = case A.unsafeIndex arr i of+ w | w <= 0x7F -> do+ B.runB be (fromIntegral w) op >>= go (i + 1)+ | w <= 0x7FF -> do+ poke8 0 $ (w `shiftR` 6) + 0xC0+ poke8 1 $ (w .&. 0x3f) + 0x80+ go (i + 1) (op `plusPtr` 2)+ | 0xD800 <= w && w <= 0xDBFF -> do+ let c = ord $ U16.chr2 w (A.unsafeIndex arr (i+1))+ poke8 0 $ (c `shiftR` 18) + 0xF0+ poke8 1 $ ((c `shiftR` 12) .&. 0x3F) + 0x80+ poke8 2 $ ((c `shiftR` 6) .&. 0x3F) + 0x80+ poke8 3 $ (c .&. 0x3F) + 0x80+ go (i + 2) (op `plusPtr` 4)+ | otherwise -> do+ poke8 0 $ (w `shiftR` 12) + 0xE0+ poke8 1 $ ((w `shiftR` 6) .&. 0x3F) + 0x80+ poke8 2 $ (w .&. 0x3F) + 0x80+ go (i + 1) (op `plusPtr` 3)+ | otherwise = loop i env (Buffer ope op)+ where+ poke8 :: Integral a => Int -> a -> IO ()+ poke8 j v = S.poke (op `plusPtr` j) (fromIntegral v :: Word8)++foreign import ccall unsafe "memmove"+ c_memmove :: Ptr Word8 -> Ptr Word8 -> Int -> IO ()++-- | Decimal encoding of a positive 'Double'.+{-# INLINE grisu3 #-}+grisu3 :: Double -> Maybe (B.ByteString, Int)+grisu3 d = unsafeDupablePerformIO $ allocaArray 2 $ \plen -> do+ fptr <- B.mallocByteString 18+ let pexp = plusPtr plen (S.sizeOf (undefined :: CInt))+ success <- withForeignPtr fptr $ \ptr -> c_grisu3 (realToFrac d) ptr plen pexp+ if success == 0+ then return Nothing+ else do+ len <- fromIntegral <$> S.peek plen+ e <- fromIntegral <$> S.peek pexp+ return $ Just (B.PS fptr 0 len, len + e)++foreign import ccall unsafe "static grisu3"+ c_grisu3 :: CDouble -> Ptr Word8 -> Ptr CInt -> Ptr CInt -> IO CInt