Persist.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Module      : Massiv.Persist
-- Copyright   : (c) Alexey Kuleshevich 2021
-- License     : BSD3
-- Maintainer  : Alexey Kuleshevich <alexey@kuleshevi.ch>
-- Stability   : experimental
-- Portability : non-portable
--
-- This package provides instances for `Persist` class for all mutable `Array`
-- representations in [@massiv@](https://hackage.haskell.org/package/massiv) package. These
-- instances are provided as orphans from a separate package in order to avoid direct
-- dependency on [@persist@](https://hackage.haskell.org/package/persist) package in
-- @massiv@.
--
-- Array elements are serialized in little endian order, which is consistent with the rest
-- of the instances in @persist@ package.
--
-- Below is a simple example how to use it. Note a blank module import: @import
-- Massiv.Persist ()@, which is the only thing needed from this module in order to use
-- provided orphan instances.
--
-- >>> import Massiv.Persist ()
-- >>> import Data.Massiv.Array as A
-- >>> import Data.Int (Int8)
-- >>> let arr = A.fromList A.Seq [72,97,115,107,101,108,108] :: A.Vector A.P Int8
-- >>> encode arr
-- "\NUL\a\NUL\NUL\NUL\NUL\NUL\NUL\NULHaskell"
-- >>> Right arr' = decode (encode arr) :: Either String (A.Vector A.P Int8)
-- >>> arr'
-- Array P Seq (Sz1 7)
--   [ 72, 97, 115, 107, 101, 108, 108 ]
--
module Massiv.Persist
  ( -- * Helper functions used to define Persist instances
    putIx
  , getIx
  , mkSzFail
  , putArray
  , getArray
  , putPrimArray
  , getPrimArray
  , putStorableArray
  , getStorableArray
  ) where

import Control.DeepSeq (NFData)
import Control.Monad
import qualified Control.Monad.Fail as Fail
import qualified Data.ByteString.Internal as BS
import qualified Data.ByteString.Short.Internal as SBS
import Data.Foldable as F
import Data.Massiv.Array as A
import Data.Massiv.Array.Unsafe
import Data.Persist
import Data.Persist.Internal
import qualified Data.Primitive as Primitive
import qualified Data.Primitive.ByteArray as BA
import Data.Proxy
import Data.Word
import Foreign.Ptr
import Foreign.ForeignPtr
import qualified Foreign.Storable as Storable

#include "MachDeps.h"

instance Persist Comp where
  put comp =
    case comp of
      Seq      -> put (0 :: Word8)
      ParOn xs -> put (1 :: Word8) >> put xs
      ParN n   -> put (2 :: Word8) >> put n
  get = do
    ty :: Word8 <- get
    case ty of
      0 -> pure Seq
      1 -> ParOn <$> get
      2 -> ParN <$> get
      n -> Fail.fail $ "Unexpected Comp tag: " <> show n



-- | Encode index
--
-- @since 0.1.0
putIx ::
     forall ix. Index ix
  => ix
  -> Put ()
putIx = foldlIndex (\ !acc i -> put i >> acc) (pure ())

-- | Decode index
--
-- @since 0.1.0
getIx ::
     forall ix. Index ix
  => Get ix
getIx = do
  let getDim ix dim = do
        i <- get
        either (Fail.fail . show) pure $! setDimM ix dim i
  F.foldlM getDim zeroIndex [1 .. dimensions (Proxy :: Proxy ix)]

instance Persist Ix2 where
  put = putIx
  get = getIx

instance Index (IxN n) => Persist (IxN n) where
  put = putIx
  get = getIx



-- | Construct size from index verifying its correctness.
--
-- @since 0.1.0
mkSzFail ::
     forall ix m. (Index ix, Fail.MonadFail m)
  => ix
  -> m (Sz ix)
mkSzFail ix = do
  let guardNegativeOverflow i !acc = do
        when (i < 0) $ Fail.fail $ "Negative size encountered: " <> show i
        let acc' = i * acc
        when (acc' /= 0 && acc' < acc) $ Fail.fail $ "Overflow detected, size is too big: " <> show i
        pure acc'
  Sz ix <$ foldlIndex (\acc i -> acc >>= guardNegativeOverflow i) (pure 1) ix

instance Index ix => Persist (Sz ix) where
  put = putIx . unSz
  get = mkSzFail =<< getIx



-- | Serialize array computation startegy and size
putArrayHeader :: forall r ix e. (Strategy r, Size r, Index ix) => Array r ix e -> Put ()
putArrayHeader arr = do
  put (getComp arr)
  put (size arr)

instance (Index ix, Persist e) => Persist (Array B ix e) where
  put = putArray
  get = getArray

instance (Index ix, Persist e) => Persist (Array BL ix e) where
  put = putArray
  get = getArray

instance (Index ix, NFData e, Persist e) => Persist (Array BN ix e) where
  put = putArray
  get = getArray

instance (Index ix, Unbox e, Persist e) => Persist (Array U ix e) where
  put = putArray
  get = getArray

-- | Serialize array as `LittleEndian`
--
-- @since 0.1.0
putArray :: (Manifest r e, Index ix, Persist e) => Array r ix e -> Put ()
putArray arr = do
  putArrayHeader arr
  A.mapM_ put arr

-- | Deserialize array from binary form in `LittleEndian`
--
-- @since 0.1.0
getArray :: (Mutable r e, Index ix, Persist e) => Get (Array r ix e)
getArray = do
  comp <- get
  sz <- get
  setComp comp <$> A.makeArrayA sz (const get)

-- | Serialize primitive array in `LittleEndian` order
--
-- @since 0.1.0
putPrimArray :: forall ix e . (Index ix, Prim e, Persist e) => Array P ix e -> Put ()
putPrimArray arr = do
#ifdef WORDS_BIGENDIAN
  putArray
#else
  putArrayHeader arr
  let eltBytes = Primitive.sizeOf (undefined :: e)
      n = totalElem (size arr) * eltBytes
      _ = put (undefined :: e) -- force `Persist` constraint
      s =
        case unwrapByteArray arr of
          BA.ByteArray ba -> SBS.SBS ba
  grow n
  Put $ \_ p -> do
    SBS.copyToPtr s (unwrapByteArrayOffset arr * eltBytes) p n
    pure $! p `plusPtr` n :!: ()
#endif

-- | Deserialize primitive array in `LittleEndian` order
--
-- @since 0.1.0
getPrimArray :: forall ix e . (Index ix, Prim e, Persist e) => Get (Array P ix e)
getPrimArray = do
#ifdef WORDS_BIGENDIAN
  getArray
#else
  comp <- get
  sz <- get
  let n = totalElem sz * Primitive.sizeOf (undefined :: e)
      _ = put (undefined :: e) -- force `Persist` constraint
  SBS.SBS sbs <- SBS.toShort <$!> getBytes n
  either (Fail.fail . show) pure $
    resizeM sz (fromByteArray comp (BA.ByteArray sbs))
#endif

instance (Index ix, Prim e, Persist e) => Persist (Array P ix e) where
  put = putPrimArray
  get = getPrimArray


-- | Serialize storable array in `LittleEndian` order
--
-- @since 0.1.0
putStorableArray :: forall ix e . (Index ix, Storable e, Persist e) => Array S ix e -> Put ()
putStorableArray arr = do
#ifdef WORDS_BIGENDIAN
  puArray
#else
  let _ = put (undefined :: e) -- force `Persist` constraint
  putArrayHeader arr
  putByteString $!
    case unsafeArrayToForeignPtr arr of
      (fp, len) ->
        BS.PS (castForeignPtr fp) 0 (len * Storable.sizeOf (undefined :: e))
#endif

-- | Deserialize storable array in `LittleEndian` order
--
-- @since 0.1.0
getStorableArray :: forall ix e . (Index ix, Storable e, Persist e) => Get (Array S ix e)
getStorableArray = do
#ifdef WORDS_BIGENDIAN
  getArray
#else
  comp <- get
  sz <- get
  let eltCount = totalElem sz
      eltBytes = Storable.sizeOf (undefined :: e)
      _ = put (undefined :: e) -- force `Persist` constraint
  BS.PS fp off _ <- getByteString (eltCount * eltBytes)
  either (Fail.fail . show) pure $
    resizeM sz $
    unsafeArrayFromForeignPtr0 comp (fp `plusForeignPtr` off) (Sz eltCount)
#endif

instance (Index ix, Storable e, Persist e) => Persist (Array S ix e) where
  put = putStorableArray
  get = getStorableArray