diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog for `massiv-serialise` + +## 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-serialise + +Orphan `Serialise` class instances from +[serialise](https://hackage.haskell.org/package/serialise) 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-serialise.cabal b/massiv-serialise.cabal new file mode 100644 --- /dev/null +++ b/massiv-serialise.cabal @@ -0,0 +1,77 @@ +name: massiv-serialise +version: 0.1.0.0 +synopsis: Compatibility of 'massiv' with 'serialise' +description: Orphan 'Serialise' 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: Algorithms +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.Serialise + + other-modules: + build-depends: base >= 4.8 && < 5 + , deepseq + , massiv >= 0.5.0.0 + , serialise >= 0.2.0.0 + , vector + + 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.SerialiseSpec + , Spec + build-tool-depends: hspec-discover:hspec-discover + build-depends: base >= 4.8 && < 5 + , massiv-serialise + , massiv-test + , massiv + , serialise + , 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/Serialise.hs b/src/Massiv/Serialise.hs new file mode 100644 --- /dev/null +++ b/src/Massiv/Serialise.hs @@ -0,0 +1,190 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Massiv.Serialise +-- Copyright : (c) Alexey Kuleshevich 2021 +-- License : BSD3 +-- Maintainer : Alexey Kuleshevich +-- Stability : experimental +-- Portability : non-portable +-- +-- This package provides instances for `Serialise` 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 [@serialise@](https://hackage.haskell.org/package/serialise) package in +-- @massiv@. +-- +-- Array serialisation is done by falling back onto instances for `VG.Vector` types from +-- [@vector@](https://hackage.haskell.org/package/vector) package. +-- +-- Below is a simple example how to use it. Note a blank module import: @import +-- Massiv.Serialise ()@, which is the only thing needed from this module in order to use +-- provided orphan instances. +-- +-- >>> import Massiv.Serialise () +-- >>> import Data.Massiv.Array as A +-- >>> let arr = A.fromList A.Seq [72,97,115,107,101,108,108] :: A.Vector A.P Int +-- >>> serialise arr +-- "\NUL\a\135\CANH\CANa\CANs\CANk\CANe\CANl\CANl" +-- >>> deserialise (serialise arr) :: A.Vector A.P Int +-- Array P Seq (Sz1 7) +-- [ 72, 97, 115, 107, 101, 108, 108 ] +-- +module Massiv.Serialise + ( -- * Helper functions used to define Serialise instances + encodeIx + , decodeIx + , mkSzFail + , encodeArray + , decodeArray + ) where + +import Codec.Serialise +import Codec.Serialise.Decoding +import Codec.Serialise.Encoding +import Control.DeepSeq (NFData) +import Control.Monad +import qualified Control.Monad.Fail as Fail +import Data.Foldable as F +import Data.Massiv.Array +import Data.Massiv.Array.Manifest.Vector +import Data.Proxy +import Data.Typeable +import qualified Data.Vector as V +import qualified Data.Vector.Generic as VG +import qualified Data.Vector.Primitive as VP +import qualified Data.Vector.Storable as VS +import qualified Data.Vector.Unboxed as VU + +instance Serialise Comp where + encode comp = + case comp of + Seq -> encode (0 :: Int) + ParOn xs -> encode (1 :: Int) <> encode xs + ParN n -> encode (2 :: Int) <> encode n + decode = do + ty :: Int <- decode + case ty of + 0 -> pure Seq + 1 -> ParOn <$> decode + 2 -> ParN <$> decode + n -> Fail.fail $ "Unexpected Comp tag: " <> show n + + + +-- | Encode index +-- +-- @since 0.1.0 +encodeIx :: + forall ix. Index ix + => ix + -> Encoding +encodeIx = foldlIndex (\ !acc i -> encode i <> acc) mempty + +-- | Decode index +-- +-- @since 0.1.0 +decodeIx :: + forall s ix. Index ix + => Decoder s ix +decodeIx = do + let decodeDim ix dim = do + i <- decode + either (Fail.fail . show) pure $! setDimM ix dim i + F.foldlM decodeDim zeroIndex [1 .. dimensions (Proxy :: Proxy ix)] + +instance Serialise Ix2 where + encode = encodeIx + decode = decodeIx + +instance Index (IxN n) => Serialise (IxN n) where + encode = encodeIx + decode = decodeIx + + + +-- | 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, Serialise ix) => Serialise (Sz ix) where + encode = encodeIx . unSz + decode = mkSzFail =<< decodeIx + + + +-- | Encode array by using its corresponding vector instance +-- +-- @since 0.1.0 +encodeArray :: + forall v r ix e. + ( Manifest r ix e + , Mutable (ARepr v) ix e + , VG.Vector v e + , VRepr (ARepr v) ~ v + , Serialise ix + , Serialise (v e) + ) + => Array r ix e + -> Encoding +encodeArray arr = + encode (getComp arr) <> encode (size arr) <> encode (toVector arr :: v e) + +-- | Decode array by using its corresponding vector instance +-- +-- @since 0.1.0 +decodeArray :: + forall v r ix e s. + ( Typeable v + , VG.Vector v e + , Mutable (ARepr v) ix e + , Mutable r ix e + , Serialise ix + , Serialise (v e) + ) + => Decoder s (Array r ix e) +decodeArray = do + comp <- decode + sz <- decode + vector :: v e <- decode + -- setComp is to workaround a minor bug for boxed arrays in massiv < 0.6 + either (Fail.fail . show) (pure . setComp comp) $ fromVectorM comp sz vector + +instance (Index ix, Serialise ix, Serialise e) => Serialise (Array B ix e) where + encode = encodeArray @V.Vector + decode = decodeArray @V.Vector + +instance (Index ix, NFData e, Serialise ix, Serialise e) => Serialise (Array N ix e) where + encode = encode . unwrapNormalForm + decode = evalNormalForm <$> decode + +instance (Index ix, Storable e, Serialise ix, Serialise e) => Serialise (Array S ix e) where + encode = encodeArray @VS.Vector + decode = decodeArray @VS.Vector + +instance (Index ix, Unbox e, Serialise ix, Serialise e) => Serialise (Array U ix e) where + encode = encodeArray @VU.Vector + decode = decodeArray @VU.Vector + +instance (Index ix, Prim e, Serialise ix, Serialise e) => Serialise (Array P ix e) where + encode = encodeArray @VP.Vector + decode = decodeArray @VP.Vector + 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/SerialiseSpec.hs b/tests/Test/Massiv/SerialiseSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Test/Massiv/SerialiseSpec.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Test.Massiv.SerialiseSpec (spec) where + +import Codec.Serialise +import Common +import Massiv.Serialise () +import Test.Massiv.Core +import Data.Massiv.Array +import Data.Word + +roundtrip :: (Eq a, Show a, Serialise a) => a -> Property +roundtrip val = deserialise (serialise val) === val + +roundtripArray :: + forall r ix e. + ( Load r ix e + , Serialise (Array r ix e) + , Eq (Array r ix e) + , Show (Array r ix e) + ) + => Array r ix e + -> Property +roundtripArray arr = + let arr' = deserialise (serialise arr) + in (arr' === arr) .&&. (getComp arr' === getComp arr) + +roundtripArraySpec :: + forall r ix e. + ( Eq (Array r ix e) + , Show (Array r ix e) + , Typeable ix + , Typeable e + , Arbitrary ix + , Construct r ix e + , Load r ix e + , Arbitrary e + , Serialise (Array r ix e) + ) + => Spec +roundtripArraySpec = + prop (showsType @(Array r ix e) "") $ roundtripArray @r @ix @e + +spec :: Spec +spec = do + describe "Serialise" $ 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 @Word + roundtripArraySpec @U @Ix2 @Word + roundtripArraySpec @U @Ix3 @Word + roundtripArraySpec @U @Ix4 @Word + roundtripArraySpec @U @Ix5 @Word + describe "S" $ do + 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