{-# LANGUAGE TypeFamilies, TupleSections, OverloadedStrings #-}

module File.Binary.Classes (Field(..), Binary(..), pop, push) where

import Data.ByteString.Lazy (ByteString, unpack, singleton, cons')
import qualified Data.ByteString.Lazy.Char8 as BSLC ()
import Data.Bits ((.&.), (.|.), shiftL, shiftR)
import Data.Monoid (Monoid, mappend, mempty)
import Data.Word
import Control.Arrow (first, second)
import Control.Applicative
import Control.Monad

type AddBits b = ([Bool], b)

class Field f where
	type FieldArgument f
	fromBinary :: (Binary b, Applicative m, Monad m) => FieldArgument f -> b -> m (f, b)
	toBinary :: (Binary b, Applicative m, Monad m) => FieldArgument f -> f -> m b
	fromBits :: (Binary b, Applicative m, Monad m) =>
		FieldArgument f -> AddBits b -> m (f, AddBits b)
	consToBits :: (Binary b, Applicative m, Monad m) =>
		FieldArgument f -> f -> AddBits b -> m (AddBits b)

	fromBits a ([], b) = second ([] ,) `liftM` fromBinary a b
	fromBits _ _ = error "fromBits: not bytes (1 byte = 8 bits)"
	consToBits a f ([], b) = do
		ret <- (`mappend` b) <$> toBinary a f
		return ([], ret)
	consToBits _ _ (bits, _) =
		fail $ "consToBits: not bytes (1 byte = 8 bits) " ++ show bits

	fromBinary a b = do
		ret <- fromBits a ([], b)
		case ret of
			(f, ([], rest)) -> return (f, rest)
			_ -> fail "fromBinary: not bytes (1 byte = 8 bits)"
	toBinary a f = do
		ret <- consToBits a f ([], mempty)
		case ret of
			([], bin) -> return bin
			(bits, _) -> fail $
				"toBinary: not bytes (1 byte = 8 bits) " ++ show bits

pop :: Binary b => b -> AddBits b
pop = first (wtbs (8 :: Int) . head . unpack) . getBytes 1
	where
	wtbs 0 _ = []
	wtbs n w = toEnum (fromIntegral $ 1 .&. w) : wtbs (n - 1) (w `shiftR` 1)

push :: Binary b => AddBits b -> b
push = uncurry $ mappend . makeBinary . singleton . bstw
	where
	bstw = foldr (\b w -> w `shiftL` 1 .|. fromIntegral (fromEnum b)) 0

class (Eq b, Monoid b) => Binary b where
	getBytes :: Int -> b -> (ByteString, b)
	spanBytes :: (Word8 -> Bool) -> b -> (ByteString, b)
	unconsByte :: b -> (Word8, b)
	makeBinary :: ByteString -> b

	getBytes 0 b = ("", b)
	getBytes n b = let
		(h, t) = unconsByte b
		(r, b') = getBytes (n - 1) t in
		(h `cons'` r, b')

	spanBytes p b
		| b == makeBinary "" = ("", b)
		| p h = let (ret, rest) = spanBytes p t in (h `cons'` ret, rest)
		| otherwise = ("", b)
		where
		(h, t) = unconsByte b