-- "src/Dao/Binary.hs"  declares the binary serializing monad.
-- 
-- Copyright (C) 2008-2014  Ramin Honary.
-- This file is part of the Dao System.
--
-- The Dao System is free software: you can redistribute it and/or
-- modify it under the terms of the GNU General Public License as
-- published by the Free Software Foundation, either version 3 of the
-- License, or (at your option) any later version.
-- 
-- The Dao System is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
-- 
-- You should have received a copy of the GNU General Public License
-- along with this program (see the file called "LICENSE"). If not, see
-- <http://www.gnu.org/licenses/agpl.html>.

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}

-- | This module provides an essential wrapper around the 'Data.Binary.Binary' monad which allows a
-- binary serializer to read data type tags in the byte stream and select the next parser to be used
-- by looking up the parser with data type tag.
-- 
-- Dao's binary protocol is compact and efficient, with every fundamental data type prefixed with a
-- single byte of information. Integers of arbitrary length are stored using Variable Length Integer
-- (VLI) encoding. However the byte stream is not compressed, and there are no functions in this
-- module which facilitate this, it is up to you to do compression. Using algorithms like GZip or
-- BZip2 will almost certainly decrese the size of the byte stream as Dao's binary protocol makes
-- no attempt to reduce data entropy.
--
-- Arbitrary data types can be encoded as long as they instantiate 'Data.Typeable.Typeable' and
-- 'Dao.Interpreter.ObjectInterface' and have been made available to the 'Dao.Interpreter.Runtime' during
-- initialization of the Dao program. Each new type placed in the stream creates an integer tag in
-- an index with the 'Data.Typeable.TypeRep', and every item of the type that is placed after that
-- tag is prefixed with the integer index value. When decoding, the index of tags is constructed on
-- the fly as they are read from arbitrary points in the stream, and the index is used to select the
-- correct binary decoder from the 'Dao.Interpreter.ObjectInterface' stored in the 'Dao.Interpreter.Runtime'.
-- 
-- Of course, this module is not a full re-writing of "Data.Binary", it relies heavily on the
-- "Data.Binary" module, and provides a Dao-friendly wrapper around it.
module Dao.Binary where

import           Dao.String
import qualified Dao.Tree             as T
import           Dao.Token
import           Dao.Predicate

import           Control.Applicative
import           Control.Monad
import           Control.Monad.Error
import qualified Control.Monad.State  as S

import           Data.Monoid
import           Data.Dynamic
import           Data.Char
import           Data.Int
import           Data.Ratio
import           Data.Complex
import           Data.Word
import           Data.Bits
import           Data.Time
import           Data.Array.IArray
import qualified Data.Map             as M
import qualified Data.IntMap          as Im
import qualified Data.Set             as S
import qualified Data.IntSet          as Is
import qualified Data.ByteString.Lazy as Z

import           Data.Digest.SHA1     as SHA1
import qualified Data.Binary.IEEE754  as B
import qualified Data.ByteString      as B
import qualified Data.Binary          as B
import qualified Data.Binary.Get      as B
import qualified Data.Binary.Put      as B

----------------------------------------------------------------------------------------------------

type Byte = Word8
type InStreamID = Word32
type ByteOffset = B.ByteOffset

-- | A data type used to help instantiate the 'Dao.Binary.Binary' class. Refer to the
-- 'fromDataBinary' function for more details.
data Serializer mtab a = Serializer{ serializeGet :: GGet mtab a, serializePut :: a -> GPutM mtab () }

-- | Minimal complete definition is to either instantiate both 'get' and 'put', or to instnatiate
-- just 'serializer'. You can instantiate all three if you want but that may cause a lot of
-- confusion. Apart from 'serializer', it is identical to the 'Data.Binary.Binary' class, so please
-- refer to that module for more background information on how to use this one.
class Binary a mtab where
  get :: GGet mtab a
  get = serializeGet serializer
  put :: a -> GPutM mtab ()
  put = serializePut serializer
  serializer :: Serializer mtab a
  serializer = Serializer{serializeGet=Dao.Binary.get,serializePut=Dao.Binary.put}

class HasCoderTable mtab where
  getEncoderForType :: Name -> mtab -> Maybe (Dynamic -> GPut mtab)
  getDecoderForType :: Name -> mtab -> Maybe (GGet mtab Dynamic)

