packages feed

cereal-plus 0.3.2 → 0.3.3

raw patch · 10 files changed

+869/−741 lines, 10 filesdep +HTFdep +HUnitdep +QuickCheck

Dependencies added: HTF, HUnit, QuickCheck, QuickCheck-GenT, cereal-plus, quickcheck-instances

Files

cereal-plus.cabal view
@@ -1,7 +1,7 @@ name:   cereal-plus version:-  0.3.2+  0.3.3 synopsis:   An extended serialization library on top of "cereal" description:@@ -42,7 +42,7 @@  library   hs-source-dirs:-    src+    library   exposed-modules:     CerealPlus.Serializable     CerealPlus.Deserialize@@ -71,35 +71,108 @@     base >= 4.5 && < 5   default-extensions:     Arrows-    DeriveGeneric-    ImpredicativeTypes     BangPatterns-    PatternGuards+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveGeneric+    EmptyDataDecls+    FlexibleContexts+    FlexibleInstances+    FunctionalDependencies     GADTs-    StandaloneDeriving+    GeneralizedNewtypeDeriving+    ImpredicativeTypes+    LambdaCase+    LiberalTypeSynonyms     MultiParamTypeClasses+    MultiWayIf+    NoImplicitPrelude+    NoMonomorphismRestriction+    OverloadedStrings+    PatternGuards+    QuasiQuotes+    RankNTypes+    RecordWildCards     ScopedTypeVariables-    FlexibleInstances+    StandaloneDeriving+    TemplateHaskell+    TupleSections     TypeFamilies     TypeOperators+  default-language:+    Haskell2010+++test-suite cereal-plus-htf-test-suite+  ghc-options:+    -threaded+    "-with-rtsopts=-N"+  type:             +    exitcode-stdio-1.0+  hs-source-dirs:   +    htf-test-suite+  main-is:          +    HTFTestSuite.hs+  build-depends:+    cereal-plus,+    -- testing:+    quickcheck-instances,+    QuickCheck-GenT == 0.1.*,+    QuickCheck,+    HUnit,+    HTF == 0.11.*,+    -- Serialization:+    cereal == 0.4.*,+    -- Concurrency:+    stm,+    -- Data:+    time,+    hashable,+    hashtables,+    unordered-containers,+    vector,+    array,+    containers,+    text,+    bytestring,+    -- Control:+    layers == 0.1.*,+    errors,+    mtl,+    base >= 4.5 && < 5+  default-extensions:+    Arrows+    BangPatterns+    ConstraintKinds+    DataKinds+    DefaultSignatures+    DeriveDataTypeable+    DeriveGeneric+    EmptyDataDecls     FlexibleContexts+    FlexibleInstances+    FunctionalDependencies+    GADTs+    GeneralizedNewtypeDeriving+    ImpredicativeTypes+    LambdaCase+    LiberalTypeSynonyms+    MultiParamTypeClasses+    MultiWayIf     NoImplicitPrelude-    EmptyDataDecls-    DataKinds     NoMonomorphismRestriction-    RankNTypes-    ConstraintKinds-    DefaultSignatures-    TupleSections     OverloadedStrings-    TemplateHaskell+    PatternGuards     QuasiQuotes-    DeriveDataTypeable-    GeneralizedNewtypeDeriving+    RankNTypes     RecordWildCards-    MultiWayIf-    LiberalTypeSynonyms-    LambdaCase+    ScopedTypeVariables+    StandaloneDeriving+    TemplateHaskell+    TupleSections+    TypeFamilies+    TypeOperators   default-language:     Haskell2010-
+ htf-test-suite/HTFTestSuite.hs view
@@ -0,0 +1,20 @@+{-# OPTIONS_GHC -F -pgmF htfpp #-}++import Test.Framework+import HTFTestSuite.Prelude+import CerealPlus.Serializable+import qualified CerealPlus.Serialize as S+import qualified CerealPlus.Deserialize as D++main = htfMain $ htf_thisModulesTests++++test_deserializeBoolOutOfRange = do+  bs <- S.exec $ serialize $ ('a')+  traceM $ show bs+  r :: D.Result IO Bool <- D.runPartial deserialize bs +  case r of+    D.Fail t bs -> assertEqual ("Out of range", "") (t, bs)+    D.Partial c -> error $ "Partial"+    D.Done r bs -> error $ "Done: " <> show r <> " " <> show bs
+ library/CerealPlus/Deserialize.hs view
@@ -0,0 +1,98 @@+-- |+-- A monad-transformer over "Data.Serialize.Get".+module CerealPlus.Deserialize+  (+    Deserialize,+    runPartial,+    Result(..),+    liftGet,+    mapBase,+    throwError,+  )+  where++import CerealPlus.Prelude+import qualified Data.Serialize.Get as Cereal+import qualified Control.Monad.Layer as Layers+++-- | A deserialization monad transformer. +newtype Deserialize m a = Deserialize { +  -- | Run on a chunk of data and get a partial result.+  runPartial :: ByteString -> m (Result m a) +}++instance (Monad m) => Monad (Deserialize m) where+  Deserialize runA >>= aToDeserializeTB = Deserialize $ \bs -> runA bs >>= aToMB where+    aToMB a = case a of+      Fail msg bs -> return $ Fail msg bs+      Partial cont -> return $ Partial $ \bs -> cont bs >>= aToMB+      Done a bs -> case aToDeserializeTB a of Deserialize runB -> runB bs+  return a = Deserialize $ \bs -> return $ Done a bs++instance MonadTrans Deserialize where+  lift m = Deserialize $ \bs -> m >>= \a -> return $ Done a bs++instance (MonadIO m) => MonadIO (Deserialize m) where+  liftIO = lift . liftIO++instance (Monad m) => Applicative (Deserialize m) where+  pure = return+  (<*>) = ap++instance (Monad m) => Functor (Deserialize m) where+  fmap = liftM++instance (Monad m) => Layers.MonadTransFunctor (Deserialize m) where+  transMap = mapBase++instance (Monad m) => Layers.MonadTrans (Deserialize m) where+  type Outer (Deserialize m) = Deserialize+  transInvmap = const . Layers.transMap++instance (Monad m) => Layers.MonadLayerFunctor (Deserialize m) where+  layerMap = Layers.transMap++instance (Monad m) => Layers.MonadLayer (Deserialize m) where+  type Inner (Deserialize m) = m+  layerInvmap = const . Layers.layerMap+  layer = lift+++-- | A partial result of deserialization.+data Result m a = +  -- | A message describing the deserialization failure and a remaining chunk.+  Fail Text ByteString |+  -- | A continuation function, which should be supplied with the next chunk.+  Partial (ByteString -> m (Result m a)) |+  -- | A deserialized data structure and a remaining chunk.+  Done a ByteString++-- | Run a `Cereal.Get` action of the \"cereal\" library.+liftGet :: Monad m => Cereal.Get a -> Deserialize m a+liftGet get = Deserialize $ \bs -> return $ convertResult $ Cereal.runGetPartial get bs +  where+    convertResult r = case r of+      Cereal.Fail m bs -> Fail (packText m) bs+      Cereal.Partial cont -> Partial $ \bs -> return $ convertResult $ cont bs+      Cereal.Done a bs -> Done a bs++-- | Change the base monad. Same as `Layers.transMap` of the \"layers\" library.+mapBase :: (Monad m, Monad m') => (forall b. m b -> m' b) -> Deserialize m a -> Deserialize m' a+mapBase mToM' = \(Deserialize runPartial) -> Deserialize $ runPartialToRunPartial' runPartial+  where+    runPartialToRunPartial' runPartial = +      mToM' . runPartial >=> \case+        Fail m bs -> return $ Fail m bs+        Partial runPartial' -> return $ Partial $ runPartialToRunPartial' runPartial'+        Done a bs -> return $ Done a bs++-- | +-- Fail with a message.+-- +-- Since there's no consensus on how to implement 'catchError' of 'MonadError', +-- we'll go with just this function.+-- +-- It is not implemented as 'fail' because 'fail' is pure evil.+throwError :: (Monad m) => Text -> Deserialize m a+throwError t = Deserialize $ \bs -> return $ Fail t bs
+ library/CerealPlus/Prelude.hs view
@@ -0,0 +1,119 @@+module CerealPlus.Prelude +  ( +    module Exports,+    LazyByteString,+    LazyText,+    PVector,+    SVector,+    UVector,+    traceM,+    packText,+    unpackText,+  )+  where++-- base+import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath, id, (.))+import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Applicative as Exports+import Control.Arrow as Exports hiding (left, right)+import Control.Category as Exports+import Data.Monoid as Exports+import Data.Foldable as Exports+import Data.Traversable as Exports hiding (for)+import Data.Maybe as Exports+import Data.List as Exports hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')+import Data.Tuple as Exports+import Data.Ord as Exports (Down(..))+import Data.String as Exports+import Data.Int as Exports+import Data.Word as Exports+import Data.Ratio as Exports+import Data.Fixed as Exports+import Data.Ix as Exports+import Data.Data as Exports+import Text.Read as Exports (readMaybe, readEither)+import Control.Exception as Exports hiding (tryJust)+import Control.Concurrent as Exports hiding (yield)+import System.Timeout as Exports+import System.Exit as Exports+import System.IO.Unsafe as Exports+import System.IO as Exports (Handle, hClose)+import System.IO.Error as Exports+import Unsafe.Coerce as Exports+import GHC.Exts as Exports (groupWith, sortWith)+import GHC.Generics as Exports (Generic)+import GHC.IO.Exception as Exports+import Debug.Trace as Exports+import Data.IORef as Exports+import Data.STRef as Exports+import Control.Monad.ST as Exports++-- mtl+import Control.Monad.Identity as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.Reader as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.Writer as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)+import Control.Monad.Trans as Exports++-- stm+import Control.Concurrent.STM as Exports++-- bytestring+import Data.ByteString as Exports (ByteString)++-- text+import Data.Text as Exports (Text)++-- containers+import Data.Map as Exports (Map)+import Data.IntMap as Exports (IntMap)+import Data.Set as Exports (Set)+import Data.IntSet as Exports (IntSet)+import Data.Sequence as Exports (Seq)+import Data.Tree as Exports (Tree)++-- unordered-containers+import Data.HashMap.Strict as Exports (HashMap)+import Data.HashSet as Exports (HashSet)++-- array+import Data.Array as Exports (Array)+import Data.Array.Unboxed as Exports (UArray)+import Data.Array.IArray as Exports (IArray)++-- vector+import Data.Vector as Exports (Vector)++-- hashable+import Data.Hashable as Exports (Hashable(..), hash)++-- time+import Data.Time as Exports (Day, DiffTime, NominalDiffTime, UniversalTime, UTCTime, LocalTime, TimeOfDay, TimeZone, ZonedTime)+import Data.Time.Clock.TAI as Exports (AbsoluteTime)++-- errors+import Control.Error as Exports+++import qualified Data.ByteString.Lazy+import qualified Data.Text.Lazy+import qualified Data.Vector.Primitive+import qualified Data.Vector.Storable+import qualified Data.Vector.Unboxed+import qualified Data.HashMap.Lazy+import qualified Data.Text+++type LazyByteString = Data.ByteString.Lazy.ByteString+type LazyText = Data.Text.Lazy.Text+type PVector = Data.Vector.Primitive.Vector+type SVector = Data.Vector.Storable.Vector+type UVector = Data.Vector.Unboxed.Vector+++traceM :: (Monad m) => String -> m ()+traceM s = trace s $ return ()++packText = Data.Text.pack+unpackText = Data.Text.unpack+
+ library/CerealPlus/Serializable.hs view
@@ -0,0 +1,459 @@+module CerealPlus.Serializable (Serializable(..)) where++import CerealPlus.Prelude+import qualified CerealPlus.Serialize as Serialize; import CerealPlus.Serialize (Serialize)+import qualified CerealPlus.Deserialize as Deserialize; import CerealPlus.Deserialize (Deserialize)+import qualified Data.Serialize as Cereal+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Lazy.Encoding as LazyText+import qualified Data.Time as Time+import qualified Data.Time.Clock.TAI as Time+import qualified Data.Tree+import qualified Data.Vector.Generic+import qualified Data.Vector.Primitive+import qualified Data.Vector.Storable+import qualified Data.Vector.Unboxed+import qualified Data.Array.IArray+import qualified Data.Map+import qualified Data.IntMap+import qualified Data.Set+import qualified Data.IntSet+import qualified Data.Sequence+import qualified Data.HashMap.Strict+import qualified Data.HashMap.Lazy+import qualified Data.HashSet+import qualified Data.HashTable.Class as Hashtables_Class+import qualified Data.HashTable.IO as Hashtables_IO+import qualified Data.HashTable.ST.Basic as Hashtables_Basic+import qualified Data.HashTable.ST.Cuckoo as Hashtables_Cuckoo+import qualified Data.HashTable.ST.Linear as Hashtables_Linear+import qualified GHC.Generics as Generics; import GHC.Generics ((:+:)(..), (:*:)(..))+++-- |+-- Support for serialization of a data type in a monadic context +-- (e.g., 'IO', 'ST', 'Control.Concurrent.STM.STM', 'Identity'),+-- meaning that this can be used to provide serialization support for mutable data.+-- +-- To use it in a pure context, refer to 'Identity' monad.+class Serializable m a where+  serialize :: (Monad m, Applicative m) => a -> Serialize m ()+  deserialize :: (Monad m, Applicative m) => Deserialize m a++  default serialize :: +    (Applicative m, Monad m, Generic a, SerializableRep (Generics.Rep a) m) => +    a -> Serialize m ()+  serialize = serializeRep . Generics.from++  default deserialize ::+    (Applicative m, Monad m, Generic a, SerializableRep (Generics.Rep a) m) => +    Deserialize m a+  deserialize = Generics.to <$> deserializeRep+++-- Generics:++class SerializableRep r m where+  serializeRep :: (Applicative m, Monad m) => r a -> Serialize m ()+  deserializeRep :: (Applicative m, Monad m) => Deserialize m (r a)++instance SerializableRep Generics.U1 m where+  serializeRep _ = pure ()+  deserializeRep = pure Generics.U1++instance (SerializableRep a m) => SerializableRep (Generics.M1 i c a) m where+  serializeRep = serializeRep . Generics.unM1+  deserializeRep = Generics.M1 <$> deserializeRep++instance (Serializable m a) => SerializableRep (Generics.K1 i a) m where+  serializeRep = serialize . Generics.unK1+  deserializeRep = Generics.K1 <$> deserialize++instance (SerializableRep a m, SerializableRep b m) => SerializableRep (a :*: b) m where+  serializeRep (a :*: b) = serializeRep a *> serializeRep b+  deserializeRep = (:*:) <$> deserializeRep <*> deserializeRep++instance (SerializableRep a m, SerializableRep b m) => SerializableRep (a :+: b) m where+  serializeRep = \case+    Generics.L1 a -> serialize False *> serializeRep a+    Generics.R1 a -> serialize True *> serializeRep a+  deserializeRep = deserialize >>= \case+    False -> Generics.L1 <$> deserializeRep+    True -> Generics.R1 <$> deserializeRep+++-- Manual instances:++instance (HasResolution a, Fractional (Fixed a)) => Serializable m (Fixed a) where+  serialize = serialize . toRational+  deserialize = fromRational <$> deserialize+++-- 'text' instances:++instance Serializable m Text where+  serialize = serialize . Text.encodeUtf8+  deserialize = Text.decodeUtf8 <$> deserialize++instance Serializable m LazyText where+  serialize = serialize . LazyText.encodeUtf8+  deserialize = LazyText.decodeUtf8 <$> deserialize+++-- 'time' instances:++instance Serializable m Day where+  serialize = serialize . Time.toModifiedJulianDay+  deserialize = Time.ModifiedJulianDay <$> deserialize++instance Serializable m DiffTime where+  serialize = serialize . toRational+  deserialize = fromRational <$> deserialize++instance Serializable m UniversalTime where+  serialize = serialize . Time.getModJulianDate+  deserialize = Time.ModJulianDate <$> deserialize++instance Serializable m UTCTime where+  serialize a = serialize (Time.utctDay a) *> serialize (Time.utctDayTime a)+  deserialize = Time.UTCTime <$> deserialize <*> deserialize++instance Serializable m NominalDiffTime where+  serialize = serialize . toRational+  deserialize = fromRational <$> deserialize++instance Serializable m TimeOfDay where+  serialize a = serialize (Time.todHour a) *> serialize (Time.todMin a) *> serialize (Time.todSec a)+  deserialize = Time.TimeOfDay <$> deserialize <*> deserialize <*> deserialize++instance Serializable m TimeZone where+  serialize a = +    serialize (Time.timeZoneMinutes a) *>+    serialize (Time.timeZoneSummerOnly a) *>+    serialize (Time.timeZoneName a)+  deserialize = Time.TimeZone <$> deserialize <*> deserialize <*> deserialize++instance Serializable m LocalTime where+  serialize a = serialize (Time.localDay a) *> serialize (Time.localTimeOfDay a)+  deserialize = Time.LocalTime <$> deserialize <*> deserialize++instance Serializable m ZonedTime where+  serialize a = serialize (Time.zonedTimeToLocalTime a) *> serialize (Time.zonedTimeZone a)+  deserialize = Time.ZonedTime <$> deserialize <*> deserialize++instance Serializable m AbsoluteTime where+  serialize a = serialize $ Time.diffAbsoluteTime a Time.taiEpoch+  deserialize = toAbsoluteTime <$> deserialize+    where+      toAbsoluteTime dt = Time.addAbsoluteTime dt Time.taiEpoch+++-- 'cereal' primitive instances wrappers:++instance Serializable m Char where serialize = put; deserialize = get+instance Serializable m Double where serialize = put; deserialize = get+instance Serializable m Float where serialize = put; deserialize = get+instance Serializable m Int where serialize = put; deserialize = get+instance Serializable m Int8 where serialize = put; deserialize = get+instance Serializable m Int16 where serialize = put; deserialize = get+instance Serializable m Int32 where serialize = put; deserialize = get+instance Serializable m Int64 where serialize = put; deserialize = get+instance Serializable m Integer where serialize = put; deserialize = get+instance Serializable m Word where serialize = put; deserialize = get+instance Serializable m Word8 where serialize = put; deserialize = get+instance Serializable m Word16 where serialize = put; deserialize = get+instance Serializable m Word32 where serialize = put; deserialize = get+instance Serializable m Word64 where serialize = put; deserialize = get+instance Serializable m () where serialize = put; deserialize = get+instance Serializable m ByteString where serialize = put; deserialize = get+instance Serializable m LazyByteString where serialize = put; deserialize = get+instance Serializable m IntSet where serialize = put; deserialize = get++put :: (Monad m, Applicative m, Cereal.Serialize a) => a -> Serialize m ()+put = Serialize.liftPut . Cereal.put++get :: (Monad m, Applicative m, Cereal.Serialize a) => Deserialize m a+get = Deserialize.liftGet Cereal.get+++-- fixed 'cereal' instances:++instance Serializable m Bool where +  serialize a = +    Serialize.liftPut . Cereal.putWord8 $ case a of+      False -> 0+      True -> 1+  deserialize = do+    Deserialize.liftGet Cereal.getWord8 >>= \case+      0 -> return False+      1 -> return True+      _ -> Deserialize.throwError "Out of range"++instance Serializable m Ordering where +  serialize a = +    Serialize.liftPut . Cereal.putWord8 $ case a of+      LT -> 0+      EQ -> 1+      GT -> 2+  deserialize = do+    Deserialize.liftGet Cereal.getWord8 >>= \case+      0 -> return LT+      1 -> return EQ+      2 -> return GT+      _ -> Deserialize.throwError "Out of range"+++-- Monoid wrappers instances:++instance (Serializable m a) => Serializable m (Dual a) where+  serialize = serialize . \case Dual a -> a+  deserialize = Dual <$> deserialize+  +instance Serializable m All where+  serialize = serialize . \case All a -> a+  deserialize = All <$> deserialize++instance Serializable m Any where+  serialize = serialize . \case Any a -> a+  deserialize = Any <$> deserialize++instance (Serializable m a) => Serializable m (Sum a) where+  serialize = serialize . \case Sum a -> a+  deserialize = Sum <$> deserialize++instance (Serializable m a) => Serializable m (Product a) where+  serialize = serialize . \case Product a -> a+  deserialize = Product <$> deserialize++instance (Serializable m a) => Serializable m (First a) where+  serialize = serialize . \case First a -> a+  deserialize = First <$> deserialize++instance (Serializable m a) => Serializable m (Last a) where+  serialize = serialize . \case Last a -> a+  deserialize = Last <$> deserialize+++-- Composite instances:++instance (Serializable m a, Integral a) => Serializable m (Ratio a) where+  serialize a = serialize (numerator a) *> serialize (denominator a)+  deserialize = (%) <$> deserialize <*> deserialize++instance (Serializable m a) => Serializable m (Tree a) where+  serialize (Data.Tree.Node root sub) = serialize root *> serialize sub+  deserialize = Data.Tree.Node <$> deserialize <*> deserialize++instance (Serializable m a, Serializable m b) => Serializable m (Either a b) where+  serialize = \case+    Right a -> serialize True *> serialize a+    Left a -> serialize False *> serialize a+  deserialize = do+    deserialize >>= \case+      True -> Right <$> deserialize+      False -> Left <$> deserialize++instance (Serializable m a) => Serializable m (Maybe a) where+  serialize = \case +    Just a -> serialize True >> serialize a+    Nothing -> serialize False+  deserialize = do+    z <- deserialize+    if z+      then deserialize >>= return . Just+      else return Nothing++instance (Serializable m a) => Serializable m [a] where+  serialize l = do+    serialize (length l)+    mapM_ serialize l+  deserialize = do+    n <- deserialize+    replicateM n deserialize++instance (Serializable m a) => Serializable m (Seq a) where+  serialize = serialize . toList+  deserialize = Data.Sequence.fromList <$> deserialize+++-- Tuple instances:++instance (Serializable m a) => Serializable m (Identity a) where+  serialize = serialize . \case Identity a -> a+  deserialize = Identity <$> deserialize++instance (Serializable m a, Serializable m b) => Serializable m (a, b) where+  serialize (a, b) = serialize a *> serialize b+  deserialize = (,) <$> deserialize <*> deserialize+  +instance (Serializable m a, Serializable m b, Serializable m c) => Serializable m (a, b, c) where+  serialize (a, b, c) = serialize a *> serialize b *> serialize c+  deserialize = (,,) <$> deserialize <*> deserialize <*> deserialize+  +instance (Serializable m a, Serializable m b, Serializable m c, Serializable m d) => Serializable m (a, b, c, d) where+  serialize (a, b, c, d) = serialize a *> serialize b *> serialize c *> serialize d+  deserialize = (,,,) <$> deserialize <*> deserialize <*> deserialize <*> deserialize++instance (Serializable m a, Serializable m b, Serializable m c, Serializable m d, Serializable m e) => Serializable m (a, b, c, d, e) where+  serialize (a, b, c, d, e) = serialize a *> serialize b *> serialize c *> serialize d *> serialize e+  deserialize = (,,,,) <$> deserialize <*> deserialize <*> deserialize <*> deserialize <*> deserialize+++-- 'containers' instances:++instance (Serializable m a, Ord a) => Serializable m (Set a) where+  serialize = serialize . Data.Set.toAscList+  deserialize = Data.Set.fromDistinctAscList <$> deserialize++instance (Serializable m a) => Serializable m (IntMap a) where+  serialize = serialize . Data.IntMap.toAscList+  deserialize = Data.IntMap.fromDistinctAscList <$> deserialize++instance (Serializable m a, Serializable m b, Ord a) => Serializable m (Map a b) where+  serialize = serialize . Data.Map.toAscList+  deserialize = Data.Map.fromDistinctAscList <$> deserialize+++-- 'unordered-containers' instances:++instance (Serializable m a, Serializable m b, Hashable a, Eq a) => Serializable m (HashMap a b) where+  serialize = serialize . Data.HashMap.Lazy.toList+  deserialize = Data.HashMap.Lazy.fromList <$> deserialize++instance (Serializable m a, Hashable a, Eq a) => Serializable m (HashSet a) where+  serialize = serialize . Data.HashSet.toList+  deserialize = Data.HashSet.fromList <$> deserialize+++-- 'array' instances:++instance (Serializable m e, Serializable m i, Ix i) => Serializable m (Array i e) where+  serialize = serializeArray+  deserialize = deserializeArray++instance (Serializable m e, Serializable m i, IArray UArray e, Ix i) => Serializable m (UArray i e) where+  serialize = serializeArray+  deserialize = deserializeArray++serializeArray :: (Monad m, Applicative m, Ix i, Serializable m e, Serializable m i, IArray a e) => a i e -> Serialize m ()+serializeArray a = do +  serialize $ Data.Array.IArray.bounds a+  serialize $ Data.Array.IArray.elems a++deserializeArray :: (Monad m, Applicative m, Ix i, Serializable m e, Serializable m i, IArray a e) => Deserialize m (a i e)+deserializeArray = Data.Array.IArray.listArray <$> deserialize <*> deserialize+++-- 'vector' instances:++instance (Serializable m a) => Serializable m (Vector a) where+  serialize = serializeVector+  deserialize = deserializeVector++instance (Serializable m a, Data.Vector.Primitive.Prim a) => Serializable m (PVector a) where+  serialize = serializeVector+  deserialize = deserializeVector++instance (Serializable m a, Data.Vector.Storable.Storable a) => Serializable m (SVector a) where+  serialize = serializeVector+  deserialize = deserializeVector++instance (Serializable m a, Data.Vector.Unboxed.Unbox a) => Serializable m (UVector a) where+  serialize = serializeVector+  deserialize = deserializeVector++serializeVector :: (Monad m, Applicative m, Data.Vector.Generic.Vector v a, Serializable m a) => v a -> Serialize m ()+serializeVector a = do+  serialize (Data.Vector.Generic.length a)+  Data.Vector.Generic.mapM_ serialize a++deserializeVector :: (Monad m, Applicative m, Data.Vector.Generic.Vector v a, Serializable m a) => Deserialize m (v a)+deserializeVector = do+  length <- deserialize+  Data.Vector.Generic.replicateM length deserialize+++-- 'hashtables' instances:++instance ( Serializable (ST s) a, Serializable (ST s) b, Hashable a, Eq a ) => +         Serializable (ST s) (Hashtables_Basic.HashTable s a b) where+  serialize = serializeHashTableST+  deserialize = deserializeHashTableST++instance ( Serializable (ST s) a, Serializable (ST s) b, Hashable a, Eq a ) => +         Serializable (ST s) (Hashtables_Cuckoo.HashTable s a b) where+  serialize = serializeHashTableST+  deserialize = deserializeHashTableST++instance ( Serializable (ST s) a, Serializable (ST s) b, Hashable a, Eq a ) => +         Serializable (ST s) (Hashtables_Linear.HashTable s a b) where+  serialize = serializeHashTableST+  deserialize = deserializeHashTableST++serializeHashTableST :: +  (Hashtables_Class.HashTable t, Serializable (ST s) a, Serializable (ST s) b) => +  t s a b -> Serialize (ST s) ()+serializeHashTableST t = do+  join $ lift $ Hashtables_Class.foldM (\a b -> return $ a >> processRow b) (return ()) t+  signalEnd+  where+    processRow (k, v) = do+      signalRow+      serialize k+      serialize v+    signalRow = serialize True+    signalEnd = serialize False++deserializeHashTableST :: +  (Hashtables_Class.HashTable t, Serializable (ST s) a, Serializable (ST s) b, Hashable a, Eq a) => +  Deserialize (ST s) (t s a b)+deserializeHashTableST = do+  t <- lift $ Hashtables_Class.new+  loop $ do+    (k, v) <- deserializeRow+    lift $ Hashtables_Class.insert t k v+  return t+  where+    loop action = do+      deserialize >>= \case+        False -> return ()+        True -> action >> loop action+    deserializeRow = (,) <$> deserialize <*> deserialize++instance ( Serializable (ST RealWorld) a, Serializable (ST RealWorld) b, Hashable a, Eq a ) => +         Serializable IO (Hashtables_Basic.HashTable RealWorld a b) where+  serialize = Serialize.mapBase stToIO . serializeHashTableST+  deserialize = Deserialize.mapBase stToIO deserializeHashTableST++instance ( Serializable (ST RealWorld) a, Serializable (ST RealWorld) b, Hashable a, Eq a ) => +         Serializable IO (Hashtables_Cuckoo.HashTable RealWorld a b) where+  serialize = Serialize.mapBase stToIO . serializeHashTableST+  deserialize = Deserialize.mapBase stToIO deserializeHashTableST++instance ( Serializable (ST RealWorld) a, Serializable (ST RealWorld) b, Hashable a, Eq a ) => +         Serializable IO (Hashtables_Linear.HashTable RealWorld a b) where+  serialize = Serialize.mapBase stToIO . serializeHashTableST+  deserialize = Deserialize.mapBase stToIO deserializeHashTableST+++-- Instances for mutable types from 'base':++instance (Serializable IO a) => Serializable IO (IORef a) where+  serialize = serialize <=< lift . readIORef+  deserialize = lift . newIORef =<< deserialize++instance (Serializable IO a) => Serializable IO (MVar a) where+  serialize = lift . readMVar >=> serialize+  deserialize = deserialize >>= lift . newMVar+++-- Instances for 'stm':++instance (Serializable STM a) => Serializable STM (TVar a) where+  serialize = serialize <=< lift . readTVar+  deserialize = lift . newTVar =<< deserialize++instance (Serializable IO a) => Serializable IO (TVar a) where+  serialize = lift . atomically . readTVar >=> serialize+  deserialize = deserialize >>= lift . atomically . newTVar+
+ library/CerealPlus/Serialize.hs view
@@ -0,0 +1,80 @@+-- |+-- A monad-transformer over "Data.Serialize.Put".+module CerealPlus.Serialize+  (+    Serialize,+    run,+    runLazy,+    exec,+    execLazy,+    liftPut,+    mapBase,+  )+  where++import CerealPlus.Prelude+import qualified Data.Serialize.Put as Cereal+import qualified Control.Monad.Layer as Layers+++-- | A serialization monad transformer.+newtype Serialize m a = Serialize (WriterT (PutM' ()) m a)+  deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadPlus, Alternative)++instance (Monad m) => Layers.MonadTransFunctor (Serialize m) where+  transMap = mapBase++instance (Monad m) => Layers.MonadTrans (Serialize m) where+  type Outer (Serialize m) = Serialize+  transInvmap = const . Layers.transMap++instance (Monad m) => Layers.MonadLayerFunctor (Serialize m) where+  layerMap = Layers.transMap++instance (Monad m) => Layers.MonadLayer (Serialize m) where+  type Inner (Serialize m) = m+  layerInvmap = const . Layers.layerMap+  layer = lift++++newtype PutM' a = PutM' (Cereal.PutM a)+  deriving (Functor, Applicative, Monad)++-- | Required for 'WriterT'+instance Monoid (PutM' ()) where+  mempty = return ()+  mappend a b = a >> b+++-- | Run and get the monad result paired with a bytestring of serialized data.+run :: Monad m => Serialize m a -> m (a, ByteString)+run (Serialize w) = do+  (a, PutM' putM) <- runWriterT w+  return (a, Cereal.runPut putM)++-- | Run and get the monad result paired with a lazy bytestring of serialized data.+runLazy :: Monad m => Serialize m a -> m (a, LazyByteString)+runLazy (Serialize w) = do+  (a, PutM' putM) <- runWriterT w+  return (a, Cereal.runPutLazy putM)++-- | Run and get a bytestring of serialized data.+exec :: Monad m => Serialize m a -> m ByteString+exec (Serialize w) = do+  PutM' putM <- execWriterT w+  return $ Cereal.runPut putM++-- | Run and get a lazy bytestring of serialized data.+execLazy :: Monad m => Serialize m a -> m LazyByteString+execLazy (Serialize w) = do+  PutM' putM <- execWriterT w+  return $ Cereal.runPutLazy putM++-- | Run a `Cereal.Put` action of the \"cereal\" library.+liftPut :: Monad m => Cereal.Put -> Serialize m ()+liftPut put = Serialize $ tell $ PutM' put++-- | Change the base monad. Same as `Layers.transMap` of the \"layers\" library.+mapBase :: (forall b. m b -> m' b) -> Serialize m a -> Serialize m' a+mapBase f (Serialize writer) = Serialize $ mapWriterT f writer
− src/CerealPlus/Deserialize.hs 
@@ -1,88 +0,0 @@--- |--- A monad-transformer over "Data.Serialize.Get".-module CerealPlus.Deserialize-  (-    Deserialize,-    runPartial,-    Result(..),-    liftGet,-    mapBase,-  )-  where--import CerealPlus.Prelude-import qualified Data.Serialize.Get as Cereal-import qualified Control.Monad.Layer as Layers----- | A deserialization monad transformer. -newtype Deserialize m a = Deserialize { -  -- | Run on a chunk of data and get a partial result.-  runPartial :: ByteString -> m (Result m a) -}--instance (Monad m) => Monad (Deserialize m) where-  Deserialize runA >>= aToDeserializeTB = Deserialize $ \bs -> runA bs >>= aToMB where-    aToMB a = case a of-      Fail msg bs -> return $ Fail msg bs-      Partial cont -> return $ Partial $ \bs -> cont bs >>= aToMB-      Done a bs -> case aToDeserializeTB a of Deserialize runB -> runB bs-  return a = Deserialize $ \bs -> return $ Done a bs--instance MonadTrans Deserialize where-  lift m = Deserialize $ \bs -> m >>= \a -> return $ Done a bs--instance (MonadIO m) => MonadIO (Deserialize m) where-  liftIO = lift . liftIO--instance (Monad m) => Applicative (Deserialize m) where-  pure = return-  (<*>) = ap--instance (Monad m) => Functor (Deserialize m) where-  fmap = liftM--instance (Monad m) => Layers.MonadTransFunctor (Deserialize m) where-  transMap = mapBase--instance (Monad m) => Layers.MonadTrans (Deserialize m) where-  type Outer (Deserialize m) = Deserialize-  transInvmap = const . Layers.transMap--instance (Monad m) => Layers.MonadLayerFunctor (Deserialize m) where-  layerMap = Layers.transMap--instance (Monad m) => Layers.MonadLayer (Deserialize m) where-  type Inner (Deserialize m) = m-  layerInvmap = const . Layers.layerMap-  layer = lift----- | A partial result of deserialization.-data Result m a = -  -- | A message describing the deserialization failure and a remaining chunk.-  Fail Text ByteString |-  -- | A continuation function, which should be supplied with the next chunk.-  Partial (ByteString -> m (Result m a)) |-  -- | A deserialized data structure and a remaining chunk.-  Done a ByteString---- | Run a `Cereal.Get` action of the \"cereal\" library.-liftGet :: Monad m => Cereal.Get a -> Deserialize m a-liftGet get = Deserialize $ \bs -> return $ convertResult $ Cereal.runGetPartial get bs -  where-    convertResult r = case r of-      Cereal.Fail m bs -> Fail (packText m) bs-      Cereal.Partial cont -> Partial $ \bs -> return $ convertResult $ cont bs-      Cereal.Done a bs -> Done a bs---- | Change the base monad. Same as `Layers.transMap` of the \"layers\" library.-mapBase :: (Monad m, Monad m') => (forall b. m b -> m' b) -> Deserialize m a -> Deserialize m' a-mapBase mToM' = \(Deserialize runPartial) -> Deserialize $ runPartialToRunPartial' runPartial-  where-    runPartialToRunPartial' runPartial = -      mToM' . runPartial >=> \case-        Fail m bs -> return $ Fail m bs-        Partial runPartial' -> return $ Partial $ runPartialToRunPartial' runPartial'-        Done a bs -> return $ Done a bs-
− src/CerealPlus/Prelude.hs 
@@ -1,119 +0,0 @@-module CerealPlus.Prelude -  ( -    module Exports,-    LazyByteString,-    LazyText,-    PVector,-    SVector,-    UVector,-    traceM,-    packText,-    unpackText,-  )-  where---- base-import Prelude as Exports hiding (concat, foldr, mapM_, sequence_, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, mapM, sequence, FilePath, id, (.))-import Control.Monad as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Applicative as Exports-import Control.Arrow as Exports hiding (left, right)-import Control.Category as Exports-import Data.Monoid as Exports-import Data.Foldable as Exports-import Data.Traversable as Exports hiding (for)-import Data.Maybe as Exports-import Data.List as Exports hiding (concat, foldr, foldl1, maximum, minimum, product, sum, all, and, any, concatMap, elem, foldl, foldr1, notElem, or, find, maximumBy, minimumBy, mapAccumL, mapAccumR, foldl')-import Data.Tuple as Exports-import Data.Ord as Exports (Down(..))-import Data.String as Exports-import Data.Int as Exports-import Data.Word as Exports-import Data.Ratio as Exports-import Data.Fixed as Exports-import Data.Ix as Exports-import Data.Data as Exports-import Text.Read as Exports (readMaybe, readEither)-import Control.Exception as Exports hiding (tryJust)-import Control.Concurrent as Exports hiding (yield)-import System.Timeout as Exports-import System.Exit as Exports-import System.IO.Unsafe as Exports-import System.IO as Exports (Handle, hClose)-import System.IO.Error as Exports-import Unsafe.Coerce as Exports-import GHC.Exts as Exports (groupWith, sortWith)-import GHC.Generics as Exports (Generic)-import GHC.IO.Exception as Exports-import Debug.Trace as Exports-import Data.IORef as Exports-import Data.STRef as Exports-import Control.Monad.ST as Exports---- mtl-import Control.Monad.Identity as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.Reader as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.Writer as Exports hiding (mapM_, sequence_, forM_, msum, mapM, sequence, forM)-import Control.Monad.Trans as Exports---- stm-import Control.Concurrent.STM as Exports---- bytestring-import Data.ByteString as Exports (ByteString)---- text-import Data.Text as Exports (Text)---- containers-import Data.Map as Exports (Map)-import Data.IntMap as Exports (IntMap)-import Data.Set as Exports (Set)-import Data.IntSet as Exports (IntSet)-import Data.Sequence as Exports (Seq)-import Data.Tree as Exports (Tree)---- unordered-containers-import Data.HashMap.Strict as Exports (HashMap)-import Data.HashSet as Exports (HashSet)---- array-import Data.Array as Exports (Array)-import Data.Array.Unboxed as Exports (UArray)-import Data.Array.IArray as Exports (IArray)---- vector-import Data.Vector as Exports (Vector)---- hashable-import Data.Hashable as Exports (Hashable(..), hash)---- time-import Data.Time as Exports (Day, DiffTime, NominalDiffTime, UniversalTime, UTCTime, LocalTime, TimeOfDay, TimeZone, ZonedTime)-import Data.Time.Clock.TAI as Exports (AbsoluteTime)---- errors-import Control.Error as Exports---import qualified Data.ByteString.Lazy-import qualified Data.Text.Lazy-import qualified Data.Vector.Primitive-import qualified Data.Vector.Storable-import qualified Data.Vector.Unboxed-import qualified Data.HashMap.Lazy-import qualified Data.Text---type LazyByteString = Data.ByteString.Lazy.ByteString-type LazyText = Data.Text.Lazy.Text-type PVector = Data.Vector.Primitive.Vector-type SVector = Data.Vector.Storable.Vector-type UVector = Data.Vector.Unboxed.Vector---traceM :: (Monad m) => String -> m ()-traceM s = trace s $ return ()--packText = Data.Text.pack-unpackText = Data.Text.unpack-
− src/CerealPlus/Serializable.hs 
@@ -1,434 +0,0 @@-module CerealPlus.Serializable (Serializable(..)) where--import CerealPlus.Prelude-import qualified CerealPlus.Serialize as Serialize; import CerealPlus.Serialize (Serialize)-import qualified CerealPlus.Deserialize as Deserialize; import CerealPlus.Deserialize (Deserialize)-import qualified Data.Serialize as Cereal-import qualified Data.Text.Encoding as Text-import qualified Data.Text.Lazy.Encoding as LazyText-import qualified Data.Time as Time-import qualified Data.Time.Clock.TAI as Time-import qualified Data.Tree-import qualified Data.Vector.Generic-import qualified Data.Vector.Primitive-import qualified Data.Vector.Storable-import qualified Data.Vector.Unboxed-import qualified Data.Array.IArray-import qualified Data.Map-import qualified Data.IntMap-import qualified Data.Set-import qualified Data.IntSet-import qualified Data.Sequence-import qualified Data.HashMap.Strict-import qualified Data.HashMap.Lazy-import qualified Data.HashSet-import qualified Data.HashTable.Class as Hashtables_Class-import qualified Data.HashTable.IO as Hashtables_IO-import qualified Data.HashTable.ST.Basic as Hashtables_Basic-import qualified Data.HashTable.ST.Cuckoo as Hashtables_Cuckoo-import qualified Data.HashTable.ST.Linear as Hashtables_Linear-import qualified GHC.Generics as Generics; import GHC.Generics ((:+:)(..), (:*:)(..))----- |--- Support for serialization of a data type in a monadic context --- (e.g., 'IO', 'ST', 'Control.Concurrent.STM.STM', 'Identity'),--- meaning that this can be used to provide serialization support for mutable data.--- --- To use it in a pure context, refer to 'Identity' monad.-class Serializable m a where-  serialize :: (Monad m, Applicative m) => a -> Serialize m ()-  deserialize :: (Monad m, Applicative m) => Deserialize m a--  default serialize :: -    (Applicative m, Monad m, Generic a, SerializableRep (Generics.Rep a) m) => -    a -> Serialize m ()-  serialize = serializeRep . Generics.from--  default deserialize ::-    (Applicative m, Monad m, Generic a, SerializableRep (Generics.Rep a) m) => -    Deserialize m a-  deserialize = Generics.to <$> deserializeRep----- Generics:--class SerializableRep r m where-  serializeRep :: (Applicative m, Monad m) => r a -> Serialize m ()-  deserializeRep :: (Applicative m, Monad m) => Deserialize m (r a)--instance SerializableRep Generics.U1 m where-  serializeRep _ = pure ()-  deserializeRep = pure Generics.U1--instance (SerializableRep a m) => SerializableRep (Generics.M1 i c a) m where-  serializeRep = serializeRep . Generics.unM1-  deserializeRep = Generics.M1 <$> deserializeRep--instance (Serializable m a) => SerializableRep (Generics.K1 i a) m where-  serializeRep = serialize . Generics.unK1-  deserializeRep = Generics.K1 <$> deserialize--instance (SerializableRep a m, SerializableRep b m) => SerializableRep (a :*: b) m where-  serializeRep (a :*: b) = serializeRep a *> serializeRep b-  deserializeRep = (:*:) <$> deserializeRep <*> deserializeRep--instance (SerializableRep a m, SerializableRep b m) => SerializableRep (a :+: b) m where-  serializeRep = \case-    Generics.L1 a -> serialize False *> serializeRep a-    Generics.R1 a -> serialize True *> serializeRep a-  deserializeRep = deserialize >>= \case-    False -> Generics.L1 <$> deserializeRep-    True -> Generics.R1 <$> deserializeRep----- Manual instances:--instance (HasResolution a, Fractional (Fixed a)) => Serializable m (Fixed a) where-  serialize = serialize . toRational-  deserialize = fromRational <$> deserialize----- 'text' instances:--instance Serializable m Text where-  serialize = serialize . Text.encodeUtf8-  deserialize = Text.decodeUtf8 <$> deserialize--instance Serializable m LazyText where-  serialize = serialize . LazyText.encodeUtf8-  deserialize = LazyText.decodeUtf8 <$> deserialize----- 'time' instances:--instance Serializable m Day where-  serialize = serialize . Time.toModifiedJulianDay-  deserialize = Time.ModifiedJulianDay <$> deserialize--instance Serializable m DiffTime where-  serialize = serialize . toRational-  deserialize = fromRational <$> deserialize--instance Serializable m UniversalTime where-  serialize = serialize . Time.getModJulianDate-  deserialize = Time.ModJulianDate <$> deserialize--instance Serializable m UTCTime where-  serialize a = serialize (Time.utctDay a) *> serialize (Time.utctDayTime a)-  deserialize = Time.UTCTime <$> deserialize <*> deserialize--instance Serializable m NominalDiffTime where-  serialize = serialize . toRational-  deserialize = fromRational <$> deserialize--instance Serializable m TimeOfDay where-  serialize a = serialize (Time.todHour a) *> serialize (Time.todMin a) *> serialize (Time.todSec a)-  deserialize = Time.TimeOfDay <$> deserialize <*> deserialize <*> deserialize--instance Serializable m TimeZone where-  serialize a = -    serialize (Time.timeZoneMinutes a) *>-    serialize (Time.timeZoneSummerOnly a) *>-    serialize (Time.timeZoneName a)-  deserialize = Time.TimeZone <$> deserialize <*> deserialize <*> deserialize--instance Serializable m LocalTime where-  serialize a = serialize (Time.localDay a) *> serialize (Time.localTimeOfDay a)-  deserialize = Time.LocalTime <$> deserialize <*> deserialize--instance Serializable m ZonedTime where-  serialize a = serialize (Time.zonedTimeToLocalTime a) *> serialize (Time.zonedTimeZone a)-  deserialize = Time.ZonedTime <$> deserialize <*> deserialize--instance Serializable m AbsoluteTime where-  serialize a = serialize $ Time.diffAbsoluteTime a Time.taiEpoch-  deserialize = toAbsoluteTime <$> deserialize-    where-      toAbsoluteTime dt = Time.addAbsoluteTime dt Time.taiEpoch----- 'cereal' primitive instances wrappers:--instance Serializable m Bool where serialize = put; deserialize = get-instance Serializable m Char where serialize = put; deserialize = get-instance Serializable m Double where serialize = put; deserialize = get-instance Serializable m Float where serialize = put; deserialize = get-instance Serializable m Int where serialize = put; deserialize = get-instance Serializable m Int8 where serialize = put; deserialize = get-instance Serializable m Int16 where serialize = put; deserialize = get-instance Serializable m Int32 where serialize = put; deserialize = get-instance Serializable m Int64 where serialize = put; deserialize = get-instance Serializable m Integer where serialize = put; deserialize = get-instance Serializable m Ordering where serialize = put; deserialize = get-instance Serializable m Word where serialize = put; deserialize = get-instance Serializable m Word8 where serialize = put; deserialize = get-instance Serializable m Word16 where serialize = put; deserialize = get-instance Serializable m Word32 where serialize = put; deserialize = get-instance Serializable m Word64 where serialize = put; deserialize = get-instance Serializable m () where serialize = put; deserialize = get-instance Serializable m ByteString where serialize = put; deserialize = get-instance Serializable m LazyByteString where serialize = put; deserialize = get-instance Serializable m IntSet where serialize = put; deserialize = get--put :: (Monad m, Applicative m, Cereal.Serialize a) => a -> Serialize m ()-put = Serialize.liftPut . Cereal.put--get :: (Monad m, Applicative m, Cereal.Serialize a) => Deserialize m a-get = Deserialize.liftGet Cereal.get----- Monoid wrappers instances:--instance (Serializable m a) => Serializable m (Dual a) where-  serialize = serialize . \case Dual a -> a-  deserialize = Dual <$> deserialize-  -instance Serializable m All where-  serialize = serialize . \case All a -> a-  deserialize = All <$> deserialize--instance Serializable m Any where-  serialize = serialize . \case Any a -> a-  deserialize = Any <$> deserialize--instance (Serializable m a) => Serializable m (Sum a) where-  serialize = serialize . \case Sum a -> a-  deserialize = Sum <$> deserialize--instance (Serializable m a) => Serializable m (Product a) where-  serialize = serialize . \case Product a -> a-  deserialize = Product <$> deserialize--instance (Serializable m a) => Serializable m (First a) where-  serialize = serialize . \case First a -> a-  deserialize = First <$> deserialize--instance (Serializable m a) => Serializable m (Last a) where-  serialize = serialize . \case Last a -> a-  deserialize = Last <$> deserialize----- Composite instances:--instance (Serializable m a, Integral a) => Serializable m (Ratio a) where-  serialize a = serialize (numerator a) *> serialize (denominator a)-  deserialize = (%) <$> deserialize <*> deserialize--instance (Serializable m a) => Serializable m (Tree a) where-  serialize (Data.Tree.Node root sub) = serialize root *> serialize sub-  deserialize = Data.Tree.Node <$> deserialize <*> deserialize--instance (Serializable m a, Serializable m b) => Serializable m (Either a b) where-  serialize = \case-    Right a -> serialize True *> serialize a-    Left a -> serialize False *> serialize a-  deserialize = do-    deserialize >>= \case-      True -> Right <$> deserialize-      False -> Left <$> deserialize--instance (Serializable m a) => Serializable m (Maybe a) where-  serialize = \case -    Just a -> serialize True >> serialize a-    Nothing -> serialize False-  deserialize = do-    z <- deserialize-    if z-      then deserialize >>= return . Just-      else return Nothing--instance (Serializable m a) => Serializable m [a] where-  serialize l = do-    serialize (length l)-    mapM_ serialize l-  deserialize = do-    n <- deserialize-    replicateM n deserialize--instance (Serializable m a) => Serializable m (Seq a) where-  serialize = serialize . toList-  deserialize = Data.Sequence.fromList <$> deserialize----- Tuple instances:--instance (Serializable m a) => Serializable m (Identity a) where-  serialize = serialize . \case Identity a -> a-  deserialize = Identity <$> deserialize--instance (Serializable m a, Serializable m b) => Serializable m (a, b) where-  serialize (a, b) = serialize a *> serialize b-  deserialize = (,) <$> deserialize <*> deserialize-  -instance (Serializable m a, Serializable m b, Serializable m c) => Serializable m (a, b, c) where-  serialize (a, b, c) = serialize a *> serialize b *> serialize c-  deserialize = (,,) <$> deserialize <*> deserialize <*> deserialize-  -instance (Serializable m a, Serializable m b, Serializable m c, Serializable m d) => Serializable m (a, b, c, d) where-  serialize (a, b, c, d) = serialize a *> serialize b *> serialize c *> serialize d-  deserialize = (,,,) <$> deserialize <*> deserialize <*> deserialize <*> deserialize--instance (Serializable m a, Serializable m b, Serializable m c, Serializable m d, Serializable m e) => Serializable m (a, b, c, d, e) where-  serialize (a, b, c, d, e) = serialize a *> serialize b *> serialize c *> serialize d *> serialize e-  deserialize = (,,,,) <$> deserialize <*> deserialize <*> deserialize <*> deserialize <*> deserialize----- 'containers' instances:--instance (Serializable m a, Ord a) => Serializable m (Set a) where-  serialize = serialize . Data.Set.toAscList-  deserialize = Data.Set.fromDistinctAscList <$> deserialize--instance (Serializable m a) => Serializable m (IntMap a) where-  serialize = serialize . Data.IntMap.toAscList-  deserialize = Data.IntMap.fromDistinctAscList <$> deserialize--instance (Serializable m a, Serializable m b, Ord a) => Serializable m (Map a b) where-  serialize = serialize . Data.Map.toAscList-  deserialize = Data.Map.fromDistinctAscList <$> deserialize----- 'unordered-containers' instances:--instance (Serializable m a, Serializable m b, Hashable a, Eq a) => Serializable m (HashMap a b) where-  serialize = serialize . Data.HashMap.Lazy.toList-  deserialize = Data.HashMap.Lazy.fromList <$> deserialize--instance (Serializable m a, Hashable a, Eq a) => Serializable m (HashSet a) where-  serialize = serialize . Data.HashSet.toList-  deserialize = Data.HashSet.fromList <$> deserialize----- 'array' instances:--instance (Serializable m e, Serializable m i, Ix i) => Serializable m (Array i e) where-  serialize = serializeArray-  deserialize = deserializeArray--instance (Serializable m e, Serializable m i, IArray UArray e, Ix i) => Serializable m (UArray i e) where-  serialize = serializeArray-  deserialize = deserializeArray--serializeArray :: (Monad m, Applicative m, Ix i, Serializable m e, Serializable m i, IArray a e) => a i e -> Serialize m ()-serializeArray a = do -  serialize $ Data.Array.IArray.bounds a-  serialize $ Data.Array.IArray.elems a--deserializeArray :: (Monad m, Applicative m, Ix i, Serializable m e, Serializable m i, IArray a e) => Deserialize m (a i e)-deserializeArray = Data.Array.IArray.listArray <$> deserialize <*> deserialize----- 'vector' instances:--instance (Serializable m a) => Serializable m (Vector a) where-  serialize = serializeVector-  deserialize = deserializeVector--instance (Serializable m a, Data.Vector.Primitive.Prim a) => Serializable m (PVector a) where-  serialize = serializeVector-  deserialize = deserializeVector--instance (Serializable m a, Data.Vector.Storable.Storable a) => Serializable m (SVector a) where-  serialize = serializeVector-  deserialize = deserializeVector--instance (Serializable m a, Data.Vector.Unboxed.Unbox a) => Serializable m (UVector a) where-  serialize = serializeVector-  deserialize = deserializeVector--serializeVector :: (Monad m, Applicative m, Data.Vector.Generic.Vector v a, Serializable m a) => v a -> Serialize m ()-serializeVector a = do-  serialize (Data.Vector.Generic.length a)-  Data.Vector.Generic.mapM_ serialize a--deserializeVector :: (Monad m, Applicative m, Data.Vector.Generic.Vector v a, Serializable m a) => Deserialize m (v a)-deserializeVector = do-  length <- deserialize-  Data.Vector.Generic.replicateM length deserialize----- 'hashtables' instances:--instance ( Serializable (ST s) a, Serializable (ST s) b, Hashable a, Eq a ) => -         Serializable (ST s) (Hashtables_Basic.HashTable s a b) where-  serialize = serializeHashTableST-  deserialize = deserializeHashTableST--instance ( Serializable (ST s) a, Serializable (ST s) b, Hashable a, Eq a ) => -         Serializable (ST s) (Hashtables_Cuckoo.HashTable s a b) where-  serialize = serializeHashTableST-  deserialize = deserializeHashTableST--instance ( Serializable (ST s) a, Serializable (ST s) b, Hashable a, Eq a ) => -         Serializable (ST s) (Hashtables_Linear.HashTable s a b) where-  serialize = serializeHashTableST-  deserialize = deserializeHashTableST--serializeHashTableST :: -  (Hashtables_Class.HashTable t, Serializable (ST s) a, Serializable (ST s) b) => -  t s a b -> Serialize (ST s) ()-serializeHashTableST t = do-  join $ lift $ Hashtables_Class.foldM (\a b -> return $ a >> processRow b) (return ()) t-  signalEnd-  where-    processRow (k, v) = do-      signalRow-      serialize k-      serialize v-    signalRow = serialize True-    signalEnd = serialize False--deserializeHashTableST :: -  (Hashtables_Class.HashTable t, Serializable (ST s) a, Serializable (ST s) b, Hashable a, Eq a) => -  Deserialize (ST s) (t s a b)-deserializeHashTableST = do-  t <- lift $ Hashtables_Class.new-  loop $ do-    (k, v) <- deserializeRow-    lift $ Hashtables_Class.insert t k v-  return t-  where-    loop action = do-      deserialize >>= \case-        False -> return ()-        True -> action >> loop action-    deserializeRow = (,) <$> deserialize <*> deserialize--instance ( Serializable (ST RealWorld) a, Serializable (ST RealWorld) b, Hashable a, Eq a ) => -         Serializable IO (Hashtables_Basic.HashTable RealWorld a b) where-  serialize = Serialize.mapBase stToIO . serializeHashTableST-  deserialize = Deserialize.mapBase stToIO deserializeHashTableST--instance ( Serializable (ST RealWorld) a, Serializable (ST RealWorld) b, Hashable a, Eq a ) => -         Serializable IO (Hashtables_Cuckoo.HashTable RealWorld a b) where-  serialize = Serialize.mapBase stToIO . serializeHashTableST-  deserialize = Deserialize.mapBase stToIO deserializeHashTableST--instance ( Serializable (ST RealWorld) a, Serializable (ST RealWorld) b, Hashable a, Eq a ) => -         Serializable IO (Hashtables_Linear.HashTable RealWorld a b) where-  serialize = Serialize.mapBase stToIO . serializeHashTableST-  deserialize = Deserialize.mapBase stToIO deserializeHashTableST----- Instances for mutable types from 'base':--instance (Serializable IO a) => Serializable IO (IORef a) where-  serialize = serialize <=< lift . readIORef-  deserialize = lift . newIORef =<< deserialize--instance (Serializable IO a) => Serializable IO (MVar a) where-  serialize = lift . readMVar >=> serialize-  deserialize = deserialize >>= lift . newMVar----- Instances for 'stm':--instance (Serializable STM a) => Serializable STM (TVar a) where-  serialize = serialize <=< lift . readTVar-  deserialize = lift . newTVar =<< deserialize--instance (Serializable IO a) => Serializable IO (TVar a) where-  serialize = lift . atomically . readTVar >=> serialize-  deserialize = deserialize >>= lift . atomically . newTVar-
− src/CerealPlus/Serialize.hs 
@@ -1,80 +0,0 @@--- |--- A monad-transformer over "Data.Serialize.Put".-module CerealPlus.Serialize-  (-    Serialize,-    run,-    runLazy,-    exec,-    execLazy,-    liftPut,-    mapBase,-  )-  where--import CerealPlus.Prelude-import qualified Data.Serialize.Put as Cereal-import qualified Control.Monad.Layer as Layers----- | A serialization monad transformer.-newtype Serialize m a = Serialize (WriterT (PutM' ()) m a)-  deriving (Functor, Applicative, Monad, MonadIO, MonadTrans, MonadPlus, Alternative)--instance (Monad m) => Layers.MonadTransFunctor (Serialize m) where-  transMap = mapBase--instance (Monad m) => Layers.MonadTrans (Serialize m) where-  type Outer (Serialize m) = Serialize-  transInvmap = const . Layers.transMap--instance (Monad m) => Layers.MonadLayerFunctor (Serialize m) where-  layerMap = Layers.transMap--instance (Monad m) => Layers.MonadLayer (Serialize m) where-  type Inner (Serialize m) = m-  layerInvmap = const . Layers.layerMap-  layer = lift----newtype PutM' a = PutM' (Cereal.PutM a)-  deriving (Functor, Applicative, Monad)---- | Required for 'WriterT'-instance Monoid (PutM' ()) where-  mempty = return ()-  mappend a b = a >> b----- | Run and get the monad result paired with a bytestring of serialized data.-run :: Monad m => Serialize m a -> m (a, ByteString)-run (Serialize w) = do-  (a, PutM' putM) <- runWriterT w-  return (a, Cereal.runPut putM)---- | Run and get the monad result paired with a lazy bytestring of serialized data.-runLazy :: Monad m => Serialize m a -> m (a, LazyByteString)-runLazy (Serialize w) = do-  (a, PutM' putM) <- runWriterT w-  return (a, Cereal.runPutLazy putM)---- | Run and get a bytestring of serialized data.-exec :: Monad m => Serialize m a -> m ByteString-exec (Serialize w) = do-  PutM' putM <- execWriterT w-  return $ Cereal.runPut putM---- | Run and get a lazy bytestring of serialized data.-execLazy :: Monad m => Serialize m a -> m LazyByteString-execLazy (Serialize w) = do-  PutM' putM <- execWriterT w-  return $ Cereal.runPutLazy putM---- | Run a `Cereal.Put` action of the \"cereal\" library.-liftPut :: Monad m => Cereal.Put -> Serialize m ()-liftPut put = Serialize $ tell $ PutM' put---- | Change the base monad. Same as `Layers.transMap` of the \"layers\" library.-mapBase :: (forall b. m b -> m' b) -> Serialize m a -> Serialize m' a-mapBase f (Serialize writer) = Serialize $ mapWriterT f writer