describe 0.3.1.1 → 0.4.0.0

raw patch · 19 files changed

+331/−169 lines, 19 filesdep +lensdep +mmorphdep +monad-controlPVP ok

version bump matches the API change (PVP)

Dependencies added: lens, mmorph, monad-control, mtl, profunctors, transformers

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• describe.cabal +20/−11
• src/Data/Serialize/Describe/Class.hs +58/−19
• src/Data/Serialize/Describe/Combinators.hs +0/−2
• src/Data/Serialize/Describe/Combinators/BE.hs +21/−20
• src/Data/Serialize/Describe/Combinators/Byte.hs +3/−2
• src/Data/Serialize/Describe/Combinators/ByteEnum.hs +11/−4
• src/Data/Serialize/Describe/Combinators/Conditional.hs +5/−13
• src/Data/Serialize/Describe/Combinators/Const.hs +3/−2
• src/Data/Serialize/Describe/Combinators/FList.hs +16/−6
• src/Data/Serialize/Describe/Combinators/FText.hs +5/−4
• src/Data/Serialize/Describe/Combinators/Isolate.hs +0/−8
• src/Data/Serialize/Describe/Combinators/LE.hs +23/−21
• src/Data/Serialize/Describe/Combinators/LPList.hs +4/−3
• src/Data/Serialize/Describe/Combinators/NText.hs +14/−17
• src/Data/Serialize/Describe/Combinators/Remaining.hs +10/−3
• src/Data/Serialize/Describe/Descriptor.hs +18/−34
• src/Data/Serialize/Describe/Internal/Descriptor.hs +101/−0
• src/Data/Serialize/Describe/Isomorphisms.hs +13/−0

@@ -1,5 +1,11 @@ # Revision history for describe +##0.4.0.0 -- 2020-01-19++* Added lens isomorphism utilities+* Split the role of 'describe' into 'field'/'fieldOf'+* Added the `conditionally` combinator+ ##0.3.1.1 -- 2020-01-09  * Added flist combinator

@@ -1,9 +1,6 @@ cabal-version:       2.4--- Initial package description 'describe.cabal' generated by 'cabal init'.---   For further documentation, see http://haskell.org/cabal/users-guide/- name:                describe-version:             0.3.1.1+version:             0.4.0.0 synopsis:            Combinators for describing binary data structures description:         Combinators for describing binary data structures, which eliminate the boilerplate of having to write isomorphic Get and Put instances. Please see the Github page for examples. homepage:            https://github.com/riugabachi/describe@@ -21,17 +18,22 @@ common deps   default-extensions: TypeApplications,                       MultiParamTypeClasses,+                      TupleSections,                       AllowAmbiguousTypes,+                      QuantifiedConstraints,+                      RankNTypes,                       FunctionalDependencies,+                      DeriveAnyClass,+                      DeriveGeneric,                       DerivingVia,                       OverloadedStrings,                       TypeFamilies,                       TypeOperators,-                      OverlappingInstances,                       LambdaCase,                       StandaloneDeriving,                       GeneralizedNewtypeDeriving,                       FlexibleContexts,+                      ViewPatterns,                       DefaultSignatures,                       DataKinds,                       UndecidableInstances,@@ -41,18 +43,26 @@                       EmptyDataDecls,                       ScopedTypeVariables,                       FlexibleInstances-  build-depends: base ^>= 4.12.0.0,-                 cereal >= 0.5.8 && < 0.6,-                 bytestring >= 0.10.8 && < 0.11,-                 fixed-vector >= 1.2.0 && < 1.3,-                 text         >= 1.2.3 && < 1.3,+  build-depends: base                ^>= 4.12.0.0,+                 cereal               >= 0.5.8 && < 0.6,+                 bytestring           >= 0.10.8 && < 0.11,+                 fixed-vector         >= 1.2.0 && < 1.3,+                 text                 >= 1.2.3 && < 1.3,+                 transformers         >= 0.5.6 && < 0.6,+                 lens                 >= 4.18.1 && < 4.19,+                 mtl                  >= 2.2.2 && < 2.3,+                 profunctors          >= 5.5.1 && < 5.6,+                 mmorph               >= 1.1.3 && < 1.2,+                 monad-control        >= 1.0.2 && < 1.1   ghc-options: -Wall   default-language: Haskell2010  library   import: deps+  other-modules:       Data.Serialize.Describe.Internal.Descriptor   exposed-modules:     Data.Serialize.Describe,                        Data.Serialize.Describe.Descriptor,+                       Data.Serialize.Describe.Isomorphisms,                        Data.Serialize.Describe.Combinators,                        Data.Serialize.Describe.Combinators.LE,                        Data.Serialize.Describe.Combinators.BE,@@ -61,7 +71,6 @@                        Data.Serialize.Describe.Combinators.LPList,                        Data.Serialize.Describe.Combinators.FList,                        Data.Serialize.Describe.Combinators.Const,-                       Data.Serialize.Describe.Combinators.Isolate,                        Data.Serialize.Describe.Combinators.Byte,                        Data.Serialize.Describe.Combinators.Remaining,                        Data.Serialize.Describe.Combinators.ByteEnum,