-- | To evaluate a 'GPut' or 'GGet' function without providing any coder table, simply pass @()@.
instance HasCoderTable () where
  getEncoderForType _ _ = Nothing
  getDecoderForType _ _ = Nothing

data EncodeIndex mtab
  = EncodeIndex
    { indexCounter :: InStreamID
    , encodeIndex  :: M.Map Name InStreamID
    , encMTabRef   :: mtab
    }

data DecodeIndex mtab
  = DecodeIndex
    { decodeIndex  :: M.Map InStreamID Name
    , decMTabRef   :: mtab
    }

newtype GPutM mtab a = PutM{ encoderToStateT :: S.StateT (EncodeIndex mtab) B.PutM a }
type GPut mtab = GPutM mtab ()

data GGetErr = GetErr { gGetErrOffset :: ByteOffset, gGetErrMsg :: UStr }
instance Show GGetErr where { show (GetErr ofst msg) = "(offset="++show ofst++") "++uchars msg }

newtype GGet mtab a = Get{ decoderToStateT :: PredicateT GGetErr (S.StateT (DecodeIndex mtab) B.Get) a }

instance Functor (GPutM mtab) where { fmap f (PutM a) = PutM (fmap f a) }
instance Monad (GPutM mtab) where
  return = PutM . return
  (PutM a) >>= fn = PutM (a >>= encoderToStateT . fn)
  fail = PutM . fail
instance Applicative (GPutM mtab) where { pure=return; (<*>)=ap; }
instance Monoid a => Monoid (GPutM mtab a) where
  mempty=return mempty
  mappend a b = a >>= \a -> b >>= \b -> return (mappend a b)
instance HasCoderTable mtab => S.MonadState (EncodeIndex mtab) (GPutM mtab) where
  state fn = PutM (S.state fn)

instance Functor (GGet mtab) where { fmap f (Get a) = Get (fmap f a) }
instance Monad (GGet mtab) where
  return = Get . return
  (Get a) >>= fn = Get (a >>= decoderToStateT . fn)
  Get a >> Get b = Get (a >> b)
  fail msg = bytesRead >>= \ofst -> Get (throwError (GetErr ofst (toUStr msg)))
instance MonadPlus   (GGet mtab) where { mzero = Get mzero; mplus (Get a) (Get b) = Get (mplus a b); }
instance Applicative (GGet mtab) where { pure=return; (<*>)=ap;    }
instance Alternative (GGet mtab) where { empty=mzero; (<|>)=mplus; }
instance Monoid a => Monoid (GGet mtab a) where
  mempty=return mempty
  mappend a b = a >>= \a -> b >>= \b -> return (mappend a b)
instance S.MonadState (DecodeIndex mtab) (GGet mtab) where
  state = Get . lift . S.state
instance MonadError GGetErr (GGet mtab) where
  throwError = Get . throwError
  catchError (Get fn) catch = Get (catchError fn (decoderToStateT . catch))

-- | This class only exists to provide the the function 'getCoderTable' with the exact same function
-- in both the 'GPutM' and 'GGet' monads, rather than having a separate function for each monad.
class HasCoderTable mtab => ProvidesCoderTable m mtab where { getCoderTable :: m mtab }
instance HasCoderTable mtab => ProvidesCoderTable (GPutM mtab) mtab where { getCoderTable = S.gets encMTabRef }
instance HasCoderTable mtab => ProvidesCoderTable (GGet  mtab) mtab where { getCoderTable = S.gets decMTabRef }

data InStreamIndex = InStreamIndex{ inStreamIndexID :: InStreamID, inStreamIndexLabel :: Name }
  deriving (Eq, Ord, Show)
instance HasCoderTable mtab => Binary InStreamIndex mtab where
  put (InStreamIndex a b) = prefixByte 0x01 $ put a >> put b
  get = tryWord8 0x01 $ pure InStreamIndex <*> get <*> get

-- | Find the 'Dao.String.UStr' that was associated with this 'InStreamID' when the byte stream was
-- constructed when 'newInStreamID' was called.
decodeIndexLookup :: HasCoderTable mtab => InStreamID -> GGet mtab (Maybe Name)
decodeIndexLookup tid = M.lookup tid <$> S.gets decodeIndex

-- | Given an 'Data.Int.Int64' length value, compute how many VLI bytes of hash code should be
-- necessary to for a byte stream of that length, and return an 'Data.Word.Word64' value trimmed to
-- that byte length.
trimIntegerHash :: Int64 -> Integer -> (Int, Integer)
trimIntegerHash i h = snd $ head $ dropWhile ((i<) . fst) $
  map (\x -> (2^(8+4*(fromIntegral x :: Int)), (x, h .&. (2^(7*x)-1)))) [0..14::Int]

-- | A trimmed hash is an hash produced by SHA1 along with the length of the original data. However
-- it instantiates 'Prelude.Eq', and 'Binary' in such a way that only a maximum of 5 bytes of the
-- hash value are ever stored and used for verification. This is to conserve space in a byte stream
-- when writing smaller chunks of data. For example, it is not necessary to store all 20 bytes of
-- the hash code when the data you are storing or reading is itself 20 bytes long.
data TrimmedHash = TrimmedHash Int64 Integer deriving (Eq, Ord)
instance Binary TrimmedHash mtab where
  put (TrimmedHash i h0) =
    let (len, h) = trimIntegerHash i h0
    in  if len>0 then putPosIntegral h else return ()
  get = TrimmedHash (error "TrimmedHash length not set") <$> getPosIntegral

-- | Create a 'TrimmedHash' a list of bytes as the second parameter and the maximum length of the
-- list as the first parameter.
trimmedHash :: Z.ByteString -> TrimmedHash
trimmedHash blk = mkTrimmedHash blk where
  len = Z.length blk
  mkTrimmedHash = TrimmedHash len . snd . trimIntegerHash len . SHA1.toInteger . hash .
    map snd . takeWhile ((>0) . fst) . zip (iterate (\x->x-1) len) . Z.unpack

-- not for export
setTrimmedHashLength :: Int64 -> TrimmedHash -> TrimmedHash
setTrimmedHashLength i (TrimmedHash _ h) = TrimmedHash i h

trimmedHashVerify :: Z.ByteString -> TrimmedHash -> Bool
trimmedHashVerify b = (trimmedHash b ==)

-- | A lazy block stream that wraps up a 'Data.ByteString.Lazy.ByteString' in a data type that
-- instantiates 'Binary' in such a way that the bytes are written lazily in chunks of 1 megabyte
-- blocks with checksums, providing a protocol that can encode and decode arbitrarily large data
-- without interfearing with the protocol used by this module.
newtype BlockStream1M = BlockStream1M { block1MStreamToByteString :: Z.ByteString }
instance Binary BlockStream1M mtab where
  put =
    mapM_ (\ blk -> put blk >> put (trimmedHash blk)
          ) . fix (\ loop blk ->
                      let (a,b) = Z.splitAt (2^(20::Int)) blk in a : if Z.null b then [] else loop b
                  ) . block1MStreamToByteString
  get = (BlockStream1M . Z.concat) <$> loop [] where
    loop bx = get >>= \b -> get >>= \cksum ->
      if trimmedHashVerify b (setTrimmedHashLength (Z.length b) cksum)
        then loop (bx++[b])
        else fail "bad checksum"

-- | If the type signature in the given 'Dao.String.UStr' already has an associated type ID in the
-- encoder table, the existing ID is returned rather than creating a new one, and nothing changes.
-- If a new ID is created, the 'Dao.String.UStr' is paired with the new ID and written to the byte
-- stream.
newInStreamID :: HasCoderTable mtab => Name -> GPutM mtab InStreamID
newInStreamID typ = S.get >>= \st -> let idx = encodeIndex st in case M.lookup typ idx of
  Nothing  -> do
    let nextID = indexCounter st + 1
    S.put $ st{indexCounter=nextID, encodeIndex=M.insert typ nextID idx}
    put $ InStreamIndex{inStreamIndexID=nextID, inStreamIndexLabel=typ}
    return nextID
  Just tid -> return tid

-- | When decoding a byte stream, it is up to you to check for the 'InStreamIndex'ies that are
-- scattered throughout. To do this, 'newInStreamID' is only called after a special escape byte
-- prefix is seen, for example, the byte prefix used when the 'Dao.Interpreter.OHaskell' constructor is
-- to be encoded. Once this prefix is decoded you should call 'newInStreamID'. That way, when you
-- are decoding the byte stream, you will know that 'updateTypes' must be called whenever you decode
-- the byte prefix for 'Dao.Interpreter.OHaskell'.
-- 
-- This function simply checks if a 'InStreamIndex' exists at the current location in the byte
-- stream. If it does not exist, this function simply returns and does nothing. If it does exist,
-- the data is pulled out of the stream and the index is updated.
updateTypes :: HasCoderTable mtab => GGet mtab ()
updateTypes = tryWord8 0x01 $ do
  (InStreamIndex tid label) <- get
  S.modify $ \st -> st{decodeIndex = M.insert tid label (decodeIndex st)}

runPut :: HasCoderTable mtab => mtab -> GPut mtab -> Z.ByteString
runPut mtab fn = B.runPut $ S.evalStateT (encoderToStateT fn) $
  EncodeIndex{indexCounter=1, encodeIndex=mempty, encMTabRef=mtab}

runGet :: HasCoderTable mtab => mtab -> GGet mtab a -> Z.ByteString -> Predicate GGetErr a
runGet mtab fn = B.runGet $ S.evalStateT (runPredicateT $ decoderToStateT fn) $
  DecodeIndex{decodeIndex=mempty, decMTabRef=mtab}

encode :: (HasCoderTable mtab, Binary a mtab) => mtab -> a -> Z.ByteString
encode mtab = runPut mtab . put

decode :: (HasCoderTable mtab, Binary a mtab) => mtab -> Z.ByteString -> Predicate GGetErr a
decode mtab = runGet mtab get

encodeFile :: (HasCoderTable mtab, Binary a mtab) => mtab -> FilePath -> a -> IO ()
encodeFile mtab path = Z.writeFile path . encode mtab

decodeFile :: (HasCoderTable mtab, Binary a mtab) => mtab -> FilePath -> IO (Predicate GGetErr a)
decodeFile mtab path = decode mtab <$> Z.readFile path

putWithBlockStream1M :: HasCoderTable mtab => GPut mtab -> GPut mtab
putWithBlockStream1M fn = getCoderTable >>= \mtab -> put $ BlockStream1M $ runPut mtab fn

getWithBlockStream1M :: HasCoderTable mtab => GGet mtab a -> GGet mtab a
getWithBlockStream1M fn = do
  mtab <- getCoderTable
  (BlockStream1M bs1m) <- get
  Get (predicate (runGet mtab fn bs1m))

----------------------------------------------------------------------------------------------------

class (Ix i, Binary i mtab, Binary a mtab) => HasPrefixTable a i mtab where { prefixTable :: PrefixTable mtab i a }

-- | For data types with many constructors, especially enumerated types, it is effiecient if your
-- decoder performs a single look-ahead to retrieve an index, then use the index to lookup the next
-- parser in a table. This is a lookup table using 'Data.Array.IArray.Array' as the table which does
-- exactly that.
data PrefixTable mtab i a = PrefixTable String (Maybe (GGet mtab i)) (Maybe (Array i (GGet mtab a)))

instance Ix i => Functor (PrefixTable mtab i) where
  fmap f (PrefixTable msg getIdx t) = PrefixTable msg getIdx (fmap (amap (fmap f)) t)
instance (Integral i, Show i, Ix i, Binary a mtab) => Monoid (PrefixTable mtab i a) where
  mempty = PrefixTable "" Nothing Nothing
  mappend (PrefixTable msgA getIdxA a) (PrefixTable msgB getIdxB b) =
    PrefixTable (msgA<>"<>"<>msgB) (msum [getIdxA >> getIdxB, getIdxB, getIdxA]) $ msum $
      [ a >>= \a -> b >>= \b -> do
          let ((loA, hiA), (loB, hiB)) = (bounds    a, bounds    b)
          let ( lo       ,  hi       ) = (min loA loB, max hiA hiB)
          Just $ accumArray (flip mplus) mzero (lo, hi) (assocs a ++ assocs b)
      , a, b
      ]

