Binary pattern-matching on bytestrings

Binary.hs

{-# LANGUAGE
    ScopedTypeVariables,
    ViewPatterns,
    PatternSynonyms #-}

import Data.Bits (Bits, shift)
import Data.Word
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import GHC.Float (castWord32ToFloat)

class Binary a where
  fromBS :: ByteString -> Maybe (a, ByteString)

instance Binary Word8 where
  fromBS = BS.uncons

f8 :: (Num a, Bits a) => Word8 -> Int -> a
f8 n i = shift (fromIntegral n) i

newtype Little32 = Little32 { unLittle32 :: Word32 }

instance Binary Little32 where
  fromBS
    (fromBS -> Just (a0,
     fromBS -> Just (a1,
     fromBS -> Just (a2,
     fromBS -> Just (a3, rest))))) =
     Just (Little32 (f8 a0 0 + f8 a1 8 + f8 a2 16 + f8 a3 24), rest)
  fromBS _ = Nothing

newtype Little64 = Little64 { unLittle64 :: Word64 }

instance Binary Little64 where
  fromBS
    (fromBS -> Just (a0,
     fromBS -> Just (a1,
     fromBS -> Just (a2,
     fromBS -> Just (a3,
     fromBS -> Just (a4,
     fromBS -> Just (a5,
     fromBS -> Just (a6,
     fromBS -> Just (a7, rest))))))))) =
     let n = f8 a0 0 + f8 a1 8 + f8 a2 16 + f8 a3 24 + f8 a4 32 + f8 a5 40 + f8 a6 48 + f8 a7 56
     in Just (Little64 n, rest)
  fromBS _ = Nothing

word32ToFloat :: Word32 -> Float
word32ToFloat = castWord32ToFloat

newtype LittleFloat32 = LittleFloat32 { unLittleFloat32 :: Float }

instance Binary LittleFloat32 where
  fromBS v = do
    (Little32 a0, rest) <- fromBS v
    pure (LittleFloat32 (word32ToFloat a0), rest)

pattern (:.) :: Binary a => a -> ByteString -> ByteString
pattern x :. y <- (fromBS -> Just (x, y))

infixr 1 :.

f :: ByteString -> (Word32, Word8, ByteString)
f myData =
  case myData of
    (1 :: Word8) :.
      (44 :: Word8) :.
      (a :: Little32) :.
      (b :: Little64) :.
      (c :: Word8) :.
      (d :: Little64) :.
      (e :: LittleFloat32) :.
      rest ->
      {- using a, b, c, d, e, rest -}
      (unLittle32 a, c, rest)
    _ -> undefined

main :: IO ()
main = print (f (BS.pack [1, 44, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0]))

That indeed makes things tricky. Doing it in two or three steps would be the obvious solution (b would probably take its own step).

You could reduce the dependency by making "length-prefixed strings" its own type:

-- Generalized by the type of length
newtype LengthPrefixed a = LengthPrefixed a ByteString

f :: ByteString -> ...
f bs = case bs of
  (a :: Little16) :.
    (LengthPrefixed (len :: Word8) b) :.
    (c :: Word8) :.
    (d :: Word8) :.
    rest -> ...

Or you can try view patterns, which should allow such dependencies:

getByLength :: Integral a => a -> ByteString -> Maybe (ByteString, ByteString)
getByLength = ...

f :: ByteString -> ...
f bs = case bs of
 (a :: Little16) :.
   (len :: Word8) :.
   (getByLength len -> Just (b,
     (c :: Word8) :.
     (d :: Word8) :.
     rest)) -> ...

I'll try that.

At the moment I've done it in 2 steps.

2nd step looks like this:

(b, rest2) = Data.List.splitAt len1 rest1

How will LengthPrefixed example work? As is it won't. How would it be implemented?

As is it won't.

What error did you get and what have you tried to fix them?

data LengthPrefixed a = LengthPrefixed a ByteString

instance (Binary a, Integral a) => Binary (LengthPrefixed a) where
  fromBS (n :. restn)
    | fromIntegral n > BS.length restn = Nothing
    | otherwise =
      case BS.splitAt (fromIntegral n) restn of
        (x, rest) -> Just (LengthPrefixed n x, rest)

there was no implementation for Binary (LengthPrefixed a) in your previous example.

Thx.