diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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! diff --git a/bytezap.cabal b/bytezap.cabal --- a/bytezap.cabal +++ b/bytezap.cabal @@ -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 diff --git a/cbits/aligned-static-hs-data.c b/cbits/aligned-static-hs-data.c deleted file mode 100644 --- a/cbits/aligned-static-hs-data.c +++ /dev/null @@ -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 - -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"; diff --git a/src/Bytezap.hs b/src/Bytezap.hs deleted file mode 100644 --- a/src/Bytezap.hs +++ /dev/null @@ -1,1 +0,0 @@ -module Bytezap where diff --git a/src/Bytezap/Common/TypeNats.hs b/src/Bytezap/Common/TypeNats.hs new file mode 100644 --- /dev/null +++ b/src/Bytezap/Common/TypeNats.hs @@ -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 #-} diff --git a/src/Bytezap/Parser/Struct.hs b/src/Bytezap/Parser/Struct.hs --- a/src/Bytezap/Parser/Struct.hs +++ b/src/Bytezap/Parser/Struct.hs @@ -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 diff --git a/src/Bytezap/Parser/Struct/Generic.hs b/src/Bytezap/Parser/Struct/Generic.hs --- a/src/Bytezap/Parser/Struct/Generic.hs +++ b/src/Bytezap/Parser/Struct/Generic.hs @@ -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'' #-} diff --git a/src/Bytezap/Parser/Struct/TypeLits/Bytes.hs b/src/Bytezap/Parser/Struct/TypeLits/Bytes.hs --- a/src/Bytezap/Parser/Struct/TypeLits/Bytes.hs +++ b/src/Bytezap/Parser/Struct/TypeLits/Bytes.hs @@ -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 diff --git a/src/Bytezap/Poke/KnownLen.hs b/src/Bytezap/Poke/KnownLen.hs --- a/src/Bytezap/Poke/KnownLen.hs +++ b/src/Bytezap/Poke/KnownLen.hs @@ -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 diff --git a/src/Bytezap/PokeCPS.hs b/src/Bytezap/PokeCPS.hs deleted file mode 100644 --- a/src/Bytezap/PokeCPS.hs +++ /dev/null @@ -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 #-} diff --git a/src/Bytezap/Struct/Generic.hs b/src/Bytezap/Struct/Generic.hs --- a/src/Bytezap/Struct/Generic.hs +++ b/src/Bytezap/Struct/Generic.hs @@ -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. diff --git a/src/Tmp/BSExt.hs b/src/Tmp/BSExt.hs deleted file mode 100644 --- a/src/Tmp/BSExt.hs +++ /dev/null @@ -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 diff --git a/src/Util/TypeNats.hs b/src/Util/TypeNats.hs deleted file mode 100644 --- a/src/Util/TypeNats.hs +++ /dev/null @@ -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 #-}