-- | For each 'GGet' function stored in the 'PrefixTable', bind it to the function provided here and
-- store the bound functions back into the table. It works similar to the 'Control.Monad.>>='
-- function.
bindPrefixTable :: Ix i => PrefixTable mtab i a -> (a -> GGet mtab b) -> PrefixTable mtab i b
bindPrefixTable (PrefixTable msg getIdx arr) fn = PrefixTable msg getIdx (fmap (amap (>>=fn)) arr)

-- | Construct a 'Serializer' from a list of serializers, and each list item will be prefixed with a
-- byte in the range given. It is necesary for the data type to instantiate 'Data.Typeable.Typeable'
-- in order to 
mkPrefixTable
  :: (Integral i, Show i, Ix i, Num i)
  => String -> GGet mtab i -> i -> i -> [GGet mtab a] -> PrefixTable mtab i a
mkPrefixTable msg getIdx lo' hi' ser =
  let len   = fromIntegral (length ser)
      lo    = min lo' hi'
      hi    = max lo' hi'
      idxs  = takeWhile (<=hi) (iterate (+1) lo)
      table = PrefixTable msg (Just getIdx) $ Just $
        accumArray (flip const) (fail ("in "++msg++" table")) (lo, hi) (zip idxs ser)
  in  if null ser
      then PrefixTable msg (Just getIdx) Nothing
      else
        if 0<len && len<=hi-lo+1
        then table
        else error ("too many prefix table items for mkPrefixTable for "++msg)

mkPrefixTableWord8 :: String -> Byte -> Byte -> [GGet mtab a] -> PrefixTable mtab Byte a
mkPrefixTableWord8 msg = mkPrefixTable msg getWord8

runPrefixTable :: (Integral i, Show i, Ix i, Binary i mtab) => PrefixTable mtab i a -> GGet mtab a
runPrefixTable (PrefixTable _msg getIdx t) = flip (maybe mzero) t $ \decoderArray -> do
  prefix <- lookAhead (maybe get id getIdx)
  guard $ inRange (bounds decoderArray) prefix
  prefix <- maybe get id getIdx
  decoderArray!prefix

word8PrefixTable :: HasPrefixTable a Byte mtab => GGet mtab a
word8PrefixTable = runPrefixTable (prefixTable :: HasPrefixTable a Byte mtab => PrefixTable mtab Byte a)

prefixByte :: Byte -> GPut mtab -> GPut mtab
prefixByte w fn = putWord8 w >> fn

-- | This is a polymorphic object that has been constructed using the instances of the canonical
-- 'Data.Binary.Binary'. This makes it possible to write your binary instances like so:
-- > import Data.Binary
-- > import Dao.Binary
-- > import MyObject -- exports data type MyObject which instantiates the canonical 'Data.Binary.Binary'.
-- > instance Dao.Binary.Binary MyObject where { serializer = fromDataBinary }
--
-- I cannot just use GHC's @UndecidableInstances@ feature to declare all type which instantiate the
-- canonical 'Data.Binary.Binary' to also instantiate my own 'Dao.Binary.Binary' because
-- I need my own versions of 'Data.Binary.get' and 'Data.Binary.put' for certain types like
-- 'Data.Maybe' and list types. So unfortunately, we are stuck declaring a new instance for every
-- data type that needs serialization.
fromDataBinary :: B.Binary a => Serializer mtab a
fromDataBinary =
  Serializer
  { serializeGet = dataBinaryGet B.get
  , serializePut = dataBinaryPut . B.put
  }

dataBinaryPut :: B.PutM a -> GPutM mtab a
dataBinaryPut = PutM . lift

dataBinaryGet :: B.Get a -> GGet mtab a
dataBinaryGet = Get . lift . lift

lookAhead :: GGet mtab a -> GGet mtab a
lookAhead (Get fn) = S.get >>= Get . lift . lift . B.lookAhead . S.evalStateT (runPredicateT fn) >>= Get . predicate

bytesRead :: GGet mtab ByteOffset
bytesRead = Get $ lift $ lift B.bytesRead

isEmpty :: GGet mtab Bool
isEmpty = dataBinaryGet B.isEmpty

putWord8 :: Word8 -> GPut mtab
putWord8    = PutM . lift . B.putWord8

