packages feed

ptr-poker (empty) → 0.1

raw patch · 16 files changed

+1656/−0 lines, 16 filesdep +basedep +bytestringdep +hedgehogsetup-changed

Dependencies added: base, bytestring, hedgehog, numeric-limits, ptr-poker, rerebase, scientific, text

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2020 Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ 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);+}
+ cbits/int_encoding.c view
@@ -0,0 +1,65 @@+/*+ * Copyright (c) 2020 Nikita Volkov <nikita.y.volkov@mail.ru>.+ */++#include <string.h>+#include <stdbool.h>+#include <stdint.h>+#include <stdio.h>+#include <stdlib.h>+++void rev_poke_int64+(+  int64_t val,+  uint8_t* dst+)+{+  bool negate = false;++  if (val < 0)+  {+    int64_t b4 = val;+    val /= 10;+    if (val)+    {+      *--dst = val * 10 - b4 + 48;+      val = -val;+      negate = true;+    }+    else+    {+      *(dst - 1) = val * 10 - b4 + 48;+      *(dst - 2) = '-';+      return;+    }+  }++  do+  {+    int64_t b4 = val;+    val /= 10;+    *--dst = b4 - val * 10 + 48;+  }+  while (val);++  if (negate)+  {+    *--dst = '-';+  }+}++void rev_poke_uint64+(+  uint64_t val,+  uint8_t* dst+)+{+  do+  {+    uint64_t b4 = val;+    val /= 10;+    *--dst = b4 - val * 10 + 48;+  }+  while (val);+}
+ cbits/itoa.c view
@@ -0,0 +1,216 @@+///////////////////////////////////////////////////////////////+// Encoding numbers using ASCII characters                   //+//                                                           //+// inspired by: http://www.jb.man.ac.uk/~slowe/cpp/itoa.html //+// Borrowed from the "bytestring" library                    //+///////////////////////////////////////////////////////////////++#include <stdio.h>++// Decimal Encoding+///////////////////++static const char* digits = "0123456789abcdef";++// signed integers+char* int_dec (int x, char* buf)+{+    char c, *ptr = buf, *next_free;+    int x_tmp;++    // we cannot negate directly as  0 - (minBound :: Int) = minBound+    if (x < 0) {+        *ptr++ = '-';+        buf++;+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x * 10 - x_tmp];+        if (x == 0)+          return ptr;+        else+          x = -x;+    }++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x_tmp - x * 10];+    } while ( x );++    // reverse written digits+    next_free = ptr--;+    while (buf < ptr) {+        c       = *ptr;+        *ptr--  = *buf;+        *buf++  = c;+    }+    return next_free;+}++// signed long long ints (64 bit integers)+char* long_long_int_dec (long long int x, char* buf)+{+    char c, *ptr = buf, *next_free;+    long long int x_tmp;++    // we cannot negate directly as  0 - (minBound :: Int) = minBound+    if (x < 0) {+        *ptr++ = '-';+        buf++;+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x * 10 - x_tmp];+        if (x == 0)+          return ptr;+        else+          x = -x;+    }++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x_tmp - x * 10];+    } while ( x );++    // reverse written digits+    next_free = ptr--;+    while (buf < ptr) {+        c       = *ptr;+        *ptr--  = *buf;+        *buf++  = c;+    }+    return next_free;+}++// unsigned integers+char* uint_dec (unsigned int x, char* buf)+{+    char c, *ptr = buf, *next_free;+    unsigned int x_tmp;++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x_tmp - x * 10];+    } while ( x );++    // reverse written digits+    next_free = ptr--;+    while (buf < ptr) {+        c       = *ptr;+        *ptr--  = *buf;+        *buf++  = c;+    }+    return next_free;+}++// unsigned long ints+char* long_long_uint_dec (long long unsigned int x, char* buf)+{+    char c, *ptr = buf, *next_free;+    long long unsigned int x_tmp;++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *ptr++ = digits[x_tmp - x * 10];+    } while ( x );++    // reverse written digits+    next_free = ptr--;+    while (buf < ptr) {+        c       = *ptr;+        *ptr--  = *buf;+        *buf++  = c;+    }+    return next_free;+}+++// Padded, decimal, positive integers for the decimal output of bignums+///////////////////////////////////////////////////////////////////////++// Padded (9 digits), decimal, positive int:+// We will use it with numbers that fit in 31 bits; i.e., numbers smaller than+// 10^9, as "31 * log 2 / log 10 = 9.33"+void int_dec_padded9 (int x, char* buf)+{+    const int max_width_int32_dec = 9;+    char* ptr = buf + max_width_int32_dec;+    int x_tmp;++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *(--ptr) = digits[x_tmp - x * 10];+    } while ( x );++    // pad beginning+    while (buf < ptr) { *(--ptr) = '0'; }+}++// Padded (19 digits), decimal, positive long long int:+// We will use it with numbers that fit in 63 bits; i.e., numbers smaller than+// 10^18, as "63 * log 2 / log 10 = 18.96"+void long_long_int_dec_padded18 (long long int x, char* buf)+{+    const int max_width_int64_dec = 18;+    char* ptr = buf + max_width_int64_dec;+    long long int x_tmp;++    // encode positive number as little-endian decimal+    do {+        x_tmp = x;+        x /= 10;+        *(--ptr) = digits[x_tmp - x * 10];+    } while ( x );++    // pad beginning+    while (buf < ptr) { *(--ptr) = '0'; }+}+++///////////////////////+// Hexadecimal encoding+///////////////////////++// unsigned ints (32 bit words)+char* uint_hex (unsigned int x, char* buf) {+    // write hex representation in reverse order+    char c, *ptr = buf, *next_free;+    do {+        *ptr++ = digits[x & 0xf];+        x >>= 4;+    } while ( x );+    // invert written digits+    next_free = ptr--;+    while(buf < ptr) {+        c      = *ptr;+        *ptr-- = *buf;+        *buf++ = c;+    }+    return next_free;+};++// unsigned long ints (64 bit words)+char* long_long_uint_hex (long long unsigned int x, char* buf) {+    // write hex representation in reverse order+    char c, *ptr = buf, *next_free;+    do {+        *ptr++ = digits[x & 0xf];+        x >>= 4;+    } while ( x );+    // invert written digits+    next_free = ptr--;+    while(buf < ptr) {+        c      = *ptr;+        *ptr-- = *buf;+        *buf++ = c;+    }+    return next_free;+};
+ library/PtrPoker/ByteString.hs view
@@ -0,0 +1,38 @@+module PtrPoker.ByteString+where++import PtrPoker.Prelude+import Data.ByteString.Internal+import Data.ByteString.Builder.Prim+import qualified Data.Text as Text+import qualified Data.Text.Encoding as TextEncoding+import qualified Data.ByteString.Lazy as Lazy+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Builder.Extra as Builder+import qualified Data.ByteString.Builder.Scientific as ScientificBuilder+import qualified PtrPoker.Ffi as Ffi+++builderWithStrategy strategy builder =+  builder+    & Builder.toLazyByteStringWith strategy Lazy.empty+    & Lazy.toStrict++scientific :: Scientific -> ByteString+scientific sci =+  sci+    & ScientificBuilder.scientificBuilder+    & builderWithStrategy (Builder.untrimmedStrategy 128 128)++double :: Double -> ByteString+double dbl =+  unsafeCreateUptoN 24 (\ ptr ->+    Ffi.pokeDouble dbl ptr+      & fmap fromIntegral)++unsafeCreateDownToN :: Int -> (Ptr Word8 -> IO Int) -> ByteString+unsafeCreateDownToN allocSize populate =+  unsafeDupablePerformIO $ do+    fp <- mallocByteString allocSize+    actualSize <- withForeignPtr fp (\ p -> populate (plusPtr p (pred allocSize)))+    return $! PS fp (allocSize - actualSize) actualSize
+ library/PtrPoker/Ffi.hs view
@@ -0,0 +1,33 @@+module PtrPoker.Ffi+where++import PtrPoker.Prelude+import Foreign.C+++foreign import ccall unsafe "static int_dec"+  pokeIntInDec :: CInt -> Ptr Word8 -> IO (Ptr Word8)++foreign import ccall unsafe "static long_long_int_dec"+  pokeLongLongIntInDec :: CLLong -> Ptr Word8 -> IO (Ptr Word8)++foreign import ccall unsafe "static uint_dec"+  pokeUIntInDec :: CUInt -> Ptr Word8 -> IO (Ptr Word8)++foreign import ccall unsafe "static long_long_uint_dec"+  pokeLongLongUIntInDec :: CULLong -> Ptr Word8 -> IO (Ptr Word8)++foreign import ccall unsafe "static uint_hex"+  pokeUIntInHex :: CUInt -> Ptr Word8 -> IO (Ptr Word8)++foreign import ccall unsafe "static long_long_uint_hex"+  pokeLongLongUIntInHex :: CULLong -> Ptr Word8 -> IO (Ptr Word8)++foreign import ccall unsafe "static rev_poke_int64"+  revPokeInt64 :: CLLong -> Ptr Word8 -> IO ()++foreign import ccall unsafe "static rev_poke_uint64"+  revPokeUInt64 :: CULLong -> Ptr Word8 -> IO ()++foreign import ccall unsafe "static dtoa_grisu3"+  pokeDouble :: Double -> Ptr Word8 -> IO CInt
+ library/PtrPoker/IO/ByteString.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE CPP #-}+module PtrPoker.IO.ByteString+where++import PtrPoker.Prelude+import Data.ByteString.Internal+++#if MIN_VERSION_bytestring(0,11,0)++{-# INLINE pokeByteString #-}+pokeByteString :: Ptr Word8 -> ByteString -> IO (Ptr Word8)+pokeByteString ptr (BS fptr length) =+  {-# SCC "pokeByteString" #-}+  withForeignPtr fptr $ \ bytesPtr ->+    memcpy ptr bytesPtr length $>+    plusPtr ptr length++#else++{-# INLINE pokeByteString #-}+pokeByteString :: Ptr Word8 -> ByteString -> IO (Ptr Word8)+pokeByteString ptr (PS fptr offset length) =+  {-# SCC "pokeByteString" #-}+  withForeignPtr fptr $ \ bytesPtr ->+    memcpy ptr (plusPtr bytesPtr offset) length $>+    plusPtr ptr length++#endif
+ library/PtrPoker/IO/Prim.hs view
@@ -0,0 +1,157 @@+{-# LANGUAGE CPP #-}+module PtrPoker.IO.Prim+where++import PtrPoker.Prelude+import qualified PtrPoker.UncheckedShifting as UncheckedShifting+++{-# INLINE pokeStorable #-}+pokeStorable :: Storable a => Ptr Word8 -> a -> IO ()+pokeStorable ptr value =+  {-# SCC "pokeStorable" #-} +  poke (castPtr ptr) value++{-# INLINE pokeWord8 #-}+pokeWord8 :: Ptr Word8 -> Word8 -> IO ()+pokeWord8 ptr value =+  {-# SCC "pokeWord8" #-} +  poke ptr value++{-# INLINE pokeWord8Off #-}+pokeWord8Off :: Ptr Word8 -> Int -> Word8 -> IO ()+pokeWord8Off ptr off value =+  {-# SCC "pokeWord8Off" #-} +  pokeByteOff ptr off value++{-# INLINE pokeBEWord16 #-}+pokeBEWord16 :: Ptr Word8 -> Word16 -> IO ()+#ifdef WORDS_BIGENDIAN+pokeBEWord16 =+  {-# SCC "pokeBEWord16" #-} +  pokeStorable+#else+pokeBEWord16 ptr value =+  {-# SCC "pokeBEWord16" #-} +  do+    pokeStorable ptr (fromIntegral (UncheckedShifting.shiftr_w16 value 8) :: Word8)+    pokeByteOff ptr 1 (fromIntegral value :: Word8)+#endif++{-# INLINE pokeBEWord32 #-}+pokeBEWord32 :: Ptr Word8 -> Word32 -> IO ()+#ifdef WORDS_BIGENDIAN+pokeBEWord32 =+  {-# SCC "pokeBEWord32" #-} +  pokeStorable+#else+pokeBEWord32 ptr value =+  {-# SCC "pokeBEWord32" #-} +  do+    pokeStorable ptr (fromIntegral (UncheckedShifting.shiftr_w32 value 24) :: Word8)+    pokeByteOff ptr 1 (fromIntegral (UncheckedShifting.shiftr_w32 value 16) :: Word8)+    pokeByteOff ptr 2 (fromIntegral (UncheckedShifting.shiftr_w32 value 8) :: Word8)+    pokeByteOff ptr 3 (fromIntegral value :: Word8)+#endif++{-# INLINE pokeBEWord64 #-}+pokeBEWord64 :: Ptr Word8 -> Word64 -> IO ()+#ifdef WORDS_BIGENDIAN+pokeBEWord64 =+  {-# SCC "pokeBEWord64" #-} +  pokeStorable+#else+#if WORD_SIZE_IN_BITS < 64+--+-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to+-- Word32, and write that+--+pokeBEWord64 ptr value =+  {-# SCC "pokeBEWord64" #-} +  do+    pokeBEWord32 ptr (fromIntegral (UncheckedShifting.shiftr_w64 value 32))+    pokeBEWord32 (plusPtr ptr 4) (fromIntegral value)+#else+pokeBEWord64 ptr value =+  {-# SCC "pokeBEWord64" #-} +  do+    pokeStorable ptr (fromIntegral (UncheckedShifting.shiftr_w64 value 56) :: Word8)+    pokeByteOff ptr 1 (fromIntegral (UncheckedShifting.shiftr_w64 value 48) :: Word8)+    pokeByteOff ptr 2 (fromIntegral (UncheckedShifting.shiftr_w64 value 40) :: Word8)+    pokeByteOff ptr 3 (fromIntegral (UncheckedShifting.shiftr_w64 value 32) :: Word8)+    pokeByteOff ptr 4 (fromIntegral (UncheckedShifting.shiftr_w64 value 24) :: Word8)+    pokeByteOff ptr 5 (fromIntegral (UncheckedShifting.shiftr_w64 value 16) :: Word8)+    pokeByteOff ptr 6 (fromIntegral (UncheckedShifting.shiftr_w64 value  8) :: Word8)+    pokeByteOff ptr 7 (fromIntegral value :: Word8)+#endif+#endif++{-# INLINE pokeLEWord16 #-}+pokeLEWord16 :: Ptr Word8 -> Word16 -> IO ()+#ifdef WORDS_BIGENDIAN+pokeLEWord16 p w =+  {-# SCC "pokeLEWord16" #-} +  do+    pokeWord8 p (fromIntegral w)+    pokeWord8Off p 1 (fromIntegral (UncheckedShifting.shiftr_w16 w 8))+#else+pokeLEWord16 =+  {-# SCC "pokeLEWord16" #-} +  pokeStorable+#endif++{-# INLINE pokeLEWord32 #-}+pokeLEWord32 :: Ptr Word8 -> Word32 -> IO ()+#ifdef WORDS_BIGENDIAN+pokeLEWord32 p w =+  {-# SCC "pokeLEWord32" #-}+  do+    pokeWord8 p (fromIntegral w)+    pokeWord8Off p 1 (fromIntegral (UncheckedShifting.shiftr_w32 w 8))+    pokeWord8Off p 2 (fromIntegral (UncheckedShifting.shiftr_w32 w 16))+    pokeWord8Off p 3 (fromIntegral (UncheckedShifting.shiftr_w32 w 24))+#else+pokeLEWord32 =+  {-# SCC "pokeLEWord32" #-} +  pokeStorable+#endif++{-# INLINE pokeLEWord64 #-}+pokeLEWord64 :: Ptr Word8 -> Word64 -> IO ()+#ifdef WORDS_BIGENDIAN+#if WORD_SIZE_IN_BITS < 64+--+-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to+-- Word32, and write that+--+pokeLEWord64 p w =+  {-# SCC "pokeLEWord64" #-} +  do+    let b = fromIntegral (UncheckedShifting.shiftr_w64 w 32) :: Word32+        a = fromIntegral w :: Word32+    pokeWord8 p (fromIntegral a)+    pokeWord8Off p 1 (fromIntegral (UncheckedShifting.shiftr_w32 a 8))+    pokeWord8Off p 2 (fromIntegral (UncheckedShifting.shiftr_w32 a 16))+    pokeWord8Off p 3 (fromIntegral (UncheckedShifting.shiftr_w32 a 24))+    pokeWord8Off p 4 (fromIntegral b)+    pokeWord8Off p 5 (fromIntegral (UncheckedShifting.shiftr_w32 b 8))+    pokeWord8Off p 6 (fromIntegral (UncheckedShifting.shiftr_w32 b 16))+    pokeWord8Off p 7 (fromIntegral (UncheckedShifting.shiftr_w32 b 24))+#else+pokeLEWord64 p w =+  {-# SCC "pokeLEWord64" #-} +  do+    pokeWord8 p (fromIntegral w)+    pokeWord8Off p 1 (fromIntegral (UncheckedShifting.shiftr_w64 w 8))+    pokeWord8Off p 2 (fromIntegral (UncheckedShifting.shiftr_w64 w 16))+    pokeWord8Off p 3 (fromIntegral (UncheckedShifting.shiftr_w64 w 24))+    pokeWord8Off p 4 (fromIntegral (UncheckedShifting.shiftr_w64 w 32))+    pokeWord8Off p 5 (fromIntegral (UncheckedShifting.shiftr_w64 w 40))+    pokeWord8Off p 6 (fromIntegral (UncheckedShifting.shiftr_w64 w 48))+    pokeWord8Off p 7 (fromIntegral (UncheckedShifting.shiftr_w64 w 56))+#endif+#else+pokeLEWord64 =+  {-# SCC "pokeLEWord64" #-} +  pokeStorable+#endif
+ library/PtrPoker/Poke.hs view
@@ -0,0 +1,138 @@+module PtrPoker.Poke+where++import PtrPoker.Prelude hiding (concat)+import qualified PtrPoker.IO.ByteString as ByteStringIO+import qualified PtrPoker.IO.Prim as PrimIO+import qualified PtrPoker.Ffi as Ffi+++{-# RULES+  "foldMap" forall f foldable. foldMap f foldable =+    Poke $ \ p -> foldM (\ p (Poke poker) -> poker p) p foldable+  #-}++newtype Poke =+  Poke { pokePtr :: Ptr Word8 -> IO (Ptr Word8) }++instance Semigroup Poke where+  {-# INLINE[1] (<>) #-}+  Poke lIO <> Poke rIO =+    Poke (lIO >=> rIO)+  sconcat =+    concat++instance Monoid Poke where+  {-# INLINE[1] mempty #-}+  mempty =+    Poke return+  mconcat =+    concat++instance IsString Poke where+  fromString = byteString . fromString++{-# INLINE[1] concat #-}+concat :: Foldable f => f Poke -> Poke+concat pokers =+  Poke (\ p -> foldM (\ p (Poke io) -> io p) p pokers)++{-# INLINE[1] byteString #-}+byteString :: ByteString -> Poke+byteString bs =+  Poke $ \ ptr -> ByteStringIO.pokeByteString ptr bs++{-# INLINE[1] word8 #-}+word8 :: Word8 -> Poke+word8 a =+  Poke (\ p -> PrimIO.pokeWord8 p a $> plusPtr p 1)++{-| Little-endian Word64 poker. -}+{-# INLINE[1] lWord64 #-}+lWord64 :: Word64 -> Poke+lWord64 a =+  Poke (\ p -> PrimIO.pokeLEWord64 p a $> plusPtr p 8)++{-| Big-endian Word64 poker. -}+{-# INLINE[1] bWord64 #-}+bWord64 :: Word64 -> Poke+bWord64 a =+  Poke (\ p -> PrimIO.pokeBEWord64 p a $> plusPtr p 8)+++-- * ASCII integers+-------------------------++{-# INLINE[1] int8AsciiDec #-}+int8AsciiDec :: Int8 -> Poke+int8AsciiDec a =+  Poke (Ffi.pokeIntInDec (fromIntegral a))++{-# INLINE[1] int16AsciiDec #-}+int16AsciiDec :: Int16 -> Poke+int16AsciiDec a =+  Poke (Ffi.pokeIntInDec (fromIntegral a))++{-# INLINE[1] int32AsciiDec #-}+int32AsciiDec :: Int32 -> Poke+int32AsciiDec a =+  Poke (Ffi.pokeIntInDec (fromIntegral a))++{-# INLINE[1] int64AsciiDec #-}+int64AsciiDec :: Int64 -> Poke+int64AsciiDec a =+  Poke (Ffi.pokeLongLongIntInDec (fromIntegral a))++{-# INLINE[1] intAsciiDec #-}+intAsciiDec :: Int -> Poke+intAsciiDec a =+  Poke (Ffi.pokeLongLongIntInDec (fromIntegral a))++{-# INLINE[1] word8AsciiDec #-}+word8AsciiDec :: Word8 -> Poke+word8AsciiDec a =+  Poke (Ffi.pokeUIntInDec (fromIntegral a))++{-# INLINE[1] word16AsciiDec #-}+word16AsciiDec :: Word16 -> Poke+word16AsciiDec a =+  Poke (Ffi.pokeUIntInDec (fromIntegral a))++{-# INLINE[1] word32AsciiDec #-}+word32AsciiDec :: Word32 -> Poke+word32AsciiDec a =+  Poke (Ffi.pokeUIntInDec (fromIntegral a))++{-# INLINE[1] word64AsciiDec #-}+word64AsciiDec :: Word64 -> Poke+word64AsciiDec a =+  Poke (Ffi.pokeLongLongUIntInDec (fromIntegral a))++{-# INLINE[1] wordAsciiDec #-}+wordAsciiDec :: Word -> Poke+wordAsciiDec a =+  Poke (Ffi.pokeLongLongUIntInDec (fromIntegral a))++{-# INLINE doubleAsciiDec #-}+doubleAsciiDec :: Double -> Poke+doubleAsciiDec a =+  Poke $ \ ptr ->+    Ffi.pokeDouble a ptr+      & fmap (plusPtr ptr . fromIntegral)+++-- * Low level+-------------------------++{-|+Having the amount of bytes to be written precomputed,+executes an action, which fills the pointer going downward.+-}+{-# INLINE sizedReverse #-}+sizedReverse :: Int -> (Ptr Word8 -> IO a) -> Poke+sizedReverse size action =+  Poke $ \ ptr ->+    let+      afterPtr =+        plusPtr ptr size+      in action afterPtr $> afterPtr
+ library/PtrPoker/Prelude.hs view
@@ -0,0 +1,92 @@+module PtrPoker.Prelude+( +  module Exports,+  showAsText,+)+where++-- base+-------------------------+import Control.Applicative as Exports hiding (WrappedArrow(..))+import Control.Arrow as Exports hiding (first, second)+import Control.Category as Exports+import Control.Concurrent as Exports+import Control.Exception as Exports+import Control.Monad as Exports hiding (fail, mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.IO.Class as Exports+import Control.Monad.Fail as Exports+import Control.Monad.Fix as Exports hiding (fix)+import Control.Monad.ST as Exports+import Data.Bifunctor as Exports+import Data.Bits as Exports+import Data.Bool as Exports+import Data.Char as Exports+import Data.Coerce as Exports+import Data.Complex as Exports+import Data.Data as Exports+import Data.Dynamic as Exports+import Data.Either as Exports+import Data.Fixed as Exports+import Data.Foldable as Exports hiding (toList)+import Data.Function as Exports hiding (id, (.))+import Data.Functor as Exports+import Data.Functor.Compose as Exports+import Data.Int as Exports+import Data.IORef as Exports+import Data.Ix as Exports+import Data.List as Exports hiding (sortOn, isSubsequenceOf, uncons, concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.List.NonEmpty as Exports (NonEmpty(..))+import Data.Maybe as Exports+import Data.Monoid as Exports hiding (Alt, (<>))+import Data.Ord as Exports+import Data.Proxy as Exports+import Data.Ratio as Exports+import Data.Semigroup as Exports hiding (First(..), Last(..))+import Data.STRef as Exports+import Data.String as Exports+import Data.Traversable as Exports+import Data.Tuple as Exports+import Data.Unique as Exports+import Data.Version as Exports+import Data.Void as Exports+import Data.Word as Exports+import Debug.Trace as Exports+import Foreign.ForeignPtr as Exports+import Foreign.Ptr as Exports+import Foreign.StablePtr as Exports+import Foreign.Storable as Exports+import GHC.Conc as Exports hiding (orElse, withMVar, threadWaitWriteSTM, threadWaitWrite, threadWaitReadSTM, threadWaitRead)+import GHC.Exts as Exports (IsList(..), lazy, inline, sortWith, groupWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import GHC.OverloadedLabels as Exports+import Numeric as Exports+import Prelude as Exports hiding (fail, concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, id, (.))+import System.Environment as Exports+import System.Exit as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import System.IO.Unsafe as Exports+import System.Mem as Exports+import System.Mem.StableName as Exports+import System.Timeout as Exports+import Text.ParserCombinators.ReadP as Exports (ReadP, readP_to_S, readS_to_P)+import Text.ParserCombinators.ReadPrec as Exports (ReadPrec, readPrec_to_P, readP_to_Prec, readPrec_to_S, readS_to_Prec)+import Text.Printf as Exports (printf, hPrintf)+import Text.Read as Exports (Read(..), readMaybe, readEither)+import Unsafe.Coerce as Exports++-- text+-------------------------+import Data.Text as Exports (Text)++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- scientific+-------------------------+import Data.Scientific as Exports (Scientific)++showAsText :: Show a => a -> Text+showAsText = show >>> fromString
+ library/PtrPoker/Size.hs view
@@ -0,0 +1,130 @@+{-|+Functions that compute the required allocation size by value.+-}+module PtrPoker.Size+where++import PtrPoker.Prelude+++{-# INLINE word64AsciiDec #-}+word64AsciiDec :: Word64 -> Int+word64AsciiDec x =+  if x > 9999999999+    then if x > 99999999999999+      then if x > 9999999999999999+        then if x > 99999999999999999+          then if x > 999999999999999999+            then if x > 9999999999999999999+              then 20+              else 19+            else 18+          else 17+        else if x > 999999999999999+          then 16+          else 15+      else if x > 999999999999+        then if x > 9999999999999+          then 14+          else 13+        else if x > 99999999999+          then 12+          else 11+    else if x > 99999+      then if x > 9999999+        then if x > 99999999+          then if x > 999999999+            then 10+            else 9+          else 8+        else if x > 999999+          then 7+          else 6+      else if x > 99+        then if x > 999+          then if x > 9999+            then 5+            else 4+          else 3+        else if x > 9+          then 2+          else 1++{-# INLINE int64AsciiDec #-}+int64AsciiDec :: Int64 -> Int+int64AsciiDec x =+  if x < 0+    then if x < -9999999999+      then if x < -99999999999999+        then if x < -9999999999999999+          then if x < -99999999999999999+            then if x < -999999999999999999+              then 20+              else 19+            else 18+          else if x < -999999999999999+            then 17+            else 16+        else if x < -999999999999+          then if x < -9999999999999+            then 15+            else 14+          else if x < -99999999999+            then 13+            else 12+      else if x < -99999+        then if x < -9999999+          then if x < -99999999+            then if x < -999999999+              then 11+              else 10+            else 9+          else if x < -999999+            then 8+            else 7+        else if x < -99+          then if x < -999+            then if x < -9999+              then 6+              else 5+            else 4+          else if x < -9+            then 3+            else 2+    else if x > 9999999999+      then if x > 99999999999999+        then if x > 9999999999999999+          then if x > 99999999999999999+            then if x > 999999999999999999+              then 19+              else 18+            else 17+          else if x > 999999999999999+            then 16+            else 15+        else if x > 999999999999+          then if x > 9999999999999+            then 14+            else 13+          else if x > 99999999999+            then 12+            else 11+      else if x > 99999+        then if x > 9999999+          then if x > 99999999+            then if x > 999999999+              then 10+              else 9+            else 8+          else if x > 999999+            then 7+            else 6+        else if x > 99+          then if x > 999+            then if x > 9999+              then 5+              else 4+            else 3+          else if x > 9+            then 2+            else 1
+ library/PtrPoker/UncheckedShifting.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE CPP #-}+-- |+-- Copyright   : (c) 2010 Simon Meier+--+--               Original serialization code from 'Data.Binary.Builder':+--               (c) Lennart Kolmodin, Ross Patterson+--+-- License     : BSD3-style+--+-- Utilty module defining unchecked shifts.+--+-- These functions are undefined when the amount being shifted by is+-- greater than the size in bits of a machine Int#.-+--+module PtrPoker.UncheckedShifting (+    shiftr_w16+  , shiftr_w32+  , shiftr_w64+  , shiftr_w++  , caseWordSize_32_64+  ) where+++#if !defined(__HADDOCK__)+import GHC.Base+import GHC.Word (Word32(..),Word16(..),Word64(..))++#if WORD_SIZE_IN_BITS < 64 && __GLASGOW_HASKELL__ >= 608+import GHC.Word (uncheckedShiftRL64#)+#endif+#else+import Data.Word+#endif++import Prelude+import Foreign+++------------------------------------------------------------------------+-- Unchecked shifts++-- | Right-shift of a 'Word16'.+{-# INLINE shiftr_w16 #-}+shiftr_w16 :: Word16 -> Int -> Word16++-- | Right-shift of a 'Word32'.+{-# INLINE shiftr_w32 #-}+shiftr_w32 :: Word32 -> Int -> Word32++-- | Right-shift of a 'Word64'.+{-# INLINE shiftr_w64 #-}+shiftr_w64 :: Word64 -> Int -> Word64++-- | Right-shift of a 'Word'.+{-# INLINE shiftr_w #-}+shiftr_w :: Word -> Int -> Word+#if WORD_SIZE_IN_BITS < 64+shiftr_w w s = fromIntegral $ (`shiftr_w32` s) $ fromIntegral w+#else+shiftr_w w s = fromIntegral $ (`shiftr_w64` s) $ fromIntegral w+#endif++#if !defined(__HADDOCK__)+shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#`   i)+shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#`   i)++#if WORD_SIZE_IN_BITS < 64+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i)+#else+shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i)+#endif++#else+shiftr_w16 = shiftR+shiftr_w32 = shiftR+shiftr_w64 = shiftR+#endif+++-- | 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
+ library/PtrPoker/Write.hs view
@@ -0,0 +1,122 @@+module PtrPoker.Write+where++import PtrPoker.Prelude+import qualified PtrPoker.IO.ByteString as ByteStringIO+import qualified PtrPoker.IO.Prim as PrimIO+import qualified PtrPoker.Poke as Poke+import qualified PtrPoker.Size as Size+import qualified PtrPoker.Ffi as Ffi+import qualified PtrPoker.ByteString as ByteString+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Internal as ByteString+++writeToByteString :: Write -> ByteString+writeToByteString Write{..} =+  ByteString.unsafeCreate writeSize (void . Poke.pokePtr writePoke)++{-|+Specification of how much bytes to allocate and how to populate them.++Useful for creating strict bytestrings and tasks like that.+-}+data Write =+  Write {+    writeSize :: Int,+    writePoke :: Poke.Poke+    }++instance Semigroup Write where+  {-# INLINE (<>) #-}+  Write lSize lPoke <> Write rSize rPoke =+    Write (lSize + rSize) (lPoke <> rPoke)++instance Monoid Write where+  {-# INLINE mempty #-}+  mempty =+    Write 0 mempty++instance IsString Write where+  {-# INLINE fromString #-}+  fromString =+    byteString . fromString++{-# INLINE word8 #-}+word8 :: Word8 -> Write+word8 a =+  Write 1 (Poke.word8 a)++{-# INLINE word64AsciiDec #-}+word64AsciiDec :: Word64 -> Write+word64AsciiDec a =+  Write size poke+  where+    size =+      Size.word64AsciiDec a+    poke =+      Poke.sizedReverse size (Ffi.revPokeUInt64 (fromIntegral a))++{-# INLINE wordAsciiDec #-}+wordAsciiDec :: Word -> Write+wordAsciiDec =+  word64AsciiDec . fromIntegral++{-# INLINE int64AsciiDec #-}+int64AsciiDec :: Int64 -> Write+int64AsciiDec a =+  Write size poke+  where+    size =+      Size.int64AsciiDec a+    poke =+      Poke.sizedReverse size (Ffi.revPokeInt64 (fromIntegral a))++{-# INLINE intAsciiDec #-}+intAsciiDec :: Int -> Write+intAsciiDec =+  int64AsciiDec . fromIntegral++{-|+Render double interpreting non-real values,+such as @NaN@, @Infinity@, @-Infinity@,+as is.+-}+{-# INLINE doubleAsciiDec #-}+doubleAsciiDec :: Double -> Write+doubleAsciiDec a =+  if a == 0+    then word8 48+    else if isNaN a+      then "NaN"+      else if isInfinite a+        then if a < 0+          then "-Infinity"+          else "Infinity"+        else if a < 0+          then word8 45 <> byteString (ByteString.double (negate a))+          else byteString (ByteString.double a)++{-|+Render double interpreting non real values,+such as @NaN@, @Infinity@, @-Infinity@,+as zero.+-}+{-# INLINE zeroNonRealDoubleAsciiDec #-}+zeroNonRealDoubleAsciiDec :: Double -> Write+zeroNonRealDoubleAsciiDec a =+  if a == 0 || isNaN a || isInfinite a+    then word8 48+    else if a < 0+      then word8 45 <> byteString (ByteString.double (negate a))+      else byteString (ByteString.double a)++{-# INLINE scientificAsciiDec #-}+scientificAsciiDec :: Scientific -> Write+scientificAsciiDec =+  byteString . ByteString.scientific++{-# INLINE byteString #-}+byteString :: ByteString -> Write+byteString a =+  Write (ByteString.length a) (Poke.byteString a)
+ ptr-poker.cabal view
@@ -0,0 +1,53 @@+name: ptr-poker+version: 0.1+synopsis: Pointer poking action construction and composition toolkit+homepage: https://github.com/nikita-volkov/ptr-poker+bug-reports: https://github.com/nikita-volkov/ptr-poker/issues+author: Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer: Nikita Volkov <nikita.y.volkov@mail.ru>+copyright: (c) 2020 Nikita Volkov+license: MIT+license-file: LICENSE+build-type: Simple+cabal-version: >=1.10++source-repository head+  type: git+  location: git://github.com/nikita-volkov/ptr-poker.git++library+  hs-source-dirs: library+  default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples, ViewPatterns+  default-language: Haskell2010+  exposed-modules:+    PtrPoker.Poke+    PtrPoker.Write+    PtrPoker.Size+  other-modules:+    PtrPoker.ByteString+    PtrPoker.Ffi+    PtrPoker.IO.ByteString+    PtrPoker.IO.Prim+    PtrPoker.Prelude+    PtrPoker.UncheckedShifting+  c-sources:+    cbits/dtoa.c+    cbits/int_encoding.c+    cbits/itoa.c+  build-depends:+    base >=4.11 && <5,+    bytestring >=0.10 && <0.12,+    scientific >=0.3.6.2 && <0.4,+    text >=1 && <2++test-suite test+  type: exitcode-stdio-1.0+  hs-source-dirs: test+  default-extensions: BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, InstanceSigs, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, StrictData, TemplateHaskell, TupleSections, TypeApplications, TypeFamilies, TypeOperators, UnboxedTuples, ViewPatterns+  default-language: Haskell2010+  main-is: Main.hs+  build-depends:+    hedgehog >=1.0.3 && <2,+    numeric-limits >=0.1 && <0.2,+    ptr-poker,+    rerebase >=1.10.0.1 && <2
+ test/Main.hs view
@@ -0,0 +1,98 @@+module Main where++import Prelude+import Hedgehog+import Hedgehog.Main+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Data.ByteString.Char8 as Char8ByteString+import qualified PtrPoker.Write as Write+import qualified PtrPoker.Size as Size+import qualified Numeric.Limits as NumericLimits+++main =+  defaultMain $ pure $ checkParallel $ $$(discover)++prop_word64Size =+  withTests 999 $+  property $ do+    a <- forAll (Gen.word64 (Range.exponential minBound maxBound))+    Size.word64AsciiDec a+      === length (show a)++prop_int64Size =+  withTests 999 $+  property $ do+    a <- forAll (Gen.int64 (Range.exponential minBound maxBound))+    Size.int64AsciiDec a+      === length (show a)++prop_wordAsciiDec =+  withTests 999 $+  property $ do+    a <- forAll (Gen.word (Range.exponential minBound maxBound))+    let+      string =+        Char8ByteString.unpack (Write.writeToByteString (Write.wordAsciiDec a))+    annotate string+    read string === a++prop_intAsciiDec =+  withTests 999 $+  property $ do+    a <- forAll (Gen.int (Range.exponential minBound maxBound))+    let+      string =+        Char8ByteString.unpack (Write.writeToByteString (Write.intAsciiDec a))+    annotate string+    read string === a++prop_doubleAsciiDec =+  withTests 999 $+  property $ do+    a <- forAll realFloatGen+    let+      string =+        Char8ByteString.unpack (Write.writeToByteString (Write.doubleAsciiDec a))+    annotate string+    if isNaN a+      then string === "NaN"+      else read string === a++prop_realZeroNonRealDoubleAsciiDec =+  withTests 999 $+  property $ do+    a <- forAll realRealFloatGen+    let+      string =+        Char8ByteString.unpack (Write.writeToByteString (Write.zeroNonRealDoubleAsciiDec a))+    annotate string+    read string === a++prop_nonRealZeroNonRealDoubleAsciiDec =+  withTests 99 $+  property $ do+    a <- forAll nonRealRealFloatGen+    let+      string =+        Char8ByteString.unpack (Write.writeToByteString (Write.zeroNonRealDoubleAsciiDec a))+    annotate string+    read string === 0+++-- * Gens+-------------------------++realFloatGen =+  Gen.frequency [+    (99, realRealFloatGen)+    ,+    (1, nonRealRealFloatGen)+    ]++nonRealRealFloatGen =+  Gen.element [0 / 0, 1 / 0, (-1) / 0, -0]++realRealFloatGen =+  Gen.realFloat (Range.exponentialFloat NumericLimits.minValue NumericLimits.maxValue)