-
-
Save am-kantox/605c96daf581cfa5dd3cfdfa6f57c116 to your computer and use it in GitHub Desktop.
Binary pattern-matching on bytestrings
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
{-# 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])) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment