Small utility library to make a type-directed binary stream parsing (when protocol has fixed-size packets). Is a subject to expansion.

Mapper.hs

{-# LANGUAGE MultiParamTypeClasses
           , FlexibleContexts
           , ScopedTypeVariables
           , TypeFamilies
           , UndecidableInstances
           , FlexibleInstances #-}

import qualified Data.ByteString as B
import Data.ByteString (ByteString)

import Data.Char
import Data.Bits
import Data.Word

data Zero
data S a

type One   = S Zero
type Two   = S One
type Three = S Two
type Four  = S Three
type Five  = S Four
type Six   = S Five
type Seven = S Six
type Eight = S Seven

data Location byte bit size

class Inductive a where
    order :: a -> Int

mask :: Inductive a => a -> Int
mask = order |> (2^) |> (+ negate 1)

instance Inductive Zero where
    order _ = 0

instance Inductive a => Inductive (S a) where
    order (_ :: S a) = 1 + order (undefined :: a)

locate a = B.drop (order a)

locate_bit a line = 
    let Just (hd, tl) = B.uncons line in

    (hd `shiftR` (order a)) `B.cons` tl

s2b = B.pack . map (fromIntegral . ord)
b2s = map (chr . fromIntegral) . B.unpack

class Parseable l w where
    parse :: l -> ByteString -> w

instance (Inductive byte, Inductive bit, Inductive size) 
    => Parseable (Location byte bit size) Word8 where

    parse (_ :: Location byte bit size) = id
        |> locate     (undefined :: byte)
        |> locate_bit (undefined :: bit)
        |> B.head
        |> (.&. (fromIntegral (mask (undefined :: size))))

(|>) = flip (.)

class Shiftable s d where
    type Shift s d :: *

instance Inductive a => Shiftable (S a) Zero where
    type Shift (S a) Zero = (S a)

instance (Inductive a, Inductive d) => Shiftable (S a) (S d) where
    type Shift (S a) (S d) = Shift (S (S a)) d

instance Inductive d => Shiftable Zero d where
    type Shift Zero d = d

instance (Shiftable a d, Inductive d) => Shiftable (Location a b c) d where
    type Shift (Location a b c) d = (Location (Shift a d) b c)

data LWord location

instance Shiftable location x => Shiftable (LWord location) x where
    type Shift (LWord location) x = LWord (Shift location x)

instance ( Parseable        location      Word8
         , Parseable (Shift location One) Word8) 

    => Parseable (LWord location) Word16 where

    parse (_ :: LWord location) line =
        let high :: Word8 = parse (undefined :: location) line in
        let low  :: Word8 = parse (undefined :: Shift location One) line in 0
        + (fromIntegral $ high) * 256 
        + (fromIntegral $ low)

*Main> parse (undefined :: LWord (Location One Zero Eight)) $ B.pack [0, 0x12, 0xF0] :: Word16
4848
*Main> 0x12F0
4848