bytezap 1.4.0 → 1.5.0

raw patch · 13 files changed

+123/−418 lines, 13 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• bytezap.cabal +2/−7
• cbits/aligned-static-hs-data.c +0/−26
• src/Bytezap.hs +0/−1
• src/Bytezap/Common/TypeNats.hs +17/−0
• src/Bytezap/Parser/Struct.hs +25/−15
• src/Bytezap/Parser/Struct/Generic.hs +55/−13
• src/Bytezap/Parser/Struct/TypeLits/Bytes.hs +17/−16
• src/Bytezap/Poke/KnownLen.hs +1/−1
• src/Bytezap/PokeCPS.hs +0/−153
• src/Bytezap/Struct/Generic.hs +1/−1
• src/Tmp/BSExt.hs +0/−168
• src/Util/TypeNats.hs +0/−17

@@ -1,3 +1,8 @@+## 1.5.0 (2024-09-28)+* pass metadata in generic struct parser (for pretty errors)+* rewrite type-level bytestring parser (better errors)+* clean up source tree+ ## 1.4.0 (2024-09-25) * `Write` now takes a type-level `LengthType` to indicate how it should be used * rewrite type-level bytestring parsing: now with error handling!

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           bytezap-version:        1.4.0+version:        1.5.0 synopsis:       Bytestring builder with zero intermediate allocation description:    Please see README.md. category:       Data, Serialization, Generics@@ -28,8 +28,8 @@  library   exposed-modules:-      Bytezap       Bytezap.Common.Generic+      Bytezap.Common.TypeNats       Bytezap.Parser.Struct       Bytezap.Parser.Struct.Generic       Bytezap.Parser.Struct.TypeLits.Bytes@@ -38,7 +38,6 @@       Bytezap.Poke.Derived.Endian       Bytezap.Poke.Json       Bytezap.Poke.KnownLen-      Bytezap.PokeCPS       Bytezap.Struct       Bytezap.Struct.Generic       Bytezap.Struct.TypeLits.Bytes@@ -51,8 +50,6 @@       Raehik.Compat.Data.Word.ByteSwap       Raehik.Compat.GHC.Exts.GHC908MemcpyPrimops       Raehik.Compat.GHC.Exts.GHC910UnalignedAddrPrimops-      Tmp.BSExt-      Util.TypeNats   other-modules:       Paths_bytezap   hs-source-dirs:@@ -69,8 +66,6 @@       DataKinds       MagicHash   ghc-options: -Wall-  c-sources:-      cbits/aligned-static-hs-data.c   build-depends:       base >=4.18.0.0 && <4.21     , bytestring >=0.11.5.3 && <0.13.0.0

@@ -1,26 +0,0 @@-// This file contains various chunks of raw static data that we can't-// put into GHC-Haskell primitive string literals because we perform-// /aligned/ reads with them.--#include "MachDeps.h"-#include <stdint.h>--extern const char hs_bytestring_lower_hex_table[513];-const char hs_bytestring_lower_hex_table[513]-  __attribute__(( aligned(ALIGNMENT_WORD16) ))-  = "000102030405060708090a0b0c0d0e0f"-    "101112131415161718191a1b1c1d1e1f"-    "202122232425262728292a2b2c2d2e2f"-    "303132333435363738393a3b3c3d3e3f"-    "404142434445464748494a4b4c4d4e4f"-    "505152535455565758595a5b5c5d5e5f"-    "606162636465666768696a6b6c6d6e6f"-    "707172737475767778797a7b7c7d7e7f"-    "808182838485868788898a8b8c8d8e8f"-    "909192939495969798999a9b9c9d9e9f"-    "a0a1a2a3a4a5a6a7a8a9aaabacadaeaf"-    "b0b1b2b3b4b5b6b7b8b9babbbcbdbebf"-    "c0c1c2c3c4c5c6c7c8c9cacbcccdcecf"-    "d0d1d2d3d4d5d6d7d8d9dadbdcdddedf"-    "e0e1e2e3e4e5e6e7e8e9eaebecedeeef"-    "f0f1f2f3f4f5f6f7f8f9fafbfcfdfeff";