@@ -1,9 +1,12 @@ module Data.Serialize.Describe.Class(-  Describe, describe+  Describe, Context, describe,+  field, isoField ) where  import GHC.Generics+import GHC.Exts import GHC.TypeNats+import Data.Profunctor import Control.Monad import qualified Data.Vector.Fixed as V import Data.Serialize.Get@@ -13,52 +16,88 @@ import Data.Int import Data.Proxy import Data.Word-import Data.Serialize.Describe.Descriptor+import Control.Lens (view)+import Control.Lens.Iso (Iso')+import qualified Control.Lens.Iso as I+import Control.Monad.Trans.Class+import Control.Monad.Trans.Identity+import Data.Serialize.Describe.Internal.Descriptor+import Data.Serialize.Describe.Isomorphisms  class Describe a where-  describe :: (s -> a) -> Descriptor s a+  type Context (m :: (* -> *) -> * -> *) a :: Constraint +  type Context m a = ()  -  default describe :: (Generic a, GDescribe (Rep a)) => (s -> a) -> Descriptor s a -  describe f = fmap to . gdescribe $ from <$> f+  describe :: (MonadTrans m, forall x. Monad x => Monad (m x), Context m a) => DescriptorM m a a +  default describe :: ( Generic a+                      , GDescribe (Rep a)+                      , MonadTrans m+                      , forall x. Monad x => Monad (m x)+                      ) => DescriptorM m a a +  describe = morphTransformer (lift . runIdentityT) $ dimap from to gdescribe++-- | A descriptor from structure to field.+field :: forall a m s. ( Describe a+                       , MonadTrans m+                       , forall x. Monad x => Monad (m x)+                       , Context m a+                       )+      => (s -> a) +      -> DescriptorM m s a+field f = morphRef f describe++-- | Similar to @field@, but applied to an isomorphism.+isoField :: (Describe b, MonadTrans m, forall x. Monad x => Monad (m x), Context m b) +         => Iso' a b +         -> (s -> a) +         -> DescriptorM m s a+isoField i f = view (I.from i) <$> morphRef (view i . f) describe+ class GDescribe f where-  gdescribe :: (s -> f a) -> Descriptor s (f a)+  gdescribe :: Descriptor (f a) (f a)    instance GDescribe U1 where-  gdescribe _ = pure U1+  gdescribe = pure U1  instance (GDescribe a, GDescribe b) => GDescribe (a :*: b) where-  gdescribe f = liftM2 (:*:) (gdescribe (l . f))  (gdescribe (r . f))+  gdescribe = liftM2 (:*:) (lmap l gdescribe) (lmap r gdescribe)     where       l (a :*: _) = a       r (_ :*: b) = b  instance (GDescribe a) => GDescribe (M1 i c a) where-  gdescribe f = M1 <$> gdescribe (extract . f)+  gdescribe = M1 <$> lmap extract gdescribe     where       extract (M1 x) = x -instance (Describe a) => GDescribe (K1 i a) where-  gdescribe f = K1 <$> describe (extract . f)+instance (Describe a, Context IdentityT a) => GDescribe (K1 i a) where+  gdescribe = K1 <$> lmap extract describe     where       extract (K1 x) = x  instance Describe () where-  describe _ = pure ()+  describe = pure ()  instance Describe Bool where-    describe f = toEnum . fromIntegral <$> describe (fromIntegral @_ @Word8 . fromEnum . f)+    describe = toEnum . fromIntegral <$> field (fromIntegral @_ @Word8 . fromEnum)  instance Describe Char where-    describe f = chr . fromIntegral <$> describe @Word8 (fromIntegral . ord <$> f)+    describe = chr . fromIntegral <$> field @Word8 (fromIntegral . ord)  instance Describe Word8 where-    describe f = Descriptor (fromIntegral <$> getWord8, \s' -> putWord8 (fromIntegral $ f s') >> pure (fromIntegral $ f s'))+  describe = mkDescriptor fi (const 1) getWord8 putWord8  instance Describe Int8 where-    describe f = Descriptor (fromIntegral <$> getInt8, \s' -> putInt8 (fromIntegral $ f s') >> pure (f s'))+    describe = mkDescriptor fi (const 1) getWord8 putWord8 -instance (Describe a, V.Arity n, V.Vector (Vec n) a, KnownNat n) => Describe (Vec n a) where-    describe f =+instance +  ( Describe a+  , V.Arity n+  , V.Vector (Vec n) a+  , KnownNat n+  ) => Describe (Vec n a) where+    type Context m (Vec n a) = Context m a+    describe =        V.fromList <$> forM [0..fromIntegral (natVal (Proxy :: Proxy n))-1] -        (\i -> describe $ (V.! i) . f)+        (\i -> field (V.! i))

@@ -1,5 +1,4 @@ module Data.Serialize.Describe.Combinators(-  module Data.Serialize.Describe.Combinators.Isolate,   module Data.Serialize.Describe.Combinators.Remaining,   module Data.Serialize.Describe.Combinators.FText,   module Data.Serialize.Describe.Combinators.FList,@@ -11,7 +10,6 @@   module Data.Serialize.Describe.Combinators.Byte ) where -import Data.Serialize.Describe.Combinators.Isolate import Data.Serialize.Describe.Combinators.Remaining import Data.Serialize.Describe.Combinators.FText import Data.Serialize.Describe.Combinators.FList

@@ -15,57 +15,58 @@ import Data.Serialize.IEEE754 import Data.Serialize.Get import Data.Serialize.Put-import Data.Serialize.Describe.Descriptor+import Data.Serialize.Describe.Internal.Descriptor+import Data.Serialize.Describe.Isomorphisms import Data.Serialize.Describe.Class  w16 :: Integral i => (s -> i) -> Descriptor s i-w16 f = Descriptor (fromIntegral <$> getWord16be, \s' -> putWord16be (fromIntegral $ f s') >> pure (f s'))+w16 = isoField @(BE Word16) fi  w32 :: Integral i => (s -> i) -> Descriptor s i-w32 f = Descriptor (fromIntegral <$> getWord32be, \s' -> putWord32be (fromIntegral $ f s') >> pure (f s'))+w32 = isoField @(BE Word32) fi  w64 :: Integral i => (s -> i) -> Descriptor s i-w64 f = Descriptor (fromIntegral <$> getWord64be, \s' -> putWord64be (fromIntegral $ f s') >> pure (f s'))+w64 = isoField @(BE Word64) fi  i16 :: Integral i => (s -> i) -> Descriptor s i-i16 f = Descriptor (fromIntegral <$> getInt16be, \s' -> putInt16be (fromIntegral $ f s') >> pure (f s'))+i16 = isoField @(BE Int16) fi  i32 :: Integral i => (s -> i) -> Descriptor s i-i32 f = Descriptor (fromIntegral <$> getInt32be, \s' -> putInt32be (fromIntegral $ f s') >> pure (f s'))+i32 = isoField @(BE Int32) fi  i64 :: Integral i => (s -> i) -> Descriptor s i-i64 f = Descriptor (fromIntegral <$> getInt64be, \s' -> putInt64be (fromIntegral $ f s') >> pure (f s'))+i64 = isoField @(BE Int64) fi  f32 :: (Real f, Fractional f) => (s -> f) -> Descriptor s f-f32 f = Descriptor (realToFrac <$> getFloat32be, \s' -> putFloat32be (realToFrac $ f s') >> pure (f s'))+f32 = isoField @(BE Float) rtf  f64 :: (Real f, Fractional f) => (s -> f) -> Descriptor s f-f64 f = Descriptor (realToFrac <$> getFloat64be, \s' -> putFloat64be (realToFrac $ f s') >> pure (f s'))+f64 = isoField @(BE Double) rtf -newtype BE a = BE { unwrapBE :: a }-             deriving (Show, Read, Num, Eq, Ord, Enum, Integral, Real, Fractional)+newtype BE a +  = BE { unwrapBE :: a }+  deriving newtype (Show, Read, Num, Eq, Ord, Enum, Integral, Real, Fractional)  instance Describe (BE Word16) where-    describe = w16+    describe = mkDescriptor fi (const 2) getWord16be putWord16be  instance Describe (BE Word32) where-    describe = w32+    describe = mkDescriptor fi (const 4) getWord32be putWord32be  instance Describe (BE Word64) where-    describe = w64+    describe = mkDescriptor fi (const 8) getWord64be putWord64be  instance Describe (BE Int16) where-    describe = i16+    describe = mkDescriptor fi (const 2) getInt16be putInt16be  instance Describe (BE Int32) where-    describe = i32+    describe = mkDescriptor fi (const 4) getInt32be putInt32be  instance Describe (BE Int64) where-    describe = i64+    describe = mkDescriptor fi (const 8) getInt64be putInt64be  instance Describe (BE Float) where-    describe = f32+    describe = mkDescriptor rtf (const 4) getFloat32be putFloat32be  instance Describe (BE Double) where-    describe = f64-+    describe = mkDescriptor rtf (const 8) getFloat64be putFloat64be

@@ -4,9 +4,10 @@ import Data.Int import Data.Serialize.Describe.Descriptor import Data.Serialize.Describe.Class+import Data.Serialize.Describe.Isomorphisms  w8 :: Integral i => (s -> i) -> Descriptor s i-w8 f = fromIntegral <$> describe @Word8 (fromIntegral . f)+w8 = isoField @Word8 fi  i8 :: Integral i => (s -> i) -> Descriptor s i-i8 f = fromIntegral <$> describe @Int8 (fromIntegral . f)+i8 = isoField @Int8 fi

@@ -1,16 +1,23 @@ module Data.Serialize.Describe.Combinators.ByteEnum where +import GHC.Generics hiding (from)+import Control.Lens.Wrapped+import Control.Lens.Iso import Data.Word import Data.Serialize.Describe.Class+import Data.Serialize.Describe.Isomorphisms  -- | Wraps an @Enum@ to be described as a Word8. Intended to be used with DerivingVia so as to not introduce unnecessary newtype wrappers:--- @+-- >>> --  data MyEnum = A | B | C  --              deriving Enum --              deriving Describe via ByteEnum MyEnum--- @-newtype ByteEnum e = ByteEnum { unwrapByteEnum :: e }+newtype ByteEnum e +  = ByteEnum { unwrapByteEnum :: e }+  deriving (Generic) +deriving anyclass instance Wrapped (ByteEnum e)+ instance Enum e => Describe (ByteEnum e) where-  describe f = ByteEnum . toEnum . fromIntegral <$> describe @Word8 (fromIntegral . fromEnum . unwrapByteEnum . f)+  describe = isoField @Word8 (_Wrapped' . from enum . fi) id 

@@ -1,13 +1,13 @@ module Data.Serialize.Describe.Combinators.Conditional where +import Prelude hiding (id, (.)) import GHC.TypeNats import Data.Proxy-import Data.Maybe import qualified Data.Vector.Fixed as V import Data.Vector.Fixed.Boxed-import qualified Data.Serialize.Get as G-import Data.Serialize.Describe.Descriptor+import Data.Serialize.Describe.Internal.Descriptor import Data.Serialize.Describe.Class+import Control.Monad.Trans.Control  -- | An 'Optional' represents a field which is optionally-serializable. The field will be parsed via a lookAhead and, if the value matches the 'Predicate' p, then the field exists. If not, it is assumed as though the field was never serialized in the first place and the value will be set to 'Nothing'; parsing will then continue on as usual. newtype Optional p t = Optional { unwrapOptional :: Maybe t }@@ -24,13 +24,5 @@   check = V.all (== fromIntegral (natVal (Proxy :: Proxy n1)))  instance (Describe a, Predicate a p) => Describe (Optional p a) where-  describe f = Descriptor (g, p)-    where-      g = do -        let d = unwrapGet $ describe @a $ fromJust . unwrapOptional . f-        v <- G.lookAhead d-        Optional <$> if check @a @p v then Just <$> d else pure Nothing-      p s = case unwrapOptional $ f s of-        Just x -> Optional . Just <$> unwrapPut s (describe $ const x)-        Nothing -> pure $ Optional Nothing-+  type Context m (Optional p a) = (MonadTransControl m, Context m a)+  describe = Optional <$> conditionally unwrapOptional (check @a @p) describe

@@ -4,12 +4,13 @@ import Data.Serialize.Describe import Data.Proxy --- | A type level wrapper around the equivalent of the @pure . const@ descriptor.+-- | A type level wrapper around the equivalent of the @pure . const@ descriptor forall @KnownNat@. data Const (n :: Nat) t = Const  instance KnownNat n => Show (Const n t) where   show _ = show $ natVal (Proxy :: Proxy n)  instance (KnownNat n, Describe t, Integral t) => Describe (Const n t) where-  describe _ = (Const <$) . describe @t $ const $ fromIntegral $ natVal $ (Proxy :: Proxy n)+  type Context m (Const n t) = Context m t+  describe = (Const <$) . field @t $ const $ fromIntegral $ natVal $ (Proxy :: Proxy n) 

@@ -7,12 +7,21 @@ import Data.Serialize.Describe.Combinators.BE import Data.Serialize.Describe.Combinators.LE import Control.Monad+import Control.Monad.Trans.Class  -- | A fixed-length list combinator, with similar semantics to @FText@. The list element must be @Nullable@, meaning that it must have default value that can be used for padding the list if need be.-flist :: (Describe a, Nullable a) => Int -> (s -> [a]) -> Descriptor s [a]+flist :: ( MonadTrans m+         , forall x. Monad x => Monad (m x)+         , Describe a+         , Nullable a+         , Context m a+         ) +      => Int +      -> (s -> [a]) +      -> DescriptorM m s [a] flist fixedLen f =    forM [0..fixedLen - 1] $ \i -> -    describe $ \l ->+    field $ \l ->       let actualLen = length . take fixedLen $ f l        in (!! i) . (<> replicate (fixedLen - actualLen) nullVal) $ f l @@ -27,12 +36,13 @@ instance Num n => Nullable n where   nullVal = 0 -deriving instance Num n => Nullable (LE n)-deriving instance Num n => Nullable (BE n)+deriving newtype instance Num n => Nullable (LE n)+deriving newtype instance Num n => Nullable (BE n)  instance Nullable (Const n a) where   nullVal = Const  instance (KnownNat n, Nullable a, Describe a) => Describe (FList n a) where-  describe f = do-    FList <$> flist (fromIntegral (natVal $ Proxy @n)) (unwrapFList . f)+  type Context m (FList n a) = Context m a+  describe = do+    FList <$> flist (fromIntegral (natVal $ Proxy @n)) unwrapFList

@@ -10,11 +10,12 @@ import Data.Serialize.Describe.Descriptor import Data.Serialize.Describe.Class import Control.Monad+import Control.Monad.Trans.Class  -- | A fixed text descriptor which reads a fixed amount of bytes, discarding all trailing '\0' characters. Upon serializing, the text will either be truncated to the specified fixed length, or padded with '\0' characters to meet it.-ftext :: Int -> (s -> Text) -> Descriptor s Text+ftext :: (MonadTrans m, forall x. Monad x => Monad (m x)) => Int -> (s -> Text) -> DescriptorM m s Text ftext maxLen f = -  fmap (T.takeWhile (/= '\0') . fromString . (fmap (chr . fromIntegral))) <$> forM [0..maxLen-1] $ \i -> describe $ \s -> +  fmap (T.takeWhile (/= '\0') . fromString . (fmap (chr . fromIntegral))) <$> forM [0..maxLen-1] $ \i -> field $ \s ->      let t = f s         p = (<> T.replicate (maxLen - T.length t) "\0") . T.take maxLen $ t      in fromIntegral @_ @Word8 . ord $ T.index p i@@ -27,6 +28,6 @@   fromString = FText . T.pack  instance KnownNat n => Describe (FText n) where-  describe f = -    FText <$> ftext (fromIntegral (natVal (Proxy :: Proxy n))) (fmap unwrapFText f)+  describe = +    FText <$> ftext (fromIntegral (natVal (Proxy :: Proxy n))) unwrapFText 

@@ -1,8 +0,0 @@-module Data.Serialize.Describe.Combinators.Isolate where--import qualified Data.Serialize.Get as G-import Data.Serialize.Describe.Descriptor---- | Wrapper around @isolate@ from Data.Serialize.Get-isolate :: Int -> Descriptor s a -> Descriptor s a-isolate amt desc = Descriptor (G.isolate amt $ unwrapGet desc, flip unwrapPut desc)

@@ -1,7 +1,7 @@ -- | Little endian combinators. ----- All combinators take a function that takes the structure being described ('a') and produces the specified data type from it.--- Most of the time, this will be one of the structure's fields, which are all functions from the structure to the field type.+-- All combinators take a function that takes the structure leing described ('a') and produces the specified data type from it.+-- Most of the time, this will le one of the structure's fields, which are all functions from the structure to the field type. module Data.Serialize.Describe.Combinators.LE(   LE(..),   w16, w32, w64,@@ -14,56 +14,58 @@ import Data.Serialize.IEEE754 import Data.Serialize.Get import Data.Serialize.Put-import Data.Serialize.Describe.Descriptor+import Data.Serialize.Describe.Internal.Descriptor+import Data.Serialize.Describe.Isomorphisms import Data.Serialize.Describe.Class  w16 :: Integral i => (s -> i) -> Descriptor s i-w16 f = Descriptor (fromIntegral <$> getWord16le, \s' -> putWord16le (fromIntegral $ f s') >> pure (f s'))+w16 = isoField @(LE Word16) fi  w32 :: Integral i => (s -> i) -> Descriptor s i-w32 f = Descriptor (fromIntegral <$> getWord32le, \s' -> putWord32le (fromIntegral $ f s') >> pure (f s'))+w32 = isoField @(LE Word32) fi  w64 :: Integral i => (s -> i) -> Descriptor s i-w64 f = Descriptor (fromIntegral <$> getWord64le, \s' -> putWord64le (fromIntegral $ f s') >> pure (f s'))+w64 = isoField @(LE Word64) fi  i16 :: Integral i => (s -> i) -> Descriptor s i-i16 f = Descriptor (fromIntegral <$> getInt16le, \s' -> putInt16le (fromIntegral $ f s') >> pure (f s'))+i16 = isoField @(LE Int16) fi  i32 :: Integral i => (s -> i) -> Descriptor s i-i32 f = Descriptor (fromIntegral <$> getInt32le, \s' -> putInt32le (fromIntegral $ f s') >> pure (f s'))+i32 = isoField @(LE Int32) fi  i64 :: Integral i => (s -> i) -> Descriptor s i-i64 f = Descriptor (fromIntegral <$> getInt64le, \s' -> putInt64le (fromIntegral $ f s') >> pure (f s'))+i64 = isoField @(LE Int64) fi  f32 :: (Real f, Fractional f) => (s -> f) -> Descriptor s f-f32 f = Descriptor (realToFrac <$> getFloat32le, \s' -> putFloat32le (realToFrac $ f s') >> pure (f s'))+f32 = isoField @(LE Float) rtf  f64 :: (Real f, Fractional f) => (s -> f) -> Descriptor s f-f64 f = Descriptor (realToFrac <$> getFloat64le, \s' -> putFloat64le (realToFrac $ f s') >> pure (f s'))+f64 = isoField @(LE Double) rtf -newtype LE a = LE { unwrapLE :: a }-             deriving (Show, Read, Num, Eq, Ord, Enum, Integral, Real, Fractional)+newtype LE a +  = LE { unwrapLE :: a }+  deriving newtype (Show, Read, Num, Eq, Ord, Enum, Integral, Real, Fractional)  instance Describe (LE Word16) where-    describe = w16+    describe = mkDescriptor fi (const 2) getWord16le putWord16le  instance Describe (LE Word32) where-    describe = w32+    describe = mkDescriptor fi (const 4) getWord32le putWord32le  instance Describe (LE Word64) where-    describe = w64+    describe = mkDescriptor fi (const 8) getWord64le putWord64le  instance Describe (LE Int16) where-    describe = i16+    describe = mkDescriptor fi (const 2) getInt16le putInt16le  instance Describe (LE Int32) where-    describe = i32+    describe = mkDescriptor fi (const 4) getInt32le putInt32le  instance Describe (LE Int64) where-    describe = i64+    describe = mkDescriptor fi (const 8) getInt64le putInt64le  instance Describe (LE Float) where-    describe = f32+    describe = mkDescriptor rtf (const 4) getFloat32le putFloat32le  instance Describe (LE Double) where-    describe = f64+    describe = mkDescriptor rtf (const 8) getFloat64le putFloat64le

@@ -9,7 +9,8 @@   deriving (Show) via [a]  instance (Describe t, Describe a, Integral t) => Describe (LPList t a) where-  describe f = do-    len <- describe @t $ fromIntegral . length . unwrapLPList . f-    fmap LPList $ forM [0..fromIntegral len-1] $ \i -> describe @a $ (!! i) . unwrapLPList . f +  type Context m (LPList t a) = (Context m a, Context m t)+  describe = do+    len <- field @t $ fromIntegral . length . unwrapLPList+    fmap LPList $ forM [0..fromIntegral len-1] $ \i -> field @a $ (!! i) . unwrapLPList 

@@ -1,28 +1,25 @@ module Data.Serialize.Describe.Combinators.NText where -import Data.Char+import Prelude hiding ((.), id)+import Control.Category+import Control.Monad.Trans.Class import Data.String import Data.Text (Text) import qualified Data.Text as T-import Data.Serialize.Describe.Descriptor+import Data.Serialize.Describe.Internal.Descriptor import Data.Serialize.Describe.Class-import Data.Serialize.Put-import Control.Monad  -- | A null-terminated text descriptor which reads characters until '\0' is encountered. Semantically, the '\0' is consumed by the parser. The entire text will be serialized with a '\0' character appended to the end.-ntext :: (s -> Text) -> Descriptor s Text-ntext f = Descriptor (g, p)+ntext :: (MonadTrans m, forall x. Monad x => Monad (m x)) => (s -> Text) -> DescriptorM m s Text+ntext f = T.pack . reverse <$> go 0 []   where-    g = unwrapGet $ T.pack . reverse <$> go []-      where-        go cs = describe @Char (const '\0') >>= \case-          '\0' -> pure cs-          c -> go $ c:cs-    p s = do-      forM_ (T.unpack (f s)) $ putWord8 . fromIntegral . ord-      putWord8 $ fromIntegral $ ord '\0'-      pure (f s)+    go i cs = field @Char (test i . f) >>= \case+      '\0' -> pure cs+      c -> pure (c:cs) +    test i t | i >= T.length t = '\0'+             | otherwise = T.index t i+ -- | Type-level variant of @ftext@. newtype NText = NText { unwrapNText :: Text }                 deriving (Show) via Text@@ -31,6 +28,6 @@   fromString = NText . T.pack  instance Describe NText where-  describe f = -    NText <$> ntext (fmap unwrapNText f)+  describe = +    NText <$> ntext unwrapNText 

@@ -1,14 +1,21 @@ module Data.Serialize.Describe.Combinators.Remaining where +import GHC.Generics+import Control.Lens.Wrapped import Data.ByteString+import qualified Data.ByteString as B import qualified Data.Serialize.Get as G import qualified Data.Serialize.Put as P-import Data.Serialize.Describe.Descriptor+import Data.Serialize.Describe.Internal.Descriptor import Data.Serialize.Describe.Class  -- | A  'Remaining' represents the rest of the buffer. Upon serialization, the entire wrapped ByteString will be written.-newtype Remaining = Remaining { unwrapRemaining :: ByteString }+newtype Remaining +  = Remaining { unwrapRemaining :: ByteString }+  deriving (Generic) +deriving anyclass instance Wrapped Remaining+ instance Describe Remaining where-  describe f = Descriptor (fmap Remaining . G.getByteString =<< G.remaining, \s -> P.putByteString (unwrapRemaining (f s)) >> pure (f s))+  describe = mkDescriptor _Wrapped' B.length (G.getByteString =<< G.remaining) P.putByteString 

@@ -1,38 +1,35 @@ module Data.Serialize.Describe.Descriptor(-  Descriptor(Descriptor),-  unwrapGet,-  unwrapPut,+  DescriptorM,+  Descriptor,+  -- * Execution   serialize,   deserialize,-  deserializeEx+  deserializeEx,+  -- * Conversion to @cereal@ monads+  unwrapGet,+  unwrapPut,+  -- * Utilities+  morphRef,+  morphTransformer,+  isolate,+  lookAhead,+  cursor ) where  import Control.Exception-import Control.Monad.Fail import Data.ByteString (ByteString)-import Data.Serialize.Get+import Data.Serialize.Get hiding (isolate) import Data.Serialize.Put---- | @Descriptor s a@ is an applicative functor that describes the binary structure for a structure 's' while deserializing value 'a'.-newtype Descriptor s a = Descriptor {-    unwrapDescriptor :: (Get a, s -> PutM a)-}---- | @unwrapGet desc@ takes a 'Descriptor' and returns only the internal 'Get' monad.-unwrapGet :: Descriptor s a -> Get a-unwrapGet = fst . unwrapDescriptor---- | @unwrapPut s desc@ takes the structure being described and a 'Descriptor' for it, and returns the internal 'Put' monad.-unwrapPut :: s -> Descriptor s a -> PutM a-unwrapPut s = ($ s) . snd . unwrapDescriptor+import Data.Serialize.Describe.Internal.Descriptor+import Control.Monad.Trans.Identity  -- | Convenience function for @runPut . unwrapPut s@ serialize :: s -> Descriptor s a -> ByteString-serialize s = snd . runPutM . unwrapPut s+serialize s = snd . runPutM . runIdentityT . unwrapPut s  -- | Convenience function for @flip runGet bs . unwrapGet@ deserialize :: ByteString -> Descriptor s s -> Either String s-deserialize bs = flip runGet bs . unwrapGet+deserialize bs = flip runGet bs . runIdentityT . unwrapGet  newtype ParserException = ParserException String                         deriving (Show)@@ -44,16 +41,3 @@ deserializeEx bs d = case deserialize bs d of   Left err -> throw $ ParserException err   Right a -> a--instance Functor (Descriptor s) where-  fmap f (Descriptor (g, p)) = Descriptor (f <$> g, (f <$>) . p)--instance Applicative (Descriptor s) where-  pure a = Descriptor (pure a, \_ -> pure a)-  (Descriptor (f, p)) <*> (Descriptor (g, p')) =-    Descriptor (f <*> g, \s' -> p s' <*> p' s')--instance Monad (Descriptor s) where-  (Descriptor (g, p)) >>= f =-    Descriptor (g >>= fst . unwrapDescriptor . f, \s -> p s >>= ($ s) . snd . unwrapDescriptor . f)-

@@ -0,0 +1,101 @@+module Data.Serialize.Describe.Internal.Descriptor where++import Data.Bool+import Data.Profunctor+import Data.Serialize.Get hiding (isolate)+import qualified Data.Serialize.Get as G+import Control.Lens+import Data.Serialize.Put+import Control.Monad.Trans.Identity+import Control.Monad.State+import Control.Monad.Trans.Control+import Control.Monad.Morph++-- | @Descriptor s a@ is an applicative functor that describes the binary structure for a structure 's' while deserializing value 'a'.+newtype DescriptorM m s a +  = Descriptor { unwrapDescriptor :: (StateT Int (m Get) a, s -> StateT Int (m PutM) a) }++type Descriptor s a = DescriptorM IdentityT s a++instance (MonadTrans m, forall x. Monad x => Monad (m x)) => Functor (DescriptorM m s) where+  fmap f (Descriptor (g, p)) = Descriptor (f <$> g, fmap f <$> p)++instance (MonadTrans m, forall x. Monad x => Monad (m x)) => Profunctor (DescriptorM m) where+  lmap = morphRef+  rmap = fmap+  dimap l r = morphRef l . fmap r++instance (MonadTrans m, forall x. Monad x => Monad (m x)) => Applicative (DescriptorM m s) where+  pure a = Descriptor (pure a, \_ -> pure a)+  (Descriptor (f, p)) <*> (Descriptor (g, p')) =+    Descriptor (f <*> g, \s -> p s <*> p' s)++instance (MonadTrans m, forall x. Monad x => Monad (m x)) => Monad (DescriptorM m s) where+  (Descriptor (g, p)) >>= f =+    Descriptor (g >>= bindG , \s -> p s >>= bindP s)+    where+      bindG x = fst $ unwrapDescriptor (f x)+      bindP s x = ($ s) . snd $ unwrapDescriptor (f x)++mkDescriptor :: (MonadTrans m, forall x. Monad x => Monad (m x)) +             => Iso' a s +             -> (s -> Int) +             -> Get s +             -> (s -> Put) +             -> DescriptorM m a a+mkDescriptor i size g p = +  Descriptor $ (,) +    (view (from i) <$> ((lift . lift) g >>= \s' -> modify (+ size s') >> pure s'))+    (\s -> modify (+ size (view i s)) >> (lift . lift) (p $ view i s) >> pure s)++-- | @unwrapGet desc@ takes a 'Descriptor' and returns only the internal 'Get' monad.+unwrapGet :: (MonadTrans m, forall x. Monad x => Monad (m x)) => DescriptorM m s a -> m Get a+unwrapGet = flip evalStateT 0 . fst . unwrapDescriptor++-- | @unwrapPut s desc@ takes the structure being described and a 'Descriptor' for it, and returns the internal 'Put' monad.+unwrapPut :: (MonadTrans m, forall x. Monad x => Monad (m x)) => s -> DescriptorM m s a -> m PutM a+unwrapPut s = flip evalStateT 0 . ($ s) . snd . unwrapDescriptor++-- | Shifts the reference point of the described structure using the provided morphism. Identical to @lmap@.+morphRef :: (MonadTrans m, forall x. Monad x => Monad (m x)) => (s -> t) -> DescriptorM m t a -> DescriptorM m s a+morphRef f (Descriptor (g, p)) = Descriptor (g, p . f)++-- | Morphs the underlying monad transformer+morphTransformer :: (MonadTrans t, MonadTrans u, forall n. Monad n => (Monad (t n), Monad (u n)))+                 => (forall m x. Monad m => t m x -> u m x)+                 -> DescriptorM t s a+                 -> DescriptorM u s a+morphTransformer f (Descriptor (g, p)) = Descriptor (hoist f g, hoist f <$> p)++-- | Wrapper around @isolate@ from Data.Serialize.Get+isolate :: (MonadTransControl m, forall x. Monad x => Monad (m x)) => Int -> DescriptorM m s a -> DescriptorM m s a+isolate amt desc = +  Descriptor +    (liftWith (\r' -> +      liftWith (\r -> G.isolate amt $ r . r' . fst $ unwrapDescriptor desc) +        >>= restoreT . return) +          >>= restoreT . return, snd $ unwrapDescriptor desc)++-- | Similar to lookAhead from Data.Serialize.Get; puts only if the field is @Just@+conditionally :: (MonadTransControl m, forall x. Monad x => Monad (m x))+              => (s -> Maybe a)+              -> (a -> Bool)+              -> DescriptorM m a a +              -> DescriptorM m s (Maybe a)+conditionally f pd desc = Descriptor (g, p)+  where+    g = +      liftWith (\r' -> +        liftWith (\r -> G.lookAhead (r . r' . fst $ unwrapDescriptor desc)) +          >>= restoreT . return) +            >>= restoreT . return +              >>= bool (pure Nothing) (Just <$> fst (unwrapDescriptor desc)) . pd+    p ((f $) -> Just x) = bool +      (pure Nothing) +      (fmap Just . ($ x) . snd  . unwrapDescriptor $ desc) +      (pd x)+    p _ = pure Nothing++-- | The cursor position, i.e. how many bytes have been written/parsed so far.+cursor :: (MonadTrans m, forall x. Monad (m x)) => DescriptorM m s Int+cursor = Descriptor (get, \_ -> get)

@@ -0,0 +1,13 @@+module Data.Serialize.Describe.Isomorphisms where++import Control.Lens.Iso+import Data.Char++fi :: (Integral i1, Integral i2) => Iso' i1 i2+fi = iso fromIntegral fromIntegral++rtf :: (Real i1, Fractional i1, Real i2, Fractional i2) => Iso' i1 i2+rtf = iso realToFrac realToFrac++ordChr :: Iso' Char Int+ordChr = iso ord chr