diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for `massiv-persist` + +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Alexey Kuleshevich (c) 2021 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Alexey Kuleshevich nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,6 @@ +# massiv-persist + +Orphan `Persist` class instances from +[persist](https://hackage.haskell.org/package/persist) package that allow +serialization of arrays defined in [`massiv`](https://hackage.haskell.org/package/massiv) +package. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,6 @@ +import Distribution.Simple + +main :: IO () +main = defaultMain +#endif + diff --git a/massiv-persist.cabal b/massiv-persist.cabal new file mode 100644 --- /dev/null +++ b/massiv-persist.cabal @@ -0,0 +1,78 @@ +name: massiv-persist +version: 0.1.0.0 +synopsis: Compatibility of 'massiv' with 'persist' +description: Orphan 'Persist' class instances from package that allow serialization of arrays defined in package +homepage: https://github.com/lehins/massiv-compat +license: BSD3 +license-file: LICENSE +author: Alexey Kuleshevich +maintainer: alexey@kuleshevi.ch +copyright: 2021 Alexey Kuleshevich +category: Array, Data Structures, Serialization +build-type: Simple +extra-source-files: README.md + , CHANGELOG.md +cabal-version: 1.18 +tested-with: GHC == 8.4.3 + , GHC == 8.4.4 + , GHC == 8.6.3 + , GHC == 8.6.4 + , GHC == 8.6.5 + , GHC == 8.8.1 + , GHC == 8.8.2 + , GHC == 8.10.1 + +library + hs-source-dirs: src + exposed-modules: Massiv.Persist + + other-modules: + build-depends: base >= 4.8 && < 5 + , bytestring + , deepseq + , massiv >= 0.5.9.0 + , persist + , primitive + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Main.hs + other-modules: Common + , Test.Massiv.PersistSpec + , Spec + build-tool-depends: hspec-discover:hspec-discover + build-depends: base >= 4.8 && < 5 + , massiv-persist + , massiv-test >= 0.1.5 + , massiv + , persist + , hspec + , QuickCheck + + default-language: Haskell2010 + ghc-options: -Wall + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wredundant-constraints + -fno-warn-orphans + -threaded + -with-rtsopts=-N2 + +test-suite doctests + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: doctests.hs + build-depends: base + , doctest >=0.15 + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/lehins/massiv-compat diff --git a/src/Massiv/Persist.hs b/src/Massiv/Persist.hs new file mode 100644 --- /dev/null +++ b/src/Massiv/Persist.hs @@ -0,0 +1,258 @@ +{-# 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 +-- 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. Manifest r ix e + => 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, NFData e, Persist e) => Persist (Array N 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 ix e, 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 ix e, 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 diff --git a/tests/Common.hs b/tests/Common.hs new file mode 100644 --- /dev/null +++ b/tests/Common.hs @@ -0,0 +1,6 @@ +module Common + ( module X + ) where + +import Test.Hspec as X +import Test.QuickCheck as X diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,11 @@ +module Main where + +import Spec +import System.IO (BufferMode (LineBuffering), hSetBuffering, hSetEncoding, stdout, utf8) +import Test.Hspec + +main :: IO () +main = do + hSetBuffering stdout LineBuffering + hSetEncoding stdout utf8 + hspec spec diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-} diff --git a/tests/Test/Massiv/PersistSpec.hs b/tests/Test/Massiv/PersistSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Massiv/PersistSpec.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Test.Massiv.PersistSpec (spec) where + +import Data.Persist +import Common +import Massiv.Persist +import Test.Massiv.Core +import Data.Massiv.Array +import Data.Word + +roundtrip :: (Eq a, Show a, Persist a) => a -> Property +roundtrip val = either error id (decode (encode val)) === val + +roundtripArray :: + forall r ix e. + ( Mutable r ix e + , Persist e + , Persist (Array r ix e) + , Eq (Array r ix e) + , Show (Array r ix e) + ) + => Array r ix e + -> Property +roundtripArray arr = expectProp $ do + let arr'' = either error id (runGet getArray (runPut (putArray arr))) + getComp arr'' `shouldBe` getComp arr + arr'' `shouldBe` arr + let arr' = either error id (decode (encode arr)) + getComp arr' `shouldBe` getComp arr + arr' `shouldBe` arr + +roundtripArraySpec :: + forall r ix e. + ( Eq (Array r ix e) + , Show (Array r ix e) + , Typeable ix + , Typeable e + , Arbitrary ix + , Mutable r ix e + , Arbitrary e + , Persist e + , Persist (Array r ix e) + ) + => Spec +roundtripArraySpec = + prop (showsType @(Array r ix e) "") $ roundtripArray @r @ix @e + +spec :: Spec +spec = do + describe "Persist" $ do + prop "Comp" $ roundtrip @Comp + describe "Ix" $ do + prop "Ix2" $ roundtrip @Ix2 + prop "Ix3" $ roundtrip @Ix3 + prop "Ix4" $ roundtrip @Ix4 + prop "Ix5" $ roundtrip @Ix5 + describe "Sz" $ do + prop "Sz1" $ roundtrip @Sz1 + prop "Sz2" $ roundtrip @Sz2 + prop "Sz3" $ roundtrip @Sz3 + prop "Sz4" $ roundtrip @Sz4 + prop "Sz5" $ roundtrip @Sz5 + describe "Array" $ do + describe "P" $ do + roundtripArraySpec @P @Ix1 @Word8 + roundtripArraySpec @P @Ix2 @Word8 + roundtripArraySpec @P @Ix3 @Word8 + roundtripArraySpec @P @Ix4 @Word8 + roundtripArraySpec @P @Ix5 @Word8 + roundtripArraySpec @P @Ix1 @Word16 + roundtripArraySpec @P @Ix2 @Word16 + roundtripArraySpec @P @Ix3 @Word16 + roundtripArraySpec @P @Ix4 @Word16 + roundtripArraySpec @P @Ix5 @Word16 + roundtripArraySpec @P @Ix1 @Word32 + roundtripArraySpec @P @Ix2 @Word32 + roundtripArraySpec @P @Ix3 @Word32 + roundtripArraySpec @P @Ix4 @Word32 + roundtripArraySpec @P @Ix5 @Word32 + roundtripArraySpec @P @Ix1 @Word64 + roundtripArraySpec @P @Ix2 @Word64 + roundtripArraySpec @P @Ix3 @Word64 + roundtripArraySpec @P @Ix4 @Word64 + roundtripArraySpec @P @Ix5 @Word64 + roundtripArraySpec @P @Ix1 @Word + roundtripArraySpec @P @Ix2 @Word + roundtripArraySpec @P @Ix3 @Word + roundtripArraySpec @P @Ix4 @Word + roundtripArraySpec @P @Ix5 @Word + describe "U" $ do + roundtripArraySpec @U @Ix1 @(Int, Word) + roundtripArraySpec @U @Ix2 @(Int, Word) + roundtripArraySpec @U @Ix3 @(Int, Word) + roundtripArraySpec @U @Ix4 @(Int, Word) + roundtripArraySpec @U @Ix5 @(Int, Word) + describe "S" $ do + roundtripArraySpec @S @Ix1 @Word8 + roundtripArraySpec @S @Ix2 @Word8 + roundtripArraySpec @S @Ix3 @Word8 + roundtripArraySpec @S @Ix4 @Word8 + roundtripArraySpec @S @Ix5 @Word8 + roundtripArraySpec @S @Ix1 @Word16 + roundtripArraySpec @S @Ix2 @Word16 + roundtripArraySpec @S @Ix3 @Word16 + roundtripArraySpec @S @Ix4 @Word16 + roundtripArraySpec @S @Ix5 @Word16 + roundtripArraySpec @S @Ix1 @Word32 + roundtripArraySpec @S @Ix2 @Word32 + roundtripArraySpec @S @Ix3 @Word32 + roundtripArraySpec @S @Ix4 @Word32 + roundtripArraySpec @S @Ix5 @Word32 + roundtripArraySpec @S @Ix1 @Word64 + roundtripArraySpec @S @Ix2 @Word64 + roundtripArraySpec @S @Ix3 @Word64 + roundtripArraySpec @S @Ix4 @Word64 + roundtripArraySpec @S @Ix5 @Word64 + roundtripArraySpec @S @Ix1 @Word + roundtripArraySpec @S @Ix2 @Word + roundtripArraySpec @S @Ix3 @Word + roundtripArraySpec @S @Ix4 @Word + roundtripArraySpec @S @Ix5 @Word + describe "B" $ do + roundtripArraySpec @B @Ix1 @Integer + roundtripArraySpec @B @Ix2 @Integer + roundtripArraySpec @B @Ix3 @Integer + roundtripArraySpec @B @Ix4 @Integer + roundtripArraySpec @B @Ix5 @Integer + describe "N" $ do + roundtripArraySpec @N @Ix1 @Integer + roundtripArraySpec @N @Ix2 @Integer + roundtripArraySpec @N @Ix3 @Integer + roundtripArraySpec @N @Ix4 @Integer + roundtripArraySpec @N @Ix5 @Integer diff --git a/tests/doctests.hs b/tests/doctests.hs new file mode 100644 --- /dev/null +++ b/tests/doctests.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE CPP #-} +module Main where + +#if __GLASGOW_HASKELL__ >= 802 && __GLASGOW_HASKELL__ != 810 + +import Test.DocTest (doctest) + +main :: IO () +main = doctest ["src"] + +#else + +-- TODO: fix doctest support +main :: IO () +main = putStrLn "\nDoctests are not supported for older ghc version\n" + +#endif