module File.Binary.Instances () where
import Prelude hiding (take, drop, span)
import File.Binary.Classes (Field(..), Binary(..))
import Data.Word (Word8)
import Data.ByteString.Lazy
(ByteString, take, drop, toChunks, fromChunks, pack, unpack, uncons, span)
import qualified Data.ByteString.Lazy.Char8 as BSLC (pack, unpack)
import qualified Data.ByteString as BS (ByteString, take, drop, concat, uncons, span)
import qualified Data.ByteString.Char8 ()
import Control.Monad (replicateM, foldM)
import "monads-tf" Control.Monad.State (StateT(..), gets)
import Control.Applicative ((<$>), (<*>))
import Control.Arrow (first, (&&&))
import Data.Monoid (mempty)
import Data.Char
import Data.Maybe
instance Field ByteString where
type FieldArgument ByteString = Int
fromBinary a = return . getBytes a
toBinary _ = return . makeBinary
instance Field BS.ByteString where
type FieldArgument BS.ByteString = Int
fromBinary n = return . first (BS.concat . toChunks) . getBytes n
toBinary _ = return . makeBinary . fromChunks . (: [])
instance Field Char where
type FieldArgument Char = ()
fromBinary _ = return . first (head . BSLC.unpack) . getBytes 1
toBinary _ = return . makeBinary . BSLC.pack . (: [])
instance Field Word8 where
type FieldArgument Word8 = ()
fromBinary _ = return . first (head . unpack) . getBytes 1
toBinary _ = return . makeBinary . pack . (: [])
instance Field r => Field [r] where
type FieldArgument [r] = (FieldArgument r, Maybe Int)
fromBits (a, Just b) = b `times` fromBits a
fromBits (a, Nothing) = mempty `whole` fromBits a
consToBits (a, _) fs ret = foldM (flip $ consToBits a) ret $ reverse fs
times :: Monad m => Int -> (s -> m (ret, s)) -> s -> m ([ret], s)
times n f = runStateT $ replicateM n (StateT f)
whole :: (Functor m, Monad m, Eq s) => s -> (s -> m (ret, s)) -> s -> m ([ret], s)
whole e f = runStateT $ do
emp <- gets (== e)
if emp then return [] else
(:) <$> StateT f <*> (StateT $ whole e f)
instance Binary String where
getBytes n = first BSLC.pack . splitAt n
unconsByte = fromIntegral . ord . head &&& tail
makeBinary = BSLC.unpack
instance Binary ByteString where
getBytes n = take (fromIntegral n) &&& drop (fromIntegral n)
spanBytes = span
unconsByte = fromMaybe (0, "") . uncons
makeBinary = id
instance Binary BS.ByteString where
getBytes n = fromChunks . (: []) . BS.take n &&& BS.drop n
spanBytes p = first (fromChunks . (: [])) . BS.span p
unconsByte = fromMaybe (0, "") . BS.uncons
makeBinary = BS.concat . toChunks