@@ -1,1 +0,0 @@-module Bytezap where

@@ -0,0 +1,17 @@+{-# LANGUAGE AllowAmbiguousTypes #-}++-- | Handy typenat utils.++module Bytezap.Common.TypeNats where++-- natVal''+import GHC.TypeNats ( Natural, KnownNat, natVal' )+import GHC.Exts ( proxy#, Proxy# )++natVal'' :: forall n. KnownNat n => Natural+natVal'' = natVal' (proxy# :: Proxy# n)+{-# INLINE natVal'' #-}++natValInt :: forall n. KnownNat n => Int+natValInt = fromIntegral $ natVal'' @n+{-# INLINE natValInt #-}

@@ -33,17 +33,26 @@ type STMode s = State# s  type ParserT# (st :: ZeroBitType) e a =-       ForeignPtrContents {- ^ pointer provenance -}-    -> Addr# {- ^ base address -}-    -> Int#  {- ^ cursor offset from base -}-    -> st    {- ^ state token -}-    -> Res# st e a+       ForeignPtrContents {- ^ pointer provenance (does not change) -}+    -> Addr#              {- ^ base address (does not change) -}+    -> Int#               {- ^ cursor offset from base -}+    -> st                 {- ^ state token -}+    -> Res# st e a        {- ^ result -} --- | Like flatparse, but no buffer length (= no buffer overflow checking), and---   no 'Addr#' on success (= no dynamic length parses).------ we take a 'ForeignPtrContents' because it lets us create bytestrings without--- copying if we want. it's useful+{- | Like flatparse, but no buffer length (= no buffer overflow checking), and+     no 'Addr#' on success (= no dynamic length parses).++Unlike flatparse, we separate base address from offset, rather than adding+them. This fits the unaligned 'Addr#' primops (added in GHC 9.10) better, and+in my head should hopefully assist in emitting immediates where possible for+offsets on the assembly level.++Combining them like in flatparse might be faster; but I really don't know how to+find out, without doing both and comparing various examples. After a lot of+scratching my head, I think this is most appropriate.++The 'ForeignPtrContents' is for keeping the 'Addr#' data in scope.+-} newtype ParserT (st :: ZeroBitType) e a =     ParserT { runParserT# :: ParserT# st e a } @@ -179,16 +188,17 @@ because it's hard to tell if it would be faster with modern CPUs and compilers. -} withLitErr-    :: (Num a, FiniteBits a)-    => (Int -> a -> e)-    -> Int# -> a -> (Addr# -> Int# -> a) -> ParserT st e r -> ParserT st e r-withLitErr fErr len# aLit p (ParserT pCont) = ParserT \fpc base# os# st ->+    :: (Integral a, FiniteBits a)+    => Int# -> a -> Int -> (Addr# -> Int# -> a)+    -> ParserT st (Int, Word8) r+    -> ParserT st (Int, Word8) r+withLitErr len# aLit idxStart p (ParserT pCont) = ParserT \fpc base# os# st ->     let aParsed = p base# os#     in  if   aLit == aParsed         then pCont fpc base# (os# +# len#) st         else let idxFail = firstNonMatchByteIdx aLit aParsed                  bFailed = unsafeByteAt aParsed idxFail-             in  Err# st (fErr idxFail bFailed)+             in  Err# st (idxStart + idxFail, fromIntegral bFailed) {-# INLINE withLitErr #-}  -- | Given two non-equal words @wActual@ and @wExpect@, return the index of the

@@ -1,6 +1,11 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE UndecidableInstances #-} -- thanks to type manipulation +-- TODO pass metadata to parser for errors. not hard just cba++-- TODO copies a lot of stuff from generic-data-functions. some should be kept+-- in a separate library (ReifyMaybeSymbol, ProdArity, natVal'' etc.)+ module Bytezap.Parser.Struct.Generic where  import Bytezap.Parser.Struct@@ -8,7 +13,8 @@ import GHC.Exts import Data.Kind import GHC.TypeNats-import Util.TypeNats ( natValInt )+import GHC.TypeLits ( KnownSymbol, symbolVal' )+import Bytezap.Common.TypeNats ( natValInt ) import Bytezap.Common.Generic ( type GTFoldMapCAddition ) import DeFun.Core ( type (~>) ) @@ -19,9 +25,15 @@     type GParseBaseE tag :: Type      -- unlike the serializer we stay newtyped because we want our Functor+    --+    -- TODO this is where we need to pass a bunch of metadata. see gdf     gParseBase         :: GParseBaseC tag a-        => ParserT (GParseBaseSt tag) (GParseBaseE tag) a+        => String       {- ^ data type name -}+        -> String       {- ^ constructor name -}+        -> Maybe String {- ^ record name (if present) -}+        -> Natural      {- ^ field index -}+        -> ParserT (GParseBaseSt tag) (GParseBaseE tag) a      -- | Defunctionalization symbol for a type family turning 'Type's into     --   'Natural's. (Needed as we can't partially apply type families.)@@ -30,24 +42,54 @@ class GParse tag gf where     gParse :: ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p) -instance GParse tag gf => GParse tag (D1 cd gf) where-    gParse = M1 <$> gParse @tag-instance GParse tag gf => GParse tag (C1 cc gf) where-    gParse = M1 <$> gParse @tag+instance GParseC tag dtName cstrName 0 gf+  => GParse tag (D1 (MetaData dtName _md2 _md3 _md4) (C1 (MetaCons cstrName _mc2 _mc3) gf)) where+    gParse = M1 <$> M1 <$> gParseC @tag @dtName @cstrName @0 +class GParseC tag (cd :: Symbol) (cc :: Symbol) (si :: Natural) gf where+    gParseC :: ParserT (GParseBaseSt tag) (GParseBaseE tag) (gf p)+ instance-  ( GParse tag l-  , GParse tag r+  ( GParseC tag cd cc si                 l+  , GParseC tag cd cc (si + ProdArity r) r   , GParseBase tag   , lenL ~ GTFoldMapCAddition (GParseBaseLenTF tag) l   , KnownNat lenL-  ) => GParse tag (l :*: r) where-    gParse = sequenceParsers len (:*:) (gParse @tag) (gParse @tag)+  ) => GParseC tag cd cc si (l :*: r) where+    gParseC = sequenceParsers len (:*:)+        (gParseC @tag @cd @cc @si)+        (gParseC @tag @cd @cc @(si + ProdArity r))       where         len = natValInt @lenL -instance (GParseBase tag, GParseBaseC tag a) => GParse tag (S1 c (Rec0 a)) where-    gParse = (M1 . K1) <$> gParseBase @tag+instance+  ( GParseBase tag, GParseBaseC tag a+  , KnownNat si, ReifyMaybeSymbol mSelName, KnownSymbol cc, KnownSymbol cd+  ) => GParseC tag cd cc si (S1 (MetaSel mSelName _ms2 _ms3 _ms4) (Rec0 a)) where+    gParseC = (M1 . K1) <$> gParseBase @tag cd cc cs si+      where+        cs = reifyMaybeSymbol @mSelName+        cd = symbolVal'' @cd+        cc = symbolVal'' @cc+        si = natVal'' @si  -- | Wow, look! Nothing!-instance GParse tag U1 where gParse = constParse U1+instance GParseC tag cd cc 0 U1 where gParseC = constParse U1++type family ProdArity (f :: Type -> Type) :: Natural where+    ProdArity (S1 c f)  = 1+    ProdArity (l :*: r) = ProdArity l + ProdArity r++class ReifyMaybeSymbol (mstr :: Maybe Symbol) where+    reifyMaybeSymbol :: Maybe String+instance ReifyMaybeSymbol Nothing where reifyMaybeSymbol = Nothing+instance KnownSymbol str => ReifyMaybeSymbol (Just str) where+    reifyMaybeSymbol = Just (symbolVal'' @str)++natVal'' :: forall n. KnownNat n => Natural+natVal'' = natVal' (proxy# :: Proxy# n)+{-# INLINE natVal'' #-}++symbolVal'' :: forall sym. KnownSymbol sym => String+symbolVal'' = symbolVal' (proxy# :: Proxy# sym)+{-# INLINE symbolVal'' #-}

@@ -31,13 +31,13 @@ import GHC.TypeNats ( Natural, type (+), KnownNat ) import Data.Type.Byte ( ReifyW8, reifyW64, reifyW32, reifyW16, reifyW8 ) import GHC.Exts ( (+#), Int(I#), Int#, Addr# )-import Util.TypeNats ( natValInt )+import Bytezap.Common.TypeNats ( natValInt ) import Raehik.Compat.Data.Primitive.Types ( indexWord8OffAddrAs# ) import Data.Bits  -- | Parse a type-level bytestring, largest grouping 'Word64'. class ParseReifyBytesW64 (idx :: Natural) (bs :: [Natural]) where-    parseReifyBytesW64 :: (Int -> Word8 -> e) -> ParserT st e ()+    parseReifyBytesW64 :: ParserT st (Int, Word8) ()  -- | Enough bytes to make a 'Word64'. instance {-# OVERLAPPING #-}@@ -65,7 +65,7 @@  -- | Parse a type-level bytestring, largest grouping 'Word32'. class ParseReifyBytesW32 (idx :: Natural) (bs :: [Natural]) where-    parseReifyBytesW32 :: (Int -> Word8 -> e) -> ParserT st e ()+    parseReifyBytesW32 :: ParserT st (Int, Word8) ()  -- | Enough bytes to make a 'Word32'. instance {-# OVERLAPPING #-}@@ -89,7 +89,7 @@  -- | Parse a type-level bytestring, largest grouping 'Word16'. class ParseReifyBytesW16 (idx :: Natural) (bs :: [Natural]) where-    parseReifyBytesW16 :: (Int -> Word8 -> e) -> ParserT st e ()+    parseReifyBytesW16 :: ParserT st (Int, Word8) ()  -- | Enough bytes to make a 'Word16'. instance {-# OVERLAPPING #-}@@ -111,7 +111,7 @@  -- | Serialize a type-level bytestring, byte-by-byte. class ParseReifyBytesW8 (idx :: Natural) (bs :: [Natural]) where-    parseReifyBytesW8 :: (Int -> Word8 -> e) -> ParserT st e ()+    parseReifyBytesW8 :: ParserT st (Int, Word8) ()  -- | Parse the next byte. instance@@ -120,27 +120,28 @@   , ParseReifyBytesW8 (idx+1) bs   ) => ParseReifyBytesW8 idx (b0 ': bs) where     {-# INLINE parseReifyBytesW8 #-}-    parseReifyBytesW8 f = ParserT $ \fpc base# os# st ->+    parseReifyBytesW8 = ParserT $ \fpc base# os# st ->         let bExpect = reifyW8 @b0             bActual = indexWord8OffAddrAs# base# os#             idx     = natValInt @idx         in  if   bExpect == bActual-            then runParserT# (parseReifyBytesW8 @(idx+1) @bs f) fpc base# (os# +# 1#) st-            else Err# st (f idx bActual)+            then runParserT# (parseReifyBytesW8 @(idx+1) @bs) fpc base# (os# +# 1#) st+            else Err# st (idx, bActual)  -- | End of the line. instance ParseReifyBytesW8 idx '[] where     {-# INLINE parseReifyBytesW8 #-}-    parseReifyBytesW8 _f = ParserT $ \_fpc _base# _os# st -> OK# st ()+    parseReifyBytesW8 = constParse () +{-# INLINE parseReifyBytesHelper #-} parseReifyBytesHelper-    :: forall (idx :: Natural) (len :: Natural) a e st+    :: forall (idx :: Natural) (len :: Natural) a st     .  (KnownNat idx, KnownNat len, Integral a, FiniteBits a)     => a -> (Addr# -> Int# -> a)-    -> ((Int -> Word8 -> e) -> ParserT st e ())-    -> (Int -> Word8 -> e) -> ParserT st e ()-parseReifyBytesHelper a indexWord8OffAddrAsA# pCont f = withLitErr-    (\idx b -> f (natValInt @idx + idx) (fromIntegral b))-    len# a indexWord8OffAddrAsA# (pCont f)+    -> ParserT st (Int, Word8) ()+    -> ParserT st (Int, Word8) ()+parseReifyBytesHelper aLit indexWord8OffAddrAsA# pCont = withLitErr+    len# aLit idx indexWord8OffAddrAsA# pCont   where-    !(I# len#) = natValInt @len+    !(I# len#)     = natValInt @len+    idx            = natValInt @idx

@@ -5,7 +5,7 @@ import GHC.TypeNats import Data.ByteString qualified as BS import GHC.Exts-import Util.TypeNats ( natValInt )+import Bytezap.Common.TypeNats ( natValInt )  import Raehik.Compat.Data.Primitive.Types 

@@ -1,153 +0,0 @@-{-# LANGUAGE UnboxedTuples #-}--{- | Low-level bytestring builder using continuation parsing.--bytezap's builder is highly performant. However, one thing it can't do is-/fail/. We have no way to flag an error. If you force it, you will either--* write an initial assert, followed by an unsafe builder that relies on it, or-* build a builder as we assert, then execute it once we're ready--The former is inefficient in situations where the check scales similarly with-the build (e.g. both must iterate over the input). And the latter is very silly-since your builder will be allocating all over.--A naive failable builder might use @'Either' e 'Int'@ to flag errors. After-executing, we check the result: if 'Right', we resize to the given actual-length; if 'Left', we discard the buffer with the given error. This is fine...-but it's an extra allocation, and limits us to 'Either'. A shame.--Instead, we design a builder that takes a finalizer continuation @'Int#' ->-'ByteString'@, which is passed the final offset. The builder calls this as it-finishes, wrapping it as needed (or leaving as 'ByteString' for a non-failable-builder). The runner is expected to pass a continuation to perform any buffer-reallocation necessary (if the actual length was less than the max length), and-return a 'ByteString', possibly wrapped in e.g. 'Right'.--This is much harder to use than the regular builder, and they can't be combined-(the regular builder permits sequencing, which this can't support). But it fills-a gap!--Unlike the regular builder we stick with 'IO', because the continuations get-weird otherwise.--}--module Bytezap.PokeCPS where--import GHC.Exts ( Int#, Addr#, Ptr )--import Data.Text.Internal ( Text(Text) )-import Data.Text.Array qualified as Text-import Data.Word ( Word8 )-import Data.ByteString ( ByteString )-import Data.Primitive.ByteArray ( ByteArray(ByteArray), indexByteArray )-import GHC.Storable ( writeWord8OffPtr )-import Tmp.BSExt qualified as B--type PokeCPS# r = Addr# -> Int# -> (Int# -> IO ByteString) -> IO r---- | 'PokeCPS#' newtype wrapper.------ Does not permit a 'Semigroup' instance because pokes do not return offset--- information.-newtype PokeCPS r = PokeCPS { unPokeCPS:: PokeCPS# r }--emptyPokeCPS :: PokeCPS ByteString-emptyPokeCPS = PokeCPS $ \_base# os# finalize -> finalize os#--{- Any unexplained stuff is probably parsing parts of hex bytestrings-Like @xx AA 1a2F@.--}--{- 2024-08-27 raehik-The best algorithm would probably operate on words (let's assume 8 bytes).-It would involve a shitload of inlining and praying that GHC figures out how to-turn it all into efficient JMPs.--}--{--Parse hex bytestring.--Expects that the output buffer can fit the maximum length of the input.--This is a bit overly parametric in the hopes of using it with manual buffering-(e.g. allocate a single buffer and reuse it for every parse). But that's more-complex: we need to carefully set @bufInMax@ so that it also corresponds to the-output buffer as well. But now, we also need to track the input buffer-position... yeah, it's a mess.--Wait, we _are_ tracking input buffer position. We're just not passing it to the-continuation. More reworking, sigh...--}-full-    :: ByteArray -> Ptr Word8-    -> (Int -> IO r) -> (Word8 -> IO r)-    -> (Word8 -> IO r)-    -> Int -> Int -> Int-    -> IO r-full bufIn bufOut fCont fErrEof fErrNotHexDigit bufInMax = go-  where-    -- each loop writes a single byte or fails-    go = \bufInOs bufOutOs -> do-        let bufInRemaining = bufInMax - bufInOs-        if   bufInRemaining >= 2-        then case indexByteArray @Word8 bufIn bufInOs of-               0x20 -> -- next byte is space-                case indexByteArray @Word8 bufIn (bufInOs+1) of-                  0x20 -> -- and the byte after that: skip both-                    go (bufInOs+2) bufOutOs-                  d1   ->-                    -- next byte is space, then non-space-                    -- could just skip one, but we've already asserted 2 bytes-                    -- so let's copy-paste for just 1 more byte-                    if   bufInRemaining >= 3-                    then do let d0 = indexByteArray @Word8 bufIn (bufInOs+2)-                            withHexNibbles fErrNotHexDigit d1 d0 $ \b -> do-                                writeWord8OffPtr bufOut bufOutOs b-                                go (bufInOs+3) (bufOutOs+1)-                    else fErrEof d1-               d1   -> do-                let d0 = indexByteArray @Word8 bufIn (bufInOs+1)-                withHexNibbles fErrNotHexDigit d1 d0 $ \b -> do-                    writeWord8OffPtr bufOut bufOutOs b-                    go (bufInOs+2) (bufOutOs+1)-        else if   bufInRemaining == 0-             then fCont bufOutOs-             else -- 1 byte remaining-                  case indexByteArray @Word8 bufIn bufInOs of-                    0x20 -> fCont bufOutOs-                    d1   -> fErrEof d1-{-# INLINE full #-}--withHexNibbles ::-    (Word8 -> r) -> Word8 -> Word8 -> (Word8 -> r) -> r-withHexNibbles fFail d1 d0 fCont =-    withByteAsHexDigit d1 fFail $ \n1 ->-        withByteAsHexDigit d0 fFail $ \n0 ->-            fCont $ 0x10*n1 + n0-{-# INLINE withHexNibbles #-}--withByteAsHexDigit :: Word8 -> (Word8 -> r) -> (Word8 -> r) -> r-withByteAsHexDigit c fFail f-  | dec  <= 9 = f dec-  | hexl <= 5 = f $ hexl + 10-  | hexu <= 5 = f $ hexu + 10-  | otherwise = fFail c-  where-    dec   = c - ord_0-    hexl  = c - ord_a-    hexu  = c - ord_A-    ord_0 = 0x30-    ord_a = 0x61-    ord_A = 0x41-{-# INLINE withByteAsHexDigit #-}--textToByteStringUptoIO :: Text -> IO (Either String ByteString)-textToByteStringUptoIO = \(Text (Text.ByteArray tarr) tos tlen) ->-    B.createCPS (tlen `quot` 2) finalizer $ \finalize buf ->-        full (ByteArray tarr) buf finalize fErrEof fErrNotHexDigit tlen tos 0-  where-    fErrNotHexDigit = \b -> pure $ Left ("not a hexadecimal digit: " <> show b)-    finalizer = \fp len -> Right <$> B.mkDeferredByteString fp len-    fErrEof = \_ -> pure $ Left "ended during byte (TODO)"-{-# INLINE textToByteStringUptoIO #-}

@@ -27,9 +27,9 @@ import GHC.Generics import GHC.Exts import Bytezap.Common.Generic ( type GTFoldMapCAddition )+import Bytezap.Common.TypeNats ( natValInt ) import Data.Kind import GHC.TypeNats-import Util.TypeNats ( natValInt ) import DeFun.Core ( type (~>) )  -- | Class for holding info on class to use for poking base cases.

@@ -1,168 +0,0 @@-{-# LANGUAGE UnboxedTuples #-}---- | raehik's bytestring extras (reimplementations of unexported internals).--module Tmp.BSExt-  ( module Tmp.BSExt-  , B.mkDeferredByteString-  ) where--import GHC.ForeignPtr ( ForeignPtr, unsafeWithForeignPtr, withForeignPtr )-import Foreign.Ptr ( Ptr )-import Foreign.Marshal.Utils ( copyBytes )-import Data.ByteString.Internal qualified as B-import Data.ByteString ( ByteString )-import Data.Word ( Word8 )-import Control.Exception ( assert )-import GHC.IO ( IO(IO) )-import GHC.Exts ( runRW# )---- | Copy the given number of bytes from the second area (source) into the first---   (destination); the copied areas may not overlap.------ Reimplemented from the unexported function--- 'Data.ByteString.Internal.Type.memcpyFp'.-memcpyFp :: ForeignPtr Word8 -> ForeignPtr Word8 -> Int -> IO ()-memcpyFp fp fq s = unsafeWithForeignPtr fp $ \p ->-                     unsafeWithForeignPtr fq $ \q -> copyBytes p q s---- | Create a 'ByteString' of size @l@ and use action @f@ to fill its contents.------ Reimplemented from the unexported function--- 'Data.ByteString.Internal.Type.createFp.-createFp :: Int -> (ForeignPtr Word8 -> IO ()) -> IO ByteString-createFp len action = assert (len >= 0) $ do-    fp <- B.mallocByteString len-    action fp-    B.mkDeferredByteString fp len-{-# INLINE createFp #-}--createUptoNCPS-    :: Int-    -> (Ptr Word8 -> (Int -> IO ByteString) -> IO r)-    -> IO r-createUptoNCPS maxLen action = assert (maxLen >= 0) $ do-    fp <- B.mallocByteString maxLen-    withForeignPtr fp $ \p -> action p $ \len ->-        B.mkDeferredByteString fp len-{-# INLINE createUptoNCPS #-}--createCPS-    :: Int-    -> (ForeignPtr Word8 -> Int -> IO r)-    -> ((Int -> IO r) -> Ptr Word8 -> IO r)-    -> IO r-createCPS maxLen finalize f = assert (maxLen >= 0) $ do-    fp <- B.mallocByteString maxLen-    withForeignPtr fp $ \buf -> f (finalize fp) buf-{-# INLINE createCPS #-}--{--withBuffer-    :: Int-    -> (Ptr Word8 -> Int -> IO r)-    -> (r ->-withBuffer bufLen-{-# INLINE withBuffer #-}--}--createAndTrimCPS-    :: Int-    -> (Ptr Word8 -> (Int -> IO ByteString) -> IO r)-    -> IO r-createAndTrimCPS maxLen action = assert (maxLen >= 0) $ do-    fp <- B.mallocByteString maxLen-    withForeignPtr fp $ \p -> action p $ \len ->-        if   len < maxLen-        then createFp len (\fp' -> memcpyFp fp' fp len)-             -- ^ apparently @fp@ will get GCed automatically, up to GHC-        else B.mkDeferredByteString fp maxLen-{-# INLINE createAndTrimCPS #-}--unsafeCreateAndTrimCPS-    :: Int-    -> (Ptr Word8 -> (Int -> IO ByteString) -> IO r)-    -> r-unsafeCreateAndTrimCPS l f =-    unsafeDupablePerformIOByteString (createAndTrimCPS l f)-{-# INLINE unsafeCreateAndTrimCPS #-}--createAndTrimFailable-    :: Int-    -> (Ptr Word8 -> IO (Either e Int))-    -> IO (Either e ByteString)-createAndTrimFailable l action = createFpAndTrimFailable l (wrapAction action)-{-# INLINE createAndTrimFailable #-}---- TODO how do I omit the Either allocation?-createFpAndTrimFailable-    :: Int-    -> (ForeignPtr Word8 -> IO (Either e Int))-    -> IO (Either e ByteString)-createFpAndTrimFailable maxLen action = assert (maxLen >= 0) $ do-    fp <- B.mallocByteString maxLen-    action fp >>= \case-      Right len ->-        if   len < maxLen-        then Right <$> createFp len (\fp' -> memcpyFp fp' fp len)-             -- ^ apparently @fp@ will get GCed automatically, up to GHC-        else Right <$> B.mkDeferredByteString fp maxLen-      Left  err -> pure $ Left err-{-# INLINE createFpAndTrimFailable #-}--createUptoNFailable-    :: Int-    -> (Ptr Word8 -> IO (Either e Int))-    -> IO (Either e ByteString)-createUptoNFailable l action = createFpUptoNFailable l (wrapAction action)-{-# INLINE createUptoNFailable #-}--createFpUptoNFailable-    :: Int-    -> (ForeignPtr Word8 -> IO (Either e Int))-    -> IO (Either e ByteString)-createFpUptoNFailable maxLen action = assert (maxLen >= 0) $ do-    fp <- B.mallocByteString maxLen-    action fp >>= \case-      Right len -> Right <$> B.mkDeferredByteString fp len-      Left  err -> pure $ Left err-{-# INLINE createFpUptoNFailable #-}--createFailable-    :: Int-    -> (Ptr Word8 -> IO (Either e Int))-    -> IO (Either e ByteString)-createFailable l action = createFpFailable l (wrapAction action)-{-# INLINE createFailable #-}---- TODO how do I omit the Either allocation?-createFpFailable-    :: Int-    -> (ForeignPtr Word8 -> IO (Either e Int))-    -> IO (Either e ByteString)-createFpFailable maxLen action = assert (maxLen >= 0) $ do-    fp <- B.mallocByteString maxLen-    action fp >>= \case-      Right len ->-        -- TODO does not check for correctness (len <= maxLen)!! don't lie!!!!-        Right <$> B.mkDeferredByteString fp len-      Left  err -> pure $ Left err-{-# INLINE createFpFailable #-}---- TODO probably don't export-wrapAction :: (Ptr Word8 -> IO res) -> ForeignPtr Word8 -> IO res-wrapAction = flip withForeignPtr-  -- Cannot use unsafeWithForeignPtr, because action can diverge--unsafeDupablePerformIOByteString :: IO a -> a--- Why does this exist? In base-4.15.1.0 until at least base-4.18.0.0,--- the version of unsafeDupablePerformIO in base prevents unboxing of--- its results with an opaque call to GHC.Exts.lazy, for reasons described--- in Note [unsafePerformIO and strictness] in GHC.IO.Unsafe. (See--- https://hackage.haskell.org/package/base-4.18.0.0/docs/src/GHC.IO.Unsafe.html#line-30 .)--- Even if we accept the (very questionable) premise that the sort of--- function described in that note should work, we expect no such--- calls to be made in the context of bytestring.  (And we really want--- unboxing!)-unsafeDupablePerformIOByteString (IO act) =-    case runRW# act of (# _, res #) -> res

@@ -1,17 +0,0 @@-{-# LANGUAGE AllowAmbiguousTypes #-}---- | Handy typenat utils.--module Util.TypeNats where---- natVal''-import GHC.TypeNats ( Natural, KnownNat, natVal' )-import GHC.Exts ( proxy#, Proxy# )--natVal'' :: forall n. KnownNat n => Natural-natVal'' = natVal' (proxy# :: Proxy# n)-{-# INLINE natVal'' #-}--natValInt :: forall n. KnownNat n => Int-natValInt = fromIntegral $ natVal'' @n-{-# INLINE natValInt #-}