massiv-persist (empty) → 0.1.0.0
raw patch · 11 files changed
+555/−0 lines, 11 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, deepseq, doctest, hspec, massiv, massiv-persist, massiv-test, persist, primitive
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +6/−0
- Setup.hs +6/−0
- massiv-persist.cabal +78/−0
- src/Massiv/Persist.hs +258/−0
- tests/Common.hs +6/−0
- tests/Main.hs +11/−0
- tests/Spec.hs +1/−0
- tests/Test/Massiv/PersistSpec.hs +137/−0
- tests/doctests.hs +17/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog for `massiv-persist`++## 0.1.0.0++* Initial release
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,6 @@+import Distribution.Simple++main :: IO ()+main = defaultMain+#endif+
+ massiv-persist.cabal view
@@ -0,0 +1,78 @@+name: massiv-persist+version: 0.1.0.0+synopsis: Compatibility of 'massiv' with 'persist'+description: Orphan 'Persist' class instances from <https://hackage.haskell.org/package/persist persist> package that allow serialization of arrays defined in <https://hackage.haskell.org/package/massiv massiv> 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
+ src/Massiv/Persist.hs view
@@ -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 <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. 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
+ tests/Common.hs view
@@ -0,0 +1,6 @@+module Common+ ( module X+ ) where++import Test.Hspec as X+import Test.QuickCheck as X
+ tests/Main.hs view
@@ -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
+ tests/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --no-main #-}
+ tests/Test/Massiv/PersistSpec.hs view
@@ -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
+ tests/doctests.hs view
@@ -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