{-# LANGUAGE
	TypeSynonymInstances,
	FlexibleInstances,
	TypeFamilies,
	OverloadedStrings #-}

module Classes (
	Field(..),
	Binary(..),
	fii, tii,
	readInt,
	dp, fs, ti, cc,
	lintToBin
) where

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Data.Char
import Control.Arrow

data Endian = BigEndian | LittleEndian deriving Show

readInt :: Endian -> String -> Integer
readInt LittleEndian "" = 0
readInt LittleEndian (c : cs) = fromIntegral (ord c) + 2 ^ (8 :: Integer) * readInt LittleEndian cs
readInt BigEndian str = readInt LittleEndian $ reverse str

class Field r where
	type FieldArgument r
	fromBinary :: Binary s => FieldArgument r -> s -> (r, s)
	toBinary :: Binary s => FieldArgument r -> r -> s

instance Field r => Field [r] where
	type FieldArgument [r] = (FieldArgument r, Maybe Int)
	fromBinary (a, Just b) s = (b `times` fromBinary a) s
	fromBinary (a, Nothing) s = whole (fromBinary a) s
	toBinary (a, _) rs = cc $ map (toBinary a) rs

instance Field Char where
	type FieldArgument Char = ()
	fromBinary _ str = (head $ BSLC.unpack t, d)
		where
		(t, d) = getBytes 1 str
	toBinary _ = fs . (: [])

instance Field BS.ByteString where
	type FieldArgument BS.ByteString = Int
	fromBinary n str =
		first (BS.concat . BSL.toChunks) $ getBytes n str
	toBinary _ = makeBinary . BSL.fromChunks . (: [])

class Binary a where
	getBytes :: Int -> a -> (BSL.ByteString, a)
	makeBinary :: BSL.ByteString -> a
	concatBinary :: [a] -> a
	emptyBinary :: a -> Bool

empty :: Binary a => a -> Bool
empty = emptyBinary

cc :: Binary a => [a] -> a
cc = concatBinary

ti :: Binary a => a -> Integer
ti = readInt LittleEndian . BSLC.unpack . fst . getBytes 100

fs :: Binary a => String -> a
fs = makeBinary . BSLC.pack

dp :: Binary a => Int -> a -> a
dp n = snd . getBytes n

instance Binary String where
	getBytes n = BSLC.pack . take n &&& drop n
	makeBinary = BSLC.unpack

	concatBinary = concat
	emptyBinary = null

fii :: Binary a => Int -> Int -> a
fii n = makeBinary . BSLC.pack . intToBin LittleEndian n . fromIntegral
tii :: Binary a => Int -> a -> (Int, a)
tii _ str = let
	(t, d) = getBytes 4 str in
	(fromIntegral $ ti t, d)

instance Binary BSL.ByteString where
	getBytes n = BSL.take (fromIntegral n) &&& BSL.drop (fromIntegral n)
	makeBinary = id

	concatBinary = BSL.concat
	emptyBinary = (== 0) . BSL.length

instance Binary BS.ByteString where
	getBytes n = BSL.fromChunks . (: []) . BS.take n &&& BS.drop n
	makeBinary = BS.concat . BSL.toChunks

	concatBinary = BS.concat
	emptyBinary = (== 0) . BS.length

lintToBin :: Int -> Integer -> String
lintToBin = intToBin LittleEndian

intToBin :: Endian -> Int -> Integer -> String
intToBin LittleEndian 0 _ = ""
intToBin LittleEndian n x = chr (fromIntegral $ x `mod` 256) :
	intToBin LittleEndian (fromIntegral n - 1) (x `div` 256)
intToBin BigEndian n x = reverse $ intToBin LittleEndian n x

times :: Int -> (s -> (ret, s)) -> s -> ([ret], s)
times 0 _ s = ([], s)
times n f s = let
	(ret, rest) = f s
	(rets, rest') = times (n - 1) f rest in
	(ret : rets, rest')

whole :: Binary s => (s -> (ret, s)) -> s -> ([ret], s)
whole f s
	| empty s = ([], s)
	| otherwise = let
		(ret, rest) = f s
		(rets, rest') = whole f rest in
		(ret : rets, rest')