diff --git a/Data/Aeson/Codec.hs b/Data/Aeson/Codec.hs index 9a439fa..8ef0c87 100644 --- a/Data/Aeson/Codec.hs +++ b/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. diff --git a/Data/Binary/Bits/Codec.hs b/Data/Binary/Bits/Codec.hs index 1f105e3..a4dee2a 100644 --- a/Data/Binary/Bits/Codec.hs +++ b/Data/Binary/Bits/Codec.hs @@ -10,6 +10,7 @@ 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 @@ -17,21 +18,21 @@ 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) diff --git a/Data/Binary/Codec.hs b/Data/Binary/Codec.hs index 157864d..822e9f8 100644 --- a/Data/Binary/Codec.hs +++ b/Data/Binary/Codec.hs @@ -27,42 +27,42 @@ 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 @@ -70,4 +70,4 @@ toLazyByteString (Codec r w) = concrete (\bs -> case runGetOrFail r bs of Left ( _ , _, err ) -> Left err Right ( _, _, x ) -> Right x) - (runPut . w) + (runPut . (>> return ()) . w) diff --git a/Data/Codec/Codec.hs b/Data/Codec/Codec.hs index aac4aef..1369f81 100644 --- a/Data/Codec/Codec.hs +++ b/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,24 +61,24 @@ 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 +instance (Functor fr, Functor fw) => Profunctor (Codec' fr fw) where dimap from to (Codec r w) - = Codec (to <$> r) (w . from) + = Codec (to <$> r) ((to <$>) . w . from) -- | Turn a @`Codec` a@ into a @`Codec` b@ by providing an isomorphism. -mapCodec :: Functor fr => (a -> b) -> (b -> a) -> Codec fr fw a -> Codec fr fw b +mapCodec :: (Functor fr, Functor fw) => (a -> b) -> (b -> a) -> Codec fr fw a -> Codec fr fw b mapCodec to from = dimap from to -- | Map a field codec monadically. Useful for error handling but care must be taken to make sure that -- 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) diff --git a/Foreign/Codec.hs b/Foreign/Codec.hs index 4b70446..dbb2aca 100644 --- a/Foreign/Codec.hs +++ b/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 \ No newline at end of file +codecFor _ = id