packages feed

ptr (empty) → 0.15.2

raw patch · 15 files changed

+1181/−0 lines, 15 filesdep +basedep +base-preludedep +bugsetup-changed

Dependencies added: base, base-prelude, bug, bytestring, contravariant, mtl, profunctors, ptr, quickcheck-instances, rerebase, semigroups, tasty, tasty-hunit, tasty-quickcheck, text, transformers

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2017, 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
+ library/Ptr/ByteString.hs view
@@ -0,0 +1,31 @@+module Ptr.ByteString+where++import Ptr.Prelude+import qualified Ptr.Poking as A+import qualified Ptr.Parse as C+import qualified Ptr.Peek as D+import qualified Data.ByteString.Internal as B+++{-# INLINE poking #-}+poking :: A.Poking -> B.ByteString+poking (A.Poking size population) =+  B.unsafeCreate size population++{-# INLINE parse #-}+parse :: B.ByteString -> C.Parse result -> (Int -> result) -> (Text -> result) -> result+parse (B.PS fp offset length) (C.Parse parseIO) eoi error =+  {-# SCC "parse" #-} +  unsafePerformIO $+  withForeignPtr fp $ \ptr ->+  parseIO length (plusPtr ptr offset) (return . eoi) (return . error) (\result _ _ -> return result)++{-# INLINE peek #-}+peek :: B.ByteString -> D.Peek result -> Maybe result+peek (B.PS fp offset length) (D.Peek amount io) =+  {-# SCC "peek" #-} +  if amount <= length+    then Just $ unsafePerformIO $ withForeignPtr fp $ \ptr ->+      io (plusPtr ptr offset)+    else Nothing
+ library/Ptr/IO.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE CPP #-}+module Ptr.IO+where++import Ptr.Prelude+import qualified Data.ByteString.Internal as A+import qualified Ptr.UncheckedShifting as D+++{-# INLINE peekStorable #-}+peekStorable :: Storable storable => Ptr Word8 -> IO storable+peekStorable =+  {-# SCC "peekStorable" #-} +  peek . castPtr++{-# INLINE peekWord8 #-}+peekWord8 :: Ptr Word8 -> IO Word8+peekWord8 =+  {-# SCC "peekWord8" #-} +  peekStorable++-- | Big-endian word of 2 bytes.+{-# INLINE peekBEWord16 #-}+peekBEWord16 :: Ptr Word8 -> IO Word16+#ifdef WORDS_BIGENDIAN+peekBEWord16 =+  {-# SCC "peekBEWord16" #-} +  peekStorable+#else+peekBEWord16 =+  {-# SCC "peekBEWord16" #-} +  fmap byteSwap16 . peekStorable+#endif++-- | Little-endian word of 2 bytes.+{-# INLINE peekLEWord16 #-}+peekLEWord16 :: Ptr Word8 -> IO Word16+#ifdef WORDS_BIGENDIAN+peekLEWord16 =+  {-# SCC "peekLEWord16" #-} +  fmap byteSwap16 . peekStorable+#else+peekLEWord16 =+  {-# SCC "peekLEWord16" #-} +  peekStorable+#endif++-- | Big-endian word of 4 bytes.+{-# INLINE peekBEWord32 #-}+peekBEWord32 :: Ptr Word8 -> IO Word32+#ifdef WORDS_BIGENDIAN+peekBEWord32 =+  {-# SCC "peekBEWord32" #-} +  peekStorable+#else+peekBEWord32 =+  {-# SCC "peekBEWord32" #-} +  fmap byteSwap32 . peekStorable+#endif++-- | Little-endian word of 4 bytes.+{-# INLINE peekLEWord32 #-}+peekLEWord32 :: Ptr Word8 -> IO Word32+#ifdef WORDS_BIGENDIAN+peekLEWord32 =+  {-# SCC "peekLEWord32" #-} +  fmap byteSwap32 . peekStorable+#else+peekLEWord32 =+  {-# SCC "peekLEWord32" #-} +  peekStorable+#endif++-- | Big-endian word of 8 bytes.+{-# INLINE peekBEWord64 #-}+peekBEWord64 :: Ptr Word8 -> IO Word64+#ifdef WORDS_BIGENDIAN+peekBEWord64 =+  {-# SCC "peekBEWord64" #-} +  peekStorable+#else+peekBEWord64 =+  {-# SCC "peekBEWord64" #-} +  fmap byteSwap64 . peekStorable+#endif++-- | Little-endian word of 8 bytes.+{-# INLINE peekLEWord64 #-}+peekLEWord64 :: Ptr Word8 -> IO Word64+#ifdef WORDS_BIGENDIAN+peekLEWord64 =+  {-# SCC "peekLEWord64" #-} +  fmap byteSwap64 . peekStorable+#else+peekLEWord64 =+  {-# SCC "peekLEWord64" #-} +  peekStorable+#endif++{-|+Allocate a new byte array with @memcpy@.+-}+{-# INLINE peekBytes #-}+peekBytes :: Ptr Word8 -> Int -> IO ByteString+peekBytes ptr amount =+  {-# SCC "peekBytes" #-} +  A.create amount $ \destPtr -> A.memcpy destPtr ptr amount++{-# 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 pokeBEWord16 #-}+pokeBEWord16 :: Ptr Word8 -> Word16 -> IO ()+#ifdef WORDS_BIGENDIAN+pokeBEWord16 =+  {-# SCC "pokeBEWord16" #-} +  poke+#else+pokeBEWord16 ptr value =+  {-# SCC "pokeBEWord16" #-} +  do+    pokeStorable ptr (fromIntegral (D.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 (D.shiftr_w32 value 24) :: Word8)+    pokeByteOff ptr 1 (fromIntegral (D.shiftr_w32 value 16) :: Word8)+    pokeByteOff ptr 2 (fromIntegral (D.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 (D.shiftr_w64 value 32))+    pokeBEWord32 (plusPtr ptr 4) (fromIntegral value)+#else+pokeBEWord64 ptr value =+  {-# SCC "pokeBEWord64" #-} +  do+    pokeStorable ptr (fromIntegral (D.shiftr_w64 value 56) :: Word8)+    pokeByteOff ptr 1 (fromIntegral (D.shiftr_w64 value 48) :: Word8)+    pokeByteOff ptr 2 (fromIntegral (D.shiftr_w64 value 40) :: Word8)+    pokeByteOff ptr 3 (fromIntegral (D.shiftr_w64 value 32) :: Word8)+    pokeByteOff ptr 4 (fromIntegral (D.shiftr_w64 value 24) :: Word8)+    pokeByteOff ptr 5 (fromIntegral (D.shiftr_w64 value 16) :: Word8)+    pokeByteOff ptr 6 (fromIntegral (D.shiftr_w64 value  8) :: Word8)+    pokeByteOff ptr 7 (fromIntegral value :: Word8)+#endif+#endif++{-# INLINE pokeBytesTrimming #-}+pokeBytesTrimming :: Ptr Word8 -> Int -> ByteString -> IO ()+pokeBytesTrimming ptr maxLength (A.PS fptr offset length) =+  {-# SCC "pokeBytesTrimming" #-} +  withForeignPtr fptr $ \bytesPtr -> A.memcpy ptr (plusPtr bytesPtr offset) (min length maxLength)++{-# INLINE pokeBytes #-}+pokeBytes :: Ptr Word8 -> ByteString -> IO ()+pokeBytes ptr (A.PS fptr offset length) =+  {-# SCC "pokeBytes" #-} +  withForeignPtr fptr $ \bytesPtr -> A.memcpy ptr (plusPtr bytesPtr offset) length
+ library/Ptr/Parse.hs view
@@ -0,0 +1,195 @@+module Ptr.Parse+where++import Ptr.Prelude hiding (peek, take)+import qualified Ptr.PokeAndPeek as A+import qualified Data.ByteString.Char8 as B+import qualified Ptr.Prelude as C+import qualified Ptr.IO as D+++newtype Parse output =+  Parse (Int -> Ptr Word8 -> forall result. (Int -> IO result) -> (Text -> IO result) -> (output -> Int -> Ptr Word8 -> IO result) -> IO result)++deriving instance Functor Parse++instance Applicative Parse where+  pure x =+    Parse (\ availableAmount ptr _ _ succeed -> succeed x availableAmount ptr)+  {-# INLINE (<*>) #-}+  (<*>) (Parse left) (Parse right) =+    Parse $ \ availableAmount ptr failWithEOI failWithMessage succeed ->+    left availableAmount ptr failWithEOI failWithMessage $ \ leftOutput leftAvailableAmount leftPtr ->+    right leftAvailableAmount leftPtr failWithEOI failWithMessage $ \ rightOutput rightAvailableAmount rightPtr ->+    succeed (leftOutput rightOutput) rightAvailableAmount rightPtr++instance Alternative Parse where+  empty =+    Parse (\ _ _ failWithEOI _ _ -> failWithEOI 0)+  {-# INLINE (<|>) #-}+  (<|>) (Parse left) (Parse right) =+    Parse $ \ availableAmount ptr failWithEOI failWithMessage succeed ->+    left availableAmount ptr +      (\ _ -> right availableAmount ptr failWithEOI failWithMessage succeed)+      failWithMessage succeed++instance Monad Parse where+  return = pure+  {-# INLINE (>>=) #-}+  (>>=) (Parse left) rightK =+    Parse $ \ availableAmount ptr failWithEOI failWithMessage succeed ->+    left availableAmount ptr failWithEOI failWithMessage $ \ leftOutput leftAvailableAmount leftPtr ->+    case rightK leftOutput of+      Parse right ->+        right leftAvailableAmount leftPtr failWithEOI failWithMessage succeed++instance MonadPlus Parse where+  mzero = empty+  mplus = (<|>)++{-# INLINE fail #-}+fail :: Text -> Parse output+fail message =+  Parse $ \ _ _ _ failWithMessage _ -> failWithMessage message++{-# INLINE pokeAndPeek #-}+pokeAndPeek :: A.PokeAndPeek input output -> Parse output+pokeAndPeek (A.PokeAndPeek requiredAmount _ ptrIO) =+  Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed ->+  if availableAmount >= requiredAmount+    then do+      !result <- ptrIO ptr+      succeed result (availableAmount - requiredAmount) (plusPtr ptr requiredAmount)+    else failWithEOI (requiredAmount - availableAmount)++{-# INLINE limiting #-}+limiting :: Int -> Parse output -> Parse output+limiting limitAmount (Parse io) =+  Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed ->+  if availableAmount >= limitAmount+    then io limitAmount ptr failWithEOI failWithMessage succeed+    else failWithEOI (limitAmount - availableAmount)++{-|+Decode the remaining bytes, whithout moving the parser's cursor.+Useful for debugging.+-}+{-# INLINE peekRemainders #-}+peekRemainders :: Parse ByteString+peekRemainders =+  {-# SCC "peekRemainders" #-} +  Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> do+    bytes <- D.peekBytes ptr availableAmount+    succeed bytes availableAmount ptr++{-# INLINE word8 #-}+word8 :: Parse Word8+word8 =+  {-# SCC "word8" #-} +  pokeAndPeek A.word8++{-# INLINE beWord16 #-}+beWord16 :: Parse Word16+beWord16 =+  {-# SCC "beWord16" #-} +  pokeAndPeek A.beWord16++{-# INLINE beWord32 #-}+beWord32 :: Parse Word32+beWord32 =+  {-# SCC "beWord32" #-} +  pokeAndPeek A.beWord32++{-# INLINE beWord64 #-}+beWord64 :: Parse Word64+beWord64 =+  {-# SCC "beWord64" #-} +  pokeAndPeek A.beWord64++{-# INLINE bytes #-}+bytes :: Int -> Parse ByteString+bytes amount =+  {-# SCC "bytes" #-} +  pokeAndPeek (A.bytes amount)++{-# INLINE allBytes #-}+allBytes :: Parse ByteString+allBytes =+  {-# SCC "allBytes" #-} +  Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> do+    bytes <- D.peekBytes ptr availableAmount+    succeed bytes 0 (plusPtr ptr availableAmount)++{-# INLINE nullTerminatedBytes #-}+nullTerminatedBytes :: Parse ByteString+nullTerminatedBytes =+  {-# SCC "nullTerminatedBytes" #-}+  Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed -> do+    bytes <- B.packCString (castPtr ptr)+    case succ (B.length bytes) of+      consumedAmount -> if consumedAmount <= availableAmount+        then succeed bytes (availableAmount - consumedAmount) (plusPtr ptr consumedAmount)+        else failWithEOI (consumedAmount - availableAmount)++{-# INLINE bytesWhile #-}+bytesWhile :: (Word8 -> Bool) -> Parse ByteString+bytesWhile predicate =+  {-# SCC "bytesWhile" #-}+  Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed ->+  let+    iterate !availableAmount !unconsumedAmount !ptr =+      if unconsumedAmount > 0+        then do+          byte <- C.peek ptr+          if predicate byte+            then iterate availableAmount (pred unconsumedAmount) (plusPtr ptr 1)+            else do+              bytes <- B.packCStringLen (castPtr ptr, availableAmount - unconsumedAmount)+              succeed bytes unconsumedAmount ptr+        else failWithEOI 0+    in iterate availableAmount availableAmount ptr++{-# INLINE skipWhile #-}+skipWhile :: (Word8 -> Bool) -> Parse ()+skipWhile predicate =+  {-# SCC "skipWhile" #-} +  Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed ->+  let+    iterate !availableAmount !unconsumedAmount !ptr =+      if unconsumedAmount > 0+        then do+          byte <- C.peek ptr+          if predicate byte+            then iterate availableAmount (pred unconsumedAmount) (plusPtr ptr 1)+            else succeed () unconsumedAmount ptr+        else failWithEOI 0+    in iterate availableAmount availableAmount ptr++{-# INLINE foldWhile #-}+foldWhile :: (Word8 -> Bool) -> (state -> Word8 -> state) -> state -> Parse state+foldWhile predicate step start =+  {-# SCC "foldWhile" #-} +  Parse $ \ !availableAmount !ptr failWithEOI failWithMessage succeed ->+  let+    iterate !state !unconsumedAmount !ptr =+      if unconsumedAmount > 0+        then do+          byte <- C.peek ptr+          if predicate byte+            then iterate (step state byte) (pred unconsumedAmount) (plusPtr ptr 1)+            else succeed state unconsumedAmount ptr+        else failWithEOI 0+    in iterate start availableAmount ptr++-- |+-- Unsigned integral number encoded in ASCII.+{-# INLINE unsignedASCIIIntegral #-}+unsignedASCIIIntegral :: Integral a => Parse a+unsignedASCIIIntegral =+  {-# SCC "unsignedASCIIIntegral" #-} +  foldWhile byteIsDigit step 0+  where+    byteIsDigit byte =+      byte - 48 <= 9+    step !state !byte =+      state * 10 + fromIntegral byte - 48
+ library/Ptr/Peek.hs view
@@ -0,0 +1,87 @@+module Ptr.Peek+where++import Ptr.Prelude hiding (take)+import qualified Ptr.PokeAndPeek as B+import qualified Ptr.Parse as C+++data Peek output =+  Peek !Int !(Ptr Word8 -> IO output)++instance Functor Peek where+  {-# INLINE fmap #-}+  fmap fn (Peek size io) =+    Peek size (fmap fn . io)++instance Applicative Peek where+  {-# INLINE pure #-}+  pure x =+    Peek 0 (const (pure x))+  {-# INLINE (<*>) #-}+  (<*>) (Peek leftSize leftIO) (Peek rightSize rightIO) =+    Peek (leftSize + rightSize) io+    where+      io ptr =+        leftIO ptr <*> rightIO (plusPtr ptr leftSize)+++{-# INLINE word8 #-}+word8 :: Peek Word8+word8 =+  {-# SCC "word8" #-} +  pokeAndPeek B.word8++{-# INLINE beWord16 #-}+beWord16 :: Peek Word16+beWord16 =+  {-# SCC "beWord16" #-} +  pokeAndPeek B.beWord16++{-# INLINE beWord32 #-}+beWord32 :: Peek Word32+beWord32 =+  {-# SCC "beWord32" #-} +  pokeAndPeek B.beWord32++{-# INLINE beWord64 #-}+beWord64 :: Peek Word64+beWord64 =+  {-# SCC "beWord64" #-} +  pokeAndPeek B.beWord64++{-# INLINE bytes #-}+bytes :: Int -> Peek ByteString+bytes amount =+  {-# SCC "bytes" #-} +  pokeAndPeek (B.bytes amount)++{-# INLINE pokeAndPeek #-}+pokeAndPeek :: B.PokeAndPeek input output -> Peek output+pokeAndPeek (B.PokeAndPeek size _ io) =+  {-# SCC "pokeAndPeek" #-} +  Peek size io++{-|+Given the length of the data and a specification of its sequential consumption,+produces Peek, which results in Just the successfully taken value,+or Nothing, the specified length of data wasn't enough.+-}+{-# INLINE parse #-}+parse :: Int -> C.Parse a -> (Int -> a) -> (Text -> a) -> Peek a+parse amount (C.Parse parseIO) eoi error =+  {-# SCC "parse" #-} +  Peek amount $ \ptr ->+  parseIO amount ptr (return . eoi) (return . error) (\result _ _ -> return result)++{-|+A standard idiom, where a header specifies the length of the body.++Produces Peek, which itself produces another Peek, which is the same as the result of the 'parse' function.+-}+{-# INLINE peekAmountAndParse #-}+peekAmountAndParse :: Peek Int -> C.Parse a -> (Int -> a) -> (Text -> a) -> Peek (Peek a)+peekAmountAndParse peekAmount parse_ eoi error =+  {-# SCC "peekAmountAndParse" #-} +  flip fmap peekAmount $ \amount ->+  parse amount parse_ eoi error
+ library/Ptr/Poke.hs view
@@ -0,0 +1,56 @@+module Ptr.Poke+where++import Ptr.Prelude+import qualified Ptr.PokeAndPeek as B+++{-|+Specification of a sized and errorless writing action to a pointer.+-}+data Poke input =+  Poke !Int !(Ptr Word8 -> input -> IO ())++instance Contravariant Poke where+  {-# INLINE contramap #-}+  contramap fn (Poke size io) =+    Poke size (\ptr input -> io ptr (fn input))++instance Divisible Poke where+  {-# INLINE conquer #-}+  conquer =+    Poke 0 (\_ _ -> pure ())+  {-# INLINE divide #-}+  divide fn (Poke size1 io1) (Poke size2 io2) =+    Poke (size1 + size2) (\ptr input -> case fn input of (input1, input2) -> io1 ptr input1 *> io2 (plusPtr ptr size1) input2)+++{-# INLINE word8 #-}+word8 :: Poke Word8+word8 =+  pokeAndPeek B.word8++{-# INLINE beWord16 #-}+beWord16 :: Poke Word16+beWord16 =+  pokeAndPeek B.beWord16++{-# INLINE beWord32 #-}+beWord32 :: Poke Word32+beWord32 =+  pokeAndPeek B.beWord32++{-# INLINE beWord64 #-}+beWord64 :: Poke Word64+beWord64 =+  pokeAndPeek B.beWord64++{-# INLINE bytes #-}+bytes :: Int -> Poke ByteString+bytes amount =+  pokeAndPeek (B.bytes amount)++{-# INLINE pokeAndPeek #-}+pokeAndPeek :: B.PokeAndPeek input output -> Poke input+pokeAndPeek (B.PokeAndPeek size io _) =+  Poke size io
+ library/Ptr/PokeAndPeek.hs view
@@ -0,0 +1,77 @@+module Ptr.PokeAndPeek+where++import Ptr.Prelude+import qualified Ptr.IO as A+++{-|+Encoder and decoder of the same binary representation.++You can compose both the covariant and contravariant parameters of PokeAndPeek+using Applicative and Profunctor. E.g.,++>word8AndWord32 :: PokeAndPeek (Word8, Word32) (Word8, Word32)+>word8AndWord32 =+>  (,) <$> lmap fst word8 <*> lmap snd beWord32+-}+data PokeAndPeek input output =+  PokeAndPeek !Int (Ptr Word8 -> input -> IO ()) (Ptr Word8 -> IO output)++{-|+A codec, which encodes and decodes the same type. E.g.,++>word8AndWord32 :: InvPokeAndPeek (Word8, Word32)+>word8AndWord32 =+>  (,) <$> lmap fst word8 <*> lmap snd beWord32+-}+type InvPokeAndPeek value =+  PokeAndPeek value value++instance Profunctor PokeAndPeek where+  {-# INLINE dimap #-}+  dimap fn1 fn2 (PokeAndPeek size poke peek) =+    PokeAndPeek size (\ptr -> poke ptr . fn1) (\ptr -> fmap fn2 (peek ptr))++instance Functor (PokeAndPeek input) where+  {-# INLINE fmap #-}+  fmap fn (PokeAndPeek size poke peek) =+    PokeAndPeek size poke (fmap fn . peek)++instance Applicative (PokeAndPeek input) where+  {-# INLINE pure #-}+  pure x =+    PokeAndPeek 0 (\_ _ -> pure ()) (\_ -> pure x)+  {-# INLINE (<*>) #-}+  (<*>) (PokeAndPeek leftSize leftPoke leftPeek) (PokeAndPeek rightSize rightPoke rightPeek) =+    PokeAndPeek (leftSize + rightSize) poke peek+    where+      poke ptr input =+        leftPoke ptr input *> rightPoke (plusPtr ptr leftSize) input+      peek ptr =+        leftPeek ptr <*> rightPeek (plusPtr ptr leftSize)++{-# INLINE word8 #-}+word8 :: InvPokeAndPeek Word8+word8 =+  PokeAndPeek 1 A.pokeWord8 A.peekWord8++{-# INLINE beWord16 #-}+beWord16 :: InvPokeAndPeek Word16+beWord16 =+  PokeAndPeek 2 A.pokeBEWord16 A.peekBEWord16++{-# INLINE beWord32 #-}+beWord32 :: InvPokeAndPeek Word32+beWord32 =+  PokeAndPeek 4 A.pokeBEWord32 A.peekBEWord32++{-# INLINE beWord64 #-}+beWord64 :: InvPokeAndPeek Word64+beWord64 =+  PokeAndPeek 8 A.pokeBEWord64 A.peekBEWord64++{-# INLINE bytes #-}+bytes :: Int -> InvPokeAndPeek ByteString+bytes amount =+  PokeAndPeek amount (\ptr -> A.pokeBytesTrimming ptr amount) (\ptr -> A.peekBytes ptr amount)
+ library/Ptr/Poking.hs view
@@ -0,0 +1,81 @@+module Ptr.Poking+where++import Ptr.Prelude+import qualified Ptr.IO as A+import qualified Ptr.Poke as C+import qualified Ptr.PokeAndPeek as D+import qualified Data.ByteString.Internal as B+++{-|+Efficiently composable specification of how to populate a pointer.+-}+data Poking =+  {-|+  * Amount of bytes the encoded data will occupy.+  * Exception-free action, which populates the pointer to the encoded data.+  -}+  Poking !Int !(Ptr Word8 -> IO ())++instance Semigroup Poking where+  {-# INLINE (<>) #-}+  (<>) (Poking space1 action1) (Poking space2 action2) =+    Poking (space1 + space2) (\ptr -> action1 ptr *> action2 (plusPtr ptr space1))++instance Monoid Poking where+  {-# INLINE mempty #-}+  mempty =+    Poking 0 (const (pure ()))+  {-# INLINE mappend #-}+  mappend =+    (<>)++{-|+Same as 'mappend' and '<>',+but performs the serialization concurrently.+This comes at the cost of an overhead,+so it is only advised to use this function when the merged serializations are heavy.+-}+prependConc :: Poking -> Poking -> Poking+prependConc (Poking space1 action1) (Poking space2 action2) =+  Poking (space1 + space2) action+  where+    action ptr =+      do+        lock <- newEmptyMVar+        forkIO $ do+          action1 ptr+          putMVar lock ()+        action2 (plusPtr ptr space1)+        takeMVar lock++{-# INLINE word8 #-}+word8 :: Word8 -> Poking+word8 x =+  Poking 1 (flip A.pokeWord8 x)++{-# INLINE beWord32 #-}+beWord32 :: Word32 -> Poking+beWord32 x =+  Poking 4 (flip A.pokeBEWord32 x)++{-# INLINE beWord64 #-}+beWord64 :: Word64 -> Poking+beWord64 x =+  Poking 8 (flip A.pokeBEWord64 x)++{-# INLINE bytes #-}+bytes :: ByteString -> Poking+bytes (B.PS bytesFPtr offset length) =+  Poking length (\ptr -> withForeignPtr bytesFPtr (\bytesPtr -> B.memcpy ptr (plusPtr bytesPtr offset) length))++{-# INLINE poke #-}+poke :: C.Poke input -> input -> Poking+poke (C.Poke space poke) input =+  Poking space (\ptr -> poke ptr input)++{-# INLINE pokeAndPeek #-}+pokeAndPeek :: D.PokeAndPeek input output -> input -> Poking+pokeAndPeek (D.PokeAndPeek space poke _) input =+  Poking space (\ptr -> poke ptr input)
+ library/Ptr/Prelude.hs view
@@ -0,0 +1,59 @@+module Ptr.Prelude+(+  module Exports,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (assert, left, right, isLeft, isRight, (<>), First(..), Last(..), ProtocolError, traceEvent, traceEventIO, traceMarker, traceMarkerIO)++-- base+-------------------------+import Foreign as Exports hiding (void)++-- transformers+-------------------------+import Control.Monad.IO.Class as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Cont as Exports hiding (shift, callCC)+import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT, throwE, catchE)+import Control.Monad.Trans.Maybe as Exports+import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT)+import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT)+import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT)++-- mtl+-------------------------+import Control.Monad.Cont.Class as Exports+import Control.Monad.Error.Class as Exports hiding (Error(..))+import Control.Monad.Reader.Class as Exports+import Control.Monad.State.Class as Exports+import Control.Monad.Writer.Class as Exports++-- contravariant+-------------------------+import Data.Functor.Contravariant as Exports+import Data.Functor.Contravariant.Divisible as Exports++-- profunctors+-------------------------+import Data.Profunctor.Unsafe as Exports+import Data.Profunctor as Exports hiding (WrappedArrow, WrapArrow, unwrapArrow)++-- semigroups+-------------------------+import Data.Semigroup as Exports++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- text+-------------------------+import Data.Text as Exports (Text)++-- bug+-------------------------+import Bug as Exports
+ library/Ptr/Receive.hs view
@@ -0,0 +1,40 @@+module Ptr.Receive+(+  Receive,+  create,+  peek,+)+where++import Ptr.Prelude hiding (peek)+import qualified Ptr.Receive.Core as A+import qualified Ptr.Peek as B+++{-|+A wrapper of a receiving action, which extends it with bufferization.+-}+data Receive =+  {-|+  * Exception-free action to receive another chunk of bytes. E.g., an exception-free wrapper of @Network.Socket.recvBuf@+  * Buffer+  * Size of the buffer+  * Chunk size+  -}+  Receive !(Ptr Word8 -> Int -> IO (Either Text Int)) !(ForeignPtr Word8) !(IORef (Int, Int)) !Int++create :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> Int -> IO Receive+create fetch chunkSize =+  do+    bufferFP <- mallocForeignPtrBytes chunkSize+    bufferStateRef <- newIORef (0, 0)+    return (Receive fetch bufferFP bufferStateRef chunkSize)++{-|+Receive as many bytes as is required by the provided decoder and decode immediately.++If all you need is just to get a 'ByteString' chunk then use the 'B.bytes' decoder.+-}+peek :: Receive -> B.Peek peekd -> IO (Either Text peekd)+peek (Receive fetch bufferFP bufferStateRef chunkSize) (B.Peek amount action) =+  A.peek fetch bufferFP bufferStateRef chunkSize amount action
+ library/Ptr/Receive/Core.hs view
@@ -0,0 +1,100 @@+module Ptr.Receive.Core+where++import Ptr.Prelude+import qualified Data.ByteString.Internal as A+++write :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> ForeignPtr Word8 -> IORef (Int, Int) -> Int -> Int -> Ptr Word8 -> IO (Either Text ())+write fetch bufferFP bufferStateRef chunkSize howMany destination =+  do+    (offset, end) <- readIORef bufferStateRef+    if end == offset+      then+        -- Buffer is empty, we need to fetch right away+        fetchMany fetch bufferFP bufferStateRef chunkSize howMany destination+      else+        -- We still have something in the buffer, so we'll read from it first+        withForeignPtr bufferFP $ \bufferPtr ->+        let+          amountInBuffer = end - offset+          in if amountInBuffer >= howMany+            then+              -- Buffer contains all we need, so we don't need to fetch at all+              do+                A.memcpy destination (plusPtr bufferPtr offset) howMany+                writeIORef bufferStateRef (offset + howMany, end)+                return (Right ())+            else+              do+                A.memcpy destination (plusPtr bufferPtr offset) amountInBuffer+                fetchMany fetch bufferFP bufferStateRef chunkSize (howMany - amountInBuffer) (plusPtr destination amountInBuffer)++fetchMany :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> ForeignPtr Word8 -> IORef (Int, Int) -> Int -> Int -> Ptr Word8 -> IO (Either Text ())+fetchMany fetch bufferFP bufferStateRef chunkSize remaining destination =+  if remaining >= chunkSize+    then+      -- Circumvent the buffer and write to destination directly+      fetchingSome destination chunkSize $ \amountFetched ->+      if amountFetched == remaining+        then+          -- We've fetched all we've wanted, time to stop+          do+            writeIORef bufferStateRef (0, 0)+            return (Right ())+        else+          -- Go on and get some more+          fetchMany fetch bufferFP bufferStateRef chunkSize (remaining - amountFetched) (plusPtr destination amountFetched)+    else+      -- Write to buffer first and then stream a part of it to the destination+      withForeignPtr bufferFP $ \bufferPtr ->+      fetchingSome bufferPtr chunkSize $ \amountFetched ->+      do+        A.memcpy destination bufferPtr remaining+        writeIORef bufferStateRef (remaining, amountFetched)+        return (Right ())+  where+    fetchingSome destination amount handle =+      do+        fetchResult <- fetch destination amount+        case fetchResult of+          Left msg -> return (Left msg)+          Right amountFetched ->+            if amountFetched == 0+              then return (Left "End of input")+              else handle amountFetched++peek :: (Ptr Word8 -> Int -> IO (Either Text Int)) -> ForeignPtr Word8 -> IORef (Int, Int) -> Int -> Int -> (Ptr Word8 -> IO peekd) -> IO (Either Text peekd)+peek fetch bufferFP bufferStateRef chunkSize howMany peek =+  do+    (offset, end) <- readIORef bufferStateRef+    let+      amountInBuffer = end - offset+      in if amountInBuffer >= howMany+        then+          -- We have enough bytes in the buffer, so need not to allocate anything and can directly decode from the buffer+          withForeignPtr bufferFP $ \bufferPtr ->+          do+            peekd <- peek bufferPtr+            writeIORef bufferStateRef (offset + howMany, end)+            return (Right peekd)+        else+          -- We have to allocate a temporary space to prefetch the data into+          allocaBytes howMany $ \tmpPtr ->+          do+            writeResult <-+              if end == offset+                then+                  -- Buffer is empty, we need to fetch right away+                  fetchMany fetch bufferFP bufferStateRef chunkSize howMany tmpPtr+                else+                  -- We still have something in the buffer, so we'll read from it first+                  withForeignPtr bufferFP $ \bufferPtr ->+                  do+                    A.memcpy tmpPtr (plusPtr bufferPtr offset) amountInBuffer+                    fetchMany fetch bufferFP bufferStateRef chunkSize (howMany - amountInBuffer) (plusPtr tmpPtr amountInBuffer)+            case writeResult of+              Right () -> do+                peekd <- peek tmpPtr+                return (Right peekd)+              Left msg -> return (Left msg)
+ library/Ptr/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 Ptr.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
+ ptr.cabal view
@@ -0,0 +1,95 @@+name:+  ptr+version:+  0.15.2+category:+  Ptr, Data+synopsis:+  Abstractions for operations on pointers+homepage:+  https://github.com/nikita-volkov/ptr +bug-reports:+  https://github.com/nikita-volkov/ptr/issues +author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2017, 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.git++library+  hs-source-dirs:+    library+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, PatternSynonyms, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  exposed-modules:+    Ptr.Peek+    Ptr.Parse+    Ptr.Poke+    Ptr.PokeAndPeek+    Ptr.Receive+    Ptr.Poking+    Ptr.ByteString+  other-modules:+    Ptr.Receive.Core+    Ptr.IO+    Ptr.UncheckedShifting+    Ptr.Prelude+  build-depends:+    -- data:+    text == 1.*,+    bytestring >= 0.10 && < 0.11,+    -- control:+    semigroups >= 0.18 && < 0.20,+    profunctors >= 5.1 && < 6,+    contravariant >= 1.3 && < 2,+    mtl >= 2 && < 3,+    transformers >= 0.3 && < 0.6,+    -- errors:+    bug == 1.*,+    -- general:+    base-prelude >= 1 && < 2,+    base >= 4.7 && < 5++test-suite tests+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    tests+  main-is:+    Main.hs+  ghc-options:+    -O2+    -threaded+    "-with-rtsopts=-N"+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    --+    ptr,+    -- testing:+    tasty == 0.11.*,+    tasty-quickcheck == 0.8.*,+    tasty-hunit == 0.9.*,+    quickcheck-instances >= 0.3.11 && < 0.4,+    --+    bug == 1.*,+    rerebase == 1.*
+ tests/Main.hs view
@@ -0,0 +1,47 @@+module Main where++import Prelude+import Bug+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.QuickCheck.Instances+import qualified Ptr.Poke as B+import qualified Ptr.Peek as C+import qualified Ptr.PokeAndPeek as E+import qualified Data.ByteString as D+++main =+  defaultMain $+  testGroup "All tests"+  [+    testProperty "Poke and peek (bytes)" $ \input -> input === fromJust (pokeThenPeek (B.bytes (D.length input)) (C.bytes (D.length input))) input+    ,+    testProperty "Poke and peek (word8)" $ \input -> input === fromJust (pokeThenPeek B.word8 C.word8) input+    ,+    testProperty "Poke and peek (beWord32)" $ \input -> input === fromJust (pokeThenPeek B.beWord32 C.beWord32) input+    ,+    testProperty "Poke and peek (beWord64)" $ \input -> input === fromJust (pokeThenPeek B.beWord64 C.beWord64) input+    ,+    testProperty "PokeAndPeek composition" $ \input -> input === pokeAndPeek ((,) <$> lmap fst E.word8 <*> lmap snd E.beWord32) input+  ]++pokeThenPeek :: B.Poke a -> C.Peek a -> Maybe (a -> a)+pokeThenPeek (B.Poke pokeSize pokeIO) (C.Peek peekSize peekIO) =+  if pokeSize /= peekSize+    then Nothing+    else Just $ \input -> unsafePerformIO $ do+      fp <- mallocForeignPtrBytes pokeSize+      withForeignPtr fp $ \p -> do+        pokeIO p input+        peekIO p++pokeAndPeek :: E.PokeAndPeek input output -> input -> output+pokeAndPeek (E.PokeAndPeek size poke peek) input =+  unsafePerformIO $ do+    fp <- mallocForeignPtrBytes size+    withForeignPtr fp $ \p -> do+      poke p input+      peek p