{-# OPTIONS_GHC -fno-warn-orphans #-}
--------------------------------------------------------------------
-- |
-- Module    : Data.Vector.Binary
-- Copyright : (c) Don Stewart 2010-2012

-- License   : BSD3
--
-- Maintainer: Don Stewart <dons00@gmail.com>
-- Stability : provisional
-- Portability: GHC only

-- Instances for Binary for the types defined in the vector package,
-- making it easy to serialize vectors to and from disk. We use the
-- generic interface to vectors, so all vector types are supported.
--
-- All functions in this module use same data format. Different
-- representations for vector length and its elements could be used
-- but general shape is same.
--
-- > [number of elements]
-- > [vector element    ] : N times
--
-- To serialize a vector:
--
-- > *Data.Vector.Binary> let v = Data.Vector.fromList [1..10]
-- > *Data.Vector.Binary> v
-- > fromList [1,2,3,4,5,6,7,8,9,10] :: Data.Vector.Vector
-- > *Data.Vector.Binary> encode v
-- > Chunk "\NUL\NUL\NUL\NUL\NUL...\NUL\NUL\NUL\t\NUL\NUL\NUL\NUL\n" Empty
--
-- Which you can in turn compress before writing to disk:
--
-- > compress . encode $ v
-- > Chunk "\US\139\b\NUL\NUL\N...\229\240,\254:\NUL\NUL\NUL" Empty
--
--------------------------------------------------------------------
module Data.Vector.Binary (
    genericGetVector
  , genericGetVectorWith
  , genericPutVector
  , genericPutVectorWith
  ) where

import Data.Binary

import qualified Data.Vector.Generic   as G
import qualified Data.Vector.Generic.Mutable as GM
import qualified Data.Vector.Unboxed   as U
import qualified Data.Vector.Storable  as S
import qualified Data.Vector.Primitive as P
import Data.Vector (Vector)
import System.IO.Unsafe

import Foreign.Storable (Storable)

-- Enumerate the instances to avoid the nasty overlapping instances.

-- | Boxed, generic vectors.
instance Binary a => Binary (Vector a) where
    put :: Vector a -> Put
put = Vector a -> Put
forall (v :: * -> *) a. (Vector v a, Binary a) => v a -> Put
genericPutVector
    get :: Get (Vector a)
get = Get (Vector a)
forall (v :: * -> *) a. (Vector v a, Binary a) => Get (v a)
genericGetVector
    {-# INLINE get #-}

-- | Unboxed vectors
instance (U.Unbox a, Binary a) => Binary (U.Vector a) where
    put :: Vector a -> Put
put = Vector a -> Put
forall (v :: * -> *) a. (Vector v a, Binary a) => v a -> Put
genericPutVector
    get :: Get (Vector a)
get = Get (Vector a)
forall (v :: * -> *) a. (Vector v a, Binary a) => Get (v a)
genericGetVector
    {-# INLINE get #-}

-- | Primitive vectors
instance (P.Prim a, Binary a) => Binary (P.Vector a) where
    put :: Vector a -> Put
put = Vector a -> Put
forall (v :: * -> *) a. (Vector v a, Binary a) => v a -> Put
genericPutVector
    get :: Get (Vector a)
get = Get (Vector a)
forall (v :: * -> *) a. (Vector v a, Binary a) => Get (v a)
genericGetVector
    {-# INLINE get #-}

-- | Storable vectors
instance (Storable a, Binary a) => Binary (S.Vector a) where
    put :: Vector a -> Put
put = Vector a -> Put
forall (v :: * -> *) a. (Vector v a, Binary a) => v a -> Put
genericPutVector
    get :: Get (Vector a)
get = Get (Vector a)
forall (v :: * -> *) a. (Vector v a, Binary a) => Get (v a)
genericGetVector
    {-# INLINE get #-}

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

-- | Deserialize vector using custom parsers.
genericGetVectorWith :: G.Vector v a
    => Get Int       -- ^ Parser for vector size
    -> Get a         -- ^ Parser for vector's element
    -> Get (v a)
{-# INLINE genericGetVectorWith #-}
genericGetVectorWith :: Get Int -> Get a -> Get (v a)
genericGetVectorWith Get Int
getN Get a
getA = do
    Int
n <- Get Int
getN
    Mutable v RealWorld a
v <- Mutable v RealWorld a -> Get (Mutable v RealWorld a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Mutable v RealWorld a -> Get (Mutable v RealWorld a))
-> Mutable v RealWorld a -> Get (Mutable v RealWorld a)
forall a b. (a -> b) -> a -> b
$ IO (Mutable v RealWorld a) -> Mutable v RealWorld a
forall a. IO a -> a
unsafePerformIO (IO (Mutable v RealWorld a) -> Mutable v RealWorld a)
-> IO (Mutable v RealWorld a) -> Mutable v RealWorld a
forall a b. (a -> b) -> a -> b
$ Int -> IO (Mutable v (PrimState IO) a)
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
Int -> m (v (PrimState m) a)
GM.unsafeNew Int
n
    let go :: Int -> Get ()
go Int
0 = () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        go Int
i = do a
x <- Get a
getA
                  () <- () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return (() -> Get ()) -> () -> Get ()
forall a b. (a -> b) -> a -> b
$ IO () -> ()
forall a. IO a -> a
unsafePerformIO (IO () -> ()) -> IO () -> ()
forall a b. (a -> b) -> a -> b
$ Mutable v (PrimState IO) a -> Int -> a -> IO ()
forall (m :: * -> *) (v :: * -> * -> *) a.
(PrimMonad m, MVector v a) =>
v (PrimState m) a -> Int -> a -> m ()
GM.unsafeWrite Mutable v RealWorld a
Mutable v (PrimState IO) a
v (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
i) a
x
                  Int -> Get ()
go (Int
iInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1)
    () <- Int -> Get ()
go Int
n
    v a -> Get (v a)
forall (m :: * -> *) a. Monad m => a -> m a
return (v a -> Get (v a)) -> v a -> Get (v a)
forall a b. (a -> b) -> a -> b
$ IO (v a) -> v a
forall a. IO a -> a
unsafePerformIO (IO (v a) -> v a) -> IO (v a) -> v a
forall a b. (a -> b) -> a -> b
$ Mutable v (PrimState IO) a -> IO (v a)
forall (m :: * -> *) (v :: * -> *) a.
(PrimMonad m, Vector v a) =>
Mutable v (PrimState m) a -> m (v a)
G.unsafeFreeze Mutable v RealWorld a
Mutable v (PrimState IO) a
v

-- | Generic put for anything in the G.Vector class which uses custom
--   encoders.
genericPutVectorWith :: G.Vector v a
    => (Int -> Put)  -- ^ Encoder for vector size
    -> (a   -> Put)  -- ^ Encoder for vector's element
    -> v a -> Put
{-# INLINE genericPutVectorWith #-}
genericPutVectorWith :: (Int -> Put) -> (a -> Put) -> v a -> Put
genericPutVectorWith Int -> Put
putN a -> Put
putA v a
v = do
    Int -> Put
putN (v a -> Int
forall (v :: * -> *) a. Vector v a => v a -> Int
G.length v a
v)
    (a -> Put) -> v a -> Put
forall (m :: * -> *) (v :: * -> *) a b.
(Monad m, Vector v a) =>
(a -> m b) -> v a -> m ()
G.mapM_ a -> Put
putA v a
v

-- | Generic function for vector deserialization.
genericGetVector :: (G.Vector v a, Binary a) => Get (v a)
{-# INLINE genericGetVector #-}
genericGetVector :: Get (v a)
genericGetVector = Get Int -> Get a -> Get (v a)
forall (v :: * -> *) a. Vector v a => Get Int -> Get a -> Get (v a)
genericGetVectorWith Get Int
forall t. Binary t => Get t
get Get a
forall t. Binary t => Get t
get

-- | Generic put for anything in the G.Vector class.
genericPutVector :: (G.Vector v a, Binary a) => v a -> Put
{-# INLINE genericPutVector #-}
genericPutVector :: v a -> Put
genericPutVector = (Int -> Put) -> (a -> Put) -> v a -> Put
forall (v :: * -> *) a.
Vector v a =>
(Int -> Put) -> (a -> Put) -> v a -> Put
genericPutVectorWith Int -> Put
forall t. Binary t => t -> Put
put a -> Put
forall t. Binary t => t -> Put
put