{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE UndecidableInstances #-}
--------------------------------------------------------------------
-- |
-- Module    : Data.Vector.Cereal
-- Copyright : (c) Don Stewart 2010-2012

-- License   : BSD3
--
-- Maintainer: Don Stewart <dons00@gmail.com>
-- Stability : provisional
-- Portability: GHC only
--
-- Instances for Serialize 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.
--
--------------------------------------------------------------------

module Data.Vector.Cereal () where

import Data.Serialize
import Control.Monad

import qualified Data.Vector.Generic as G
import qualified Data.Vector.Unboxed as U
import qualified Data.Vector.Storable as S
import Data.Vector (Vector)

import System.IO.Unsafe
import qualified Data.Vector.Generic.Mutable as M
import Foreign.Storable (Storable)

-- | Boxed, generic vectors.
instance Serialize a => Serialize (Vector a) where
    put = putGeneric
    get = getGeneric
    {-# INLINE get #-}

-- | Unboxed vectors
instance (U.Unbox a, Serialize a) => Serialize (U.Vector a) where
    put = putGeneric
    get = getGeneric
    {-# INLINE get #-}

-- | Storable vectors
instance (Storable a, Serialize a) => Serialize (S.Vector a) where
    put = putGeneric
    get = getGeneric
    {-# INLINE get #-}

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

-- this is morally sound, if very awkward.
-- all effects are contained, and can't escape the unsafeFreeze
getGeneric :: (G.Vector v a, Serialize a) => Get (v a)
{-# INLINE getGeneric #-}
getGeneric = do
    n  <- get

    -- new unitinialized array
    mv <- lift $ M.new n

    let fill i
            | i < n = do
                x <- get
                (unsafePerformIO $ M.unsafeWrite mv i x) `seq` return ()
                fill (i+1)

            | otherwise = return ()

    fill 0

    lift $ G.unsafeFreeze mv

-- | Generic put for anything in the G.Vector class.
putGeneric :: (G.Vector v a, Serialize a) => v a -> Put
{-# INLINE putGeneric #-}
putGeneric v = do
    put (G.length v)
    G.mapM_ put v

lift :: IO b -> Get b
lift = return .unsafePerformIO