putWord16be :: Word16 -> GPut mtab
putWord16be = PutM . lift . B.putWord16be

putWord16le :: Word16 -> GPut mtab
putWord16le = PutM . lift . B.putWord16le

putWord32be :: Word32 -> GPut mtab
putWord32be = PutM . lift . B.putWord32be

putWord32le :: Word32 -> GPut mtab
putWord32le = PutM . lift . B.putWord32le

putWord64be :: Word64 -> GPut mtab
putWord64be = PutM . lift . B.putWord64be

putWord64le :: Word64 -> GPut mtab
putWord64le = PutM . lift . B.putWord64le

getWord8 :: GGet mtab Word8
getWord8    = Get $ lift $ lift $ B.getWord8

getWord16be :: GGet mtab Word16
getWord16be = Get $ lift $ lift $ B.getWord16be

getWord16le :: GGet mtab Word16
getWord16le = Get $ lift $ lift $ B.getWord16le

getWord32be :: GGet mtab Word32
getWord32be = Get $ lift $ lift $ B.getWord32be

getWord32le :: GGet mtab Word32
getWord32le = Get $ lift $ lift $ B.getWord32le

getWord64be :: GGet mtab Word64
getWord64be = Get $ lift $ lift $ B.getWord64be

getWord64le :: GGet mtab Word64
getWord64le = Get $ lift $ lift $ B.getWord64le

putIntegral :: (Integral a, Bits a) => a -> GPut mtab
putIntegral = putInteger . fromIntegral

getIntegral :: (Integral a, Bits a) => GGet mtab a
getIntegral = fromIntegral <$> getInteger

putPosIntegral :: (Integral a, Bits a) => a -> GPut mtab
putPosIntegral = putPosInteger . fromIntegral

getPosIntegral :: (Integral a, Bits a) => GGet mtab a
getPosIntegral = fromIntegral <$> getPosInteger

putInteger :: Integer -> GPut mtab
putInteger = dataBinaryPut . vlPutInteger

getInteger :: GGet mtab Integer
getInteger = fmap fromIntegral $ dataBinaryGet vlGetInteger

putPosInteger :: Integer -> GPut mtab
putPosInteger = dataBinaryPut . vlPutPosInteger

getPosInteger :: GGet mtab Integer
getPosInteger = dataBinaryGet vlGetPosInteger

putByteString :: B.ByteString -> GPut mtab
putByteString = dataBinaryPut . B.putByteString

getByteString :: Int -> GGet mtab B.ByteString
getByteString = dataBinaryGet . B.getByteString

putLazyByteString :: Z.ByteString -> GPut mtab
putLazyByteString = dataBinaryPut . B.putLazyByteString

getLazyByteString :: Int64 -> GGet mtab Z.ByteString
getLazyByteString = dataBinaryGet . B.getLazyByteString

-- | Look ahead one byte, if the byte is the number you are expecting drop the byte and evaluate the
-- given 'GGet' function, otherwise backtrack.
tryWord8 :: Word8 -> GGet mtab a -> GGet mtab a
tryWord8 w fn = lookAhead getWord8 >>= guard . (w==) >> getWord8 >> fn

instance Binary Int8   mtab  where
  put = putWord8 . fromIntegral
  get = fmap fromIntegral getWord8
instance Binary Int16  mtab  where { put = putIntegral;    get = Dao.Binary.getIntegral    }
instance Binary Int32  mtab  where { put = putIntegral;    get = Dao.Binary.getIntegral    }
instance Binary Int64  mtab  where { put = putIntegral;    get = Dao.Binary.getIntegral    }
instance Binary Int    mtab  where { put = putIntegral;    get = Dao.Binary.getIntegral    }
instance Binary Word8  mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }
instance Binary Word16 mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }
instance Binary Word32 mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }
instance Binary Word64 mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }
instance Binary Word   mtab  where { put = putPosIntegral; get = Dao.Binary.getPosIntegral }
instance Binary Float  mtab  where
  put = dataBinaryPut . B.putFloat32be
  get = dataBinaryGet B.getFloat32be
instance Binary Double mtab  where
  put = dataBinaryPut . B.putFloat64be
  get = dataBinaryGet B.getFloat64be
