Add Monad instance for Codec'

Author: Lysxia

Data/Aeson/Codec.hs

@@ -33,7 +33,7 @@ type ObjectBuilder = Const (Endo [ Pair ])
 type ObjectCodec a = Codec ObjectParser ObjectBuilder a
 
 -- | Produce a key-value pair.
-pair :: ToJSON a => T.Text -> a -> ObjectBuilder ()
+pair :: ToJSON a => T.Text -> a -> ObjectBuilder b
 pair key val = Const $ Endo ((key .= val):)
 
 -- | Read\/write a given value from/to a given key in the current object, using a given sub-codec.

Data/Binary/Bits/Codec.hs

@@ -10,28 +10,29 @@ import Control.Applicative
 import qualified Data.Binary.Bits.Get as G
 import Data.Binary.Bits.Put
 import qualified Data.Binary.Codec as B
+import Data.Functor ((<$))
 
 import Data.Codec
 import Data.Word
 
 type BitCodec a = Codec G.Block BitPut a
 
 bool :: BitCodec Bool
-bool = Codec G.bool putBool
+bool = codec G.bool putBool
 
 word8 :: Int -> BitCodec Word8
-word8 = Codec <$> G.word8 <*> putWord8
+word8 = codec <$> G.word8 <*> putWord8
 
 word16be :: Int -> BitCodec Word16
-word16be = Codec <$> G.word16be <*> putWord16be
+word16be = codec <$> G.word16be <*> putWord16be
 
 word32be :: Int -> BitCodec Word32
-word32be = Codec <$> G.word32be <*> putWord32be
+word32be = codec <$> G.word32be <*> putWord32be
 
 word64be :: Int -> BitCodec Word64
-word64be = Codec <$> G.word64be <*> putWord64be
+word64be = codec <$> G.word64be <*> putWord64be
 
 -- | Convert a `BitCodec` into a `B.BinaryCodec`.
 toBytes :: BitCodec a -> B.BinaryCodec a
 toBytes (Codec r w)
-  = Codec (G.runBitGet $ G.block r) (runBitPut . w)
+  = codec (G.runBitGet $ G.block r) (runBitPut . (() <$) . w)

Data/Binary/Codec.hs

@@ -27,47 +27,47 @@ byteString :: Int -> BinaryCodec BS.ByteString
 byteString n = Codec
   { parse = getByteString n
   , produce = \bs -> if BS.length bs == n
-      then putByteString bs
+      then putByteString bs >> return bs
       else fail "ByteString wrong size for field."
   }
 
 word8 :: BinaryCodec Word8
-word8 = Codec getWord8 putWord8
+word8 = codec getWord8 putWord8
 
 word16be :: BinaryCodec Word16
-word16be = Codec getWord16be putWord16be
+word16be = codec getWord16be putWord16be
 
 word16le :: BinaryCodec Word16
-word16le = Codec getWord16le putWord16le
+word16le = codec getWord16le putWord16le
 
 word16host :: BinaryCodec Word16
-word16host = Codec getWord16host putWord16host
+word16host = codec getWord16host putWord16host
 
 word32be :: BinaryCodec Word32
-word32be = Codec getWord32be putWord32be
+word32be = codec getWord32be putWord32be
 
 word32le :: BinaryCodec Word32
-word32le = Codec getWord32le putWord32le
+word32le = codec getWord32le putWord32le
 
 word32host :: BinaryCodec Word32
-word32host = Codec getWord32host putWord32host
+word32host = codec getWord32host putWord32host
 
 word64be :: BinaryCodec Word64
-word64be = Codec getWord64be putWord64be
+word64be = codec getWord64be putWord64be
 
 word64le :: BinaryCodec Word64
-word64le = Codec getWord64le putWord64le
+word64le = codec getWord64le putWord64le
 
 word64host :: BinaryCodec Word64
-word64host = Codec getWord64host putWord64host
+word64host = codec getWord64host putWord64host
 
 wordhost :: BinaryCodec Word
-wordhost = Codec getWordhost putWordhost
+wordhost = codec getWordhost putWordhost
 
 -- | Convert a `BinaryCodec` into a `ConcreteCodec` on lazy `LBS.ByteString`s.
 toLazyByteString :: BinaryCodec a -> ConcreteCodec LBS.ByteString (Either String) a
 toLazyByteString (Codec r w) = concrete
   (\bs -> case runGetOrFail r bs of
     Left ( _ , _, err ) -> Left err
     Right ( _, _, x ) -> Right x)
-  (runPut . w)
+  (runPut . (>> return ()) . w)

Data/Codec/Codec.hs