instance (RealFloat a, Binary a mtab) => Binary (Complex a) mtab where
  put (a :+ b) = put a >> put b
  get = pure (:+) <*> get <*> get

instance (Num a, Bits a, Integral a, Binary a mtab) => Binary (Ratio a) mtab where
  put o = putIntegral (numerator o) >> putPosIntegral (denominator o)
  get = pure (%) <*> getIntegral <*> getPosIntegral

instance Binary Integer mtab where { put = putInteger; get = getInteger; }
instance Binary Char    mtab where { put = putPosIntegral . ord; get = chr <$> getPosIntegral; }

instance Binary UTCTime mtab where
  put t = do
    put (toModifiedJulianDay (utctDay t))
    put (toRational (utctDayTime t))
  get = do
    d <- fmap ModifiedJulianDay get
    t <- fmap fromRational get
    return (UTCTime{ utctDay=d, utctDayTime=t })

instance Binary NominalDiffTime mtab where
  put t = put (toRational t)
  get = fmap fromRational get

instance Binary B.ByteString mtab where
  put o = putPosIntegral (B.length o) >> Dao.Binary.putByteString o
  get = getPosIntegral >>= Dao.Binary.getByteString

instance Binary Z.ByteString mtab where
  put o = putPosIntegral (Z.length o) >> Dao.Binary.putLazyByteString o
  get = getPosIntegral >>= Dao.Binary.getLazyByteString

instance (Binary a t, Binary b t) => Binary (a, b) t where
  put (a, b) = put a >> put b
  get = pure (,) <*> get <*> get
instance (Binary a t, Binary b t, Binary c t) => Binary (a, b, c) t where
  put (a, b, c) = put a >> put b >> put c
  get = pure (,,) <*> get <*> get <*> get
instance (Binary a t, Binary b t, Binary c t, Binary d t) => Binary (a, b, c, d) t where
  put (a, b, c, d) = put a >> put b >> put c >> put d
  get = pure (,,,) <*> get <*> get <*> get <*> get
instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t) => Binary (a, b, c, d, e) t where
  put (a, b, c, d, e) = put a >> put b >> put c >> put d >> put e
  get = pure (,,,,) <*> get <*> get <*> get <*> get <*> get
instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t) => Binary (a, b, c, d, e, f) t where
  put (a, b, c, d, e, f) = put a >> put b >> put c >> put d >> put e >> put f
  get = pure (,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get
instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t, Binary g t) => Binary (a, b, c, d, e, f, g) t where
  put (a, b, c, d, e, f, g) = put a >> put b >> put c >> put d >> put e >> put f >> put g
  get = pure (,,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get <*> get
instance (Binary a t, Binary b t, Binary c t, Binary d t, Binary e t, Binary f t, Binary g t, Binary h t) => Binary (a, b, c, d, e, f, g, h) t where
  put (a, b, c, d, e, f, g, h) = put a >> put b >> put c >> put d >> put e >> put f >> put g >> put h
  get = pure (,,,,,,,) <*> get <*> get <*> get <*> get <*> get <*> get <*> get <*> get

instance (Ord i, Binary i mtab, Binary a mtab) => Binary (M.Map   i a) mtab where { put = put . M.assocs ; get = M.fromList  <$> get; }
instance (                      Binary a mtab) => Binary (Im.IntMap a) mtab where { put = put . Im.assocs; get = Im.fromList <$> get; }
instance (Ord a,                Binary a mtab) => Binary (S.Set     a) mtab where { put = put . S.elems  ; get = S.fromList  <$> get; }
instance                                          Binary (Is.IntSet  ) mtab where { put = put . Is.elems ; get = Is.fromList <$> get; }

instance (Eq p, Ord p, Binary p mtab, Binary a mtab) => Binary (T.Tree p a) mtab where
  put t = case t of
    T.Void           -> prefixByte 0x00 $ return ()
    T.Leaf       a   -> prefixByte 0x01 $ put a
    T.Branch       t -> prefixByte 0x02 $ put t
    T.LeafBranch a t -> prefixByte 0x03 $ put a >> put t where
  get = word8PrefixTable

instance (Eq p, Ord p, Binary p mtab, Binary a mtab) => HasPrefixTable (T.Tree p a) Byte mtab where
  prefixTable = mkPrefixTableWord8 "Tree" 0x00 0x03 $
    [ return T.Void
    , T.Leaf   <$> get
    , T.Branch <$> get
    , pure T.LeafBranch <*> get <*> get
    ]

instance Binary () mtab where { get = return (); put () = return (); }

putNullTerm :: GPut mtab
putNullTerm = putWord8 0x00

getNullTerm :: GGet mtab ()
getNullTerm = tryWord8 0x00 $ return ()

instance Binary Bool mtab where
  put o = putWord8 (if o then 0x04 else 0x05)
  get   = word8PrefixTable
instance HasPrefixTable Bool Byte mtab where
  prefixTable = mkPrefixTableWord8 "Bool" 0x04 0x05 [return False, return True]

instance Binary a mtab => Binary (Maybe a) mtab where
  put = maybe (putWord8 0x00) (\o -> putWord8 0x01 >> put o) 
  get = word8PrefixTable <|> fail "expecting Data.Maybe.Maybe"
instance Binary a mtab => HasPrefixTable (Maybe a) Byte mtab where
  prefixTable = mkPrefixTableWord8 "Maybe" 0x00 0x01 [return Nothing, Just <$> get]

instance Binary a mtab => Binary [a] mtab where
  put o = mapM_ (put . Just) o >> putNullTerm
  get   = concatMap (maybe [] return) <$> loop [] where
    loop ox = msum $
      [ getNullTerm >> return ox
        -- It is important to check for the null terminator first, then try to parse, that way the
        -- parser dose not backtrack (which may cause it to fail) if we are at a null terminator.
      , optional get >>= maybe (fail "expecting list element") (loop . (ox++) . (:[]))
      ]

-- | Like 'putUnwrapped' but takes an arbitrary binary encoder for encoding individual list
-- parameters.
putUnwrappedWith :: (a -> GPut mtab) -> [a] -> GPut mtab
putUnwrappedWith put list = mapM_ put list >> putNullTerm

-- | The inverse of 'getUnwrapped', this function is simply defined as:
-- > \list -> 'Control.Monad.mapM_' 'put' list >> 'putNullterm'
-- This is useful when you want to place a list of items, but you dont want to waste space on a
-- prefix byte for each list element. In lists of millions of elements, this can save you megabytes
-- of space, but placing any elements which are prefixed with a null byte will result in undefined
-- behavior when decoding.
putUnwrapped :: Binary a mtab => [a] -> GPut mtab
putUnwrapped = putUnwrappedWith put

-- | Like 'getUnwrapped' but takes an arbitrary binary decoder for encoding individual list
-- parameters.
getUnwrappedWith :: GGet mtab a -> GGet mtab [a]
getUnwrappedWith get = fix (\loop ox -> (getNullTerm >> return ox) <|> (get >>= \o -> loop (ox++[o]))) []

-- | The inverse of 'putUnwrapped', this function is simply defined as: 'Control.Applicative.many'
-- 'get' >>= \list -> 'getNullTerm' >> 'Control.Monad.return' list This assumes that
-- every element placed by 'get' has a non-null prefixed encoding. If any elements in the list might
-- be encoded such that they start with a 0x00 byte, the @'Control.Applicative.many'@ 'get'
-- expression will parse the null terminator of the list as though it were an element and continue
-- looping which results in undefined behavior. Examples of elements that may start with null @0x00@
-- bytes are 'Dao.String.UStr', 'Dao.String.Name', 'Prelude.Integer', or any 'Prelude.Integral' type.
getUnwrapped :: Binary a mtab => GGet mtab [a]
getUnwrapped = getUnwrappedWith get

instance Binary UStr mtab where
  put o = dataBinaryPut (B.put o)
  get = dataBinaryGet B.get

instance Binary Name mtab where
  put o = dataBinaryPut (B.put o)
  get = dataBinaryGet B.get

instance Binary Location mtab where
  put o = case o of
    LocationUnknown  -> return ()
    Location a b c d -> prefixByte 0x7F $ put a >> put b >> put c >> put d
  get = msum $
    [ isEmpty >>= guard >> return LocationUnknown
    , tryWord8 0x7F $ pure Location <*> get <*> get <*> get <*> get
    , return LocationUnknown
    ]