@@ -1,6 +1,7 @@
 module Data.Codec.Codec
   ( -- * Codecs
     Codec'(..), Codec
+  , codec
   , (>-<)
     -- * Concrete codecs
   , ConcreteCodec, concrete, parseVal, produceVal
@@ -18,15 +19,17 @@ import Control.Applicative
 import Control.Monad ((>=>))
 import Control.Monad.Reader (ReaderT(..))
 import Data.Codec.Field
+import Data.Functor ((<$))
 import Data.Functor.Compose
 import Data.Maybe (fromMaybe)
 import Data.Profunctor
+import Data.Traversable (traverse)
 
--- | De/serializer for the given types. Usually w ~ r, but they are separate
+-- | De/serializer for the given types. Usually `w ~ r`, but they are separate
 -- to allow for an `Applicative` instance.
 data Codec' fr fw w r = Codec
   { parse :: fr r
-  , produce :: w -> fw () 
+  , produce :: w -> fw r
   }
   deriving Functor
 
@@ -35,12 +38,21 @@ type Codec fr fw a = Codec' fr fw a a
 
 -- Build up a serializer in parallel to a deserializer.
 instance (Applicative fw, Applicative fr) => Applicative (Codec' fr fw w) where
-  pure x = Codec (pure x) (const $ pure ())
+  pure x = Codec (pure x) (const $ pure x)
   Codec f fw <*> Codec x xw
-    = Codec (f <*> x) (\w -> fw w *> xw w)
+    = Codec (f <*> x) (\w -> fw w <*> xw w)
+
+instance (Monad fw, Monad fr) => Monad (Codec' fr fw w) where
+  return x = Codec (return x) (const $ return x)
+  Codec a aw >>= f
+    = Codec (a >>= parse . f) (\w -> aw w >>= \a -> produce (f a) w)
+
+-- | Constructor of basic codecs.
+codec :: Functor fw => fr r -> (r -> fw ()) -> Codec fr fw r
+codec parse produce = Codec parse (\r -> r <$ produce r)
 
 -- | Associate a `Field` with a `Codec` to create a `Codec` `Build`.
-(>-<) :: Functor fr => Field r a x y -> Codec fr fw a -> Build r (Codec' fr fw r) x y
+(>-<) :: (Functor fr, Functor fw) => Field r a x y -> Codec fr fw a -> Build r (Codec' fr fw r) x y
 Field c g >-< Codec r w
   = Build (c <$> Codec r (w . g))
 
@@ -49,7 +61,7 @@ Field c g >-< Codec r w
 -- | Given a `Codec` for @a@, make one for `Maybe` @a@ that applies its deserializer optionally
 -- and does nothing when serializing `Nothing`.
 opt :: (Alternative fr, Applicative fw) => Codec fr fw a -> Codec fr fw (Maybe a)
-opt (Codec r w) = Codec (optional r) (maybe (pure ()) w)
+opt (Codec r w) = Codec (optional r) (traverse w)
 
 instance Functor fr => Profunctor (Codec' fr fw) where
   dimap from to (Codec r w)
@@ -63,10 +75,10 @@ mapCodec to from = dimap from to
 -- the results are still complementary.
 mapCodecM :: (Monad fr, Monad fw) => (a -> fr b) -> (b -> fw a) -> Codec fr fw a -> Codec fr fw b
 mapCodecM to from (Codec r w)
-  = Codec (r >>= to) (from >=> w)
+  = Codec (r >>= to) (\b -> from b >>= w >> return b)
 
 -- | Map the contexts of a given `Codec`.
-mapCodecF :: (fr a -> gr a) -> (fw () -> gw ()) -> Codec fr fw a -> Codec gr gw a
+mapCodecF :: (fr a -> gr a) -> (fw a -> gw a) -> Codec fr fw a -> Codec gr gw a
 mapCodecF fr fw (Codec r w)
   = Codec (fr r) (fw . w)
 
@@ -111,7 +123,7 @@ type PartialCodec fr fw a = Codec fr (Compose Maybe fw) a
 -- | Finish a codec construction with a @`Con` r@ to produce a `PartialCodec`.
 -- This will check that the given record has the appropriate constructor
 -- before serializing.
-cbuild :: (Functor fr, Buildable r y)
+cbuild :: (Functor fr, Functor fw, Buildable r y)
   => Con r x -> Build r (Codec' fr fw r) x y -> PartialCodec fr fw r
 cbuild (Con c p) = assume p . build c
 
@@ -134,6 +146,6 @@ cd <-> acd = Codec
 }
 
 -- | Attempt to get a serialization for a given value.
-produceMaybe :: PartialCodec fr fw a -> a -> Maybe (fw ())
+produceMaybe :: PartialCodec fr fw a -> a -> Maybe (fw a)
 produceMaybe (Codec _ w) x
   = getCompose (w x)

Foreign/Codec.hs

@@ -7,6 +7,7 @@ module Foreign.Codec
   ) where
 
 import Control.Monad.Reader
+import Data.Functor ((<$))
 import Foreign
 
 import Data.Codec.Codec
@@ -26,7 +27,7 @@ peekWith (Codec r _)
 -- | Poke a value using a `ForeignCodec'`.
 pokeWith :: ForeignCodec' p a -> Ptr p -> a -> IO ()
 pokeWith (Codec _ w) ptr x
-  = runReaderT (w x) ptr
+  = runReaderT (() <$ w x) ptr
 
 -- | A codec for a field of a foreign structure, given its byte offset and a sub-codec.
 -- You can get an offset easily using @{#offset struct_type, field}@ with @hsc2hs@.
@@ -38,7 +39,7 @@ field off cd = Codec
 
 -- | A `ForeignCodec` for any `Storable` type.
 storable :: Storable a => ForeignCodec a
-storable = Codec (ReaderT peek) (\x -> ReaderT (`poke`x))
+storable = codec (ReaderT peek) (\x -> ReaderT (`poke`x))
 
 castContext :: ForeignCodec' c a -> ForeignCodec' c' a
 castContext = mapCodecF castc castc
@@ -54,4 +55,4 @@ cBool = castContext storable
 
 -- | Restrict the pointer type of a given codec. Utility function for the @numField@ macro.
 codecFor :: c -> ForeignCodec' c a -> ForeignCodec' c a
-codecFor _ = id
+codecFor _ = id