codec 0.1.1 → 0.2

raw patch · 24 files changed

+524/−1004 lines, 24 filesdep +codecdep +generic-arbitrarydep +profunctorsdep −data-default-classdep ~aesondep ~basedep ~binaryPVP ok

version bump matches the API change (PVP)

Dependencies added: codec, generic-arbitrary, profunctors, tasty, tasty-quickcheck, vector

Dependencies removed: data-default-class

Dependency ranges changed: aeson, base, binary, binary-bits, bytestring, mtl, template-haskell, text, transformers, unordered-containers

API changes (from Hackage documentation)

Files

• Data/Aeson/Codec.hs +0/−54
• Data/Binary/Bits/Codec.hs +0/−37
• Data/Binary/Codec.hs +0/−73
• Data/Codec.hs +0/−50
• Data/Codec/Codec.hs +0/−115
• Data/Codec/Field.hs +0/−68
• Data/Codec/TH.hs +0/−89
• Data/Codec/Testing.hs +0/−34
• Data/Codec/Tuple.hs +0/−32
• Examples/Foreign.hsc +0/−75
• Examples/IP.hs +0/−40
• Examples/JSON.hs +0/−31
• Examples/Multi.hs +0/−27
• Examples/Tar.hs +0/−78
• Foreign/Codec.hs +0/−57
• TestExamples.hs +0/−14
• codec.cabal +36/−130
• src/Control/Monad/Codec.hs +55/−0
• src/Data/Aeson/Codec.hs +130/−0
• src/Data/Binary/Bits/Codec.hs +42/−0
• src/Data/Binary/Codec.hs +101/−0
• test/Data/Aeson/Codec/Test.hs +73/−0
• test/Data/Binary/Codec/Test.hs +72/−0
• test/test.hs +15/−0

@@ -1,54 +0,0 @@-module Data.Aeson.Codec-  (-  -- * JSON codecs-     JSONCodec-  -- * JSON object codecs-  , ObjectParser, ObjectBuilder, ObjectCodec-  , entry, pair, obj-  ) where--import Control.Applicative-import Data.Aeson-import Data.Aeson.Types (Parser, Pair)-import Control.Monad.Reader-import Control.Monad.Writer-import Data.Default.Class-import qualified Data.Text as T-import Data.String--import Data.Codec---- | JSON codec. This is just a `ToJSON`/`FromJSON` implementation wrapped up in newtypes.--- Use `def` to get a `JSONCodec` for a `ToJSON`/`FromJSON` instance.-type JSONCodec a = ConcreteCodec Value Parser a--instance (ToJSON a, FromJSON a) => Default (JSONCodec a) where-  def = Codec (ReaderT parseJSON) (Const . toJSON)--type ObjectParser = ReaderT Object Parser-type ObjectBuilder = Const (Endo [ Pair ])---- | A codec that parses values out of a given `Object`, and produces--- key-value pairs into a new one.-type ObjectCodec a = Codec ObjectParser ObjectBuilder a---- | Produce a key-value pair.-pair :: ToJSON a => T.Text -> a -> ObjectBuilder ()-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.--- ObjectCodec's `IsString` instance is equal to `entry` `def`.-entry :: T.Text -> JSONCodec a -> ObjectCodec a-entry key cd = Codec-  { parse = ReaderT $ \o -> (o .: key) >>= parseVal cd-  , produce = pair key . produceVal cd-  }---- | Turn an `ObjectCodec` into a `JSONCodec` with an expected name (see `withObject`).-obj :: String -> ObjectCodec a -> JSONCodec a-obj err (Codec r w) = concrete-  (withObject err $ runReaderT r)-  (\x -> object $ appEndo (getConst $ w x) [])--instance (ToJSON a, FromJSON a) => IsString (ObjectCodec a) where-  fromString s = entry (fromString s) def

@@ -1,37 +0,0 @@-module Data.Binary.Bits.Codec-  ( BitCodec-  , bool-  , word8, word16be, word32be, word64be-  , toBytes-  )-where--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.Codec-import Data.Word--type BitCodec a = Codec G.Block BitPut a--bool :: BitCodec Bool-bool = Codec G.bool putBool--word8 :: Int -> BitCodec Word8-word8 = Codec <$> G.word8 <*> putWord8--word16be :: Int -> BitCodec Word16-word16be = Codec <$> G.word16be <*> putWord16be--word32be :: Int -> BitCodec Word32-word32be = Codec <$> G.word32be <*> putWord32be--word64be :: Int -> BitCodec Word64-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)

@@ -1,73 +0,0 @@-module Data.Binary.Codec-  (-  -- * Binary codecs-    BinaryCodec-  , byteString-  , toLazyByteString-  , word8-  , word16be, word16le, word16host-  , word32be, word32le, word32host-  , word64be, word64le, word64host-  , wordhost-  )- where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import Data.Binary.Get-import Data.Binary.Put-import Data.Word--import Data.Codec.Codec--type BinaryCodec a = Codec Get PutM a---- | Get/put an n-byte field.-byteString :: Int -> BinaryCodec BS.ByteString-byteString n = Codec-  { parse = getByteString n-  , produce = \bs -> if BS.length bs == n-      then putByteString bs-      else fail "ByteString wrong size for field."-  }--word8 :: BinaryCodec Word8-word8 = Codec getWord8 putWord8--word16be :: BinaryCodec Word16-word16be = Codec getWord16be putWord16be--word16le :: BinaryCodec Word16-word16le = Codec getWord16le putWord16le--word16host :: BinaryCodec Word16-word16host = Codec getWord16host putWord16host--word32be :: BinaryCodec Word32-word32be = Codec getWord32be putWord32be--word32le :: BinaryCodec Word32-word32le = Codec getWord32le putWord32le--word32host :: BinaryCodec Word32-word32host = Codec getWord32host putWord32host--word64be :: BinaryCodec Word64-word64be = Codec getWord64be putWord64be--word64le :: BinaryCodec Word64-word64le = Codec getWord64le putWord64le--word64host :: BinaryCodec Word64-word64host = Codec getWord64host putWord64host--wordhost :: BinaryCodec Word-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)

@@ -1,50 +0,0 @@-module Data.Codec (-  -- $constructing-    module Data.Codec.Field-  , module Data.Codec.Codec-  , module Data.Codec.TH-  , module Data.Codec.Tuple-  ) where--import Data.Codec.Field -import Data.Codec.Codec-import Data.Codec.TH-import Data.Codec.Tuple---- $constructing--- The main purpose of this package is to make the creation of `Codec`s as easy and painless as possible.--- If we have a data type such as:------ @--- data User = User---  { username :: Text---  , userEmail :: Text---  , userLanguages :: [ Text ]---  , userReferrer :: Maybe Text---  } deriving Show--- @------ we can use the `genFields` function to generate `Field`s for each record field:------ @--- genFields ''User--- @------ This will create `Field`s named @f_username@, @f_userEmail@, etc. These fields can be associated with an--- appropriate `Codec` with the `>-<` operator to specify the representation of the data structure. These--- associations can then be combined with the `>>>` operator in the order of serialization/deserialization.--- These associations can then be finalized into a `Codec` by providng the constructor to use.--- For example, using the JSON `entry` `Codec` that assigns a value to a JSON key, we could write a codec for--- @User@ as:------ @---  userCodec :: JSONCodec User---  userCodec = obj "user object' $---    User---      $>> f_username      >-< "user"---      >>> f_userEmail     >-< "email"---      >>> f_userLanguages >-< "languages"---      >>> f_userReferrer  >-< opt "referrer"--- @------ The type system ensures that every field is provided exactly once.

@@ -1,115 +0,0 @@-module Data.Codec.Codec-  ( -- * Codecs-    Codec'(..), Codec-  , (>-<)-    -- * Concrete codecs-  , ConcreteCodec, concrete, parseVal, produceVal-    -- * Partial codecs-    -- | Partial codecs are useful for creating codecs-    -- for types with multiple constructors. See @examples/Multi.hs@.-  , PartialCodec, cbuild, assume, covered, (<->), produceMaybe-    -- * Codec combinators-  , opt, mapCodec, mapCodecF, mapCodecM-  )-where--import Control.Applicative-import Control.Monad ((>=>))-import Control.Monad.Reader (ReaderT(..))-import Data.Codec.Field-import Data.Functor.Compose-import Data.Maybe (fromMaybe)---- | 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 () -  }-  deriving Functor---- | De/serializer for @a@.-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 ())-  Codec f fw <*> Codec x xw-    = Codec (f <*> x) (\w -> fw w *> xw w)---- | 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-Field c g >-< Codec r w-  = Build (c <$> Codec r (w . g))---- Codec combinators---- | 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)---- | 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 to from (Codec r w)-  = Codec (to <$> r) (w . from)---- | 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)---- | Map the contexts of a given `Codec`.-mapCodecF :: (fr a -> gr a) -> (fw () -> gw ()) -> Codec fr fw a -> Codec gr gw a-mapCodecF fr fw (Codec r w)-  = Codec (fr r) (fw . w)---- | A codec where `a` can be produced from a concrete value of `b` in context `f`,--- and a concrete type of value `b` can always be produced.-type ConcreteCodec b f a = Codec (ReaderT b f) (Const b) a---- | Create a concrete codec from a reader and a writer.-concrete :: (b -> f a) -> (a -> b) -> ConcreteCodec b f a-concrete r w = Codec (ReaderT r) (Const . w)---- | Parse a concrete value with a given `ConcreteCodec`.-parseVal :: ConcreteCodec b f a -> b -> f a-parseVal (Codec r _) = runReaderT r---- | Produce a concrete value with a given `ConcreteCodec`.-produceVal :: ConcreteCodec b f a -> a -> b-produceVal (Codec _ w) = getConst . w---- | A codec that can only serialize a subset of values.-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)-  => Con r x -> Build r (Codec' fr fw r) x y -> PartialCodec fr fw r-cbuild (Con c p) = assume p . build c---- | Guard a `Codec` with a predicate to create a `PartialCodec`.-assume :: (a -> Bool) -> Codec fr fw a -> PartialCodec fr fw a-assume p (Codec r w)-  = Codec r (\x -> Compose $ if p x then Just (w x) else Nothing)---- | Convert a `PartialCodec` into a `Codec`, throwing an error--- on values it cannot serialize.-covered :: PartialCodec fr fw a -> Codec fr fw a-covered cd-  = Codec (parse cd) (fromMaybe (error "Could not serialize value.") . produceMaybe cd)---- | Combine alternative `PartialCodec`s.-(<->) :: Alternative fr => PartialCodec fr fw a -> PartialCodec fr fw a -> PartialCodec fr fw a-cd <-> acd = Codec-  { parse = parse cd <|> parse acd-  , produce = \x -> Compose $ produceMaybe cd x <|> produceMaybe acd x-}---- | Attempt to get a serialization for a given value.-produceMaybe :: PartialCodec fr fw a -> a -> Maybe (fw ())-produceMaybe (Codec _ w) x-  = getCompose (w x)

@@ -1,68 +0,0 @@-module Data.Codec.Field-  ( -  -- * First-class record construction-    Field(..)-  , Build(..)-  , Con(..)-  , ($>>), (>>>), done-  , X(X), Buildable(..)-  , having, build-  ) where--import Control.Applicative-import Control.Category-import Prelude hiding ((.), id)---- | `Field`s partially apply constructors and replace arguments with this type.-data X = X---- | The class of constructor applications that have been completely filled in by composing--- `Build`s. If you see an error message involving this, it means that you forgot to specify--- a `Build` for a field.-class Buildable r a where-  give :: a -> r--instance Buildable r r where-  give = id--instance Buildable r b => Buildable r (X -> b) where-  give f = give $ f X---- | Describes how to apply a constructor argument and how to extract from a record.--- @y@ should be @x@ with one argument knocked out: e. g.------ @--- Field MyType Int (Int -> a2 -> MyType) (X -> a2 -> MyType)--- @-data Field r a x y = Field (a -> x -> y) (r -> a)---- Static (Backwards f) + phantom parameter--- | An ongoing record construction of an @r@ in context @f@.--- Applicative actions are sequenced in the direction of `>>>`.-newtype Build r f x y = Build (f (x -> y))---- | Combine a `Field` and a way to produce an @a@ to get a `Build`.-having :: Functor f => Field r a x y -> f a -> Build r f x y-having (Field c _) p = Build (c <$> p)---- | No-op `Build` (same as `id`).-done :: Applicative f => Build r f x x-done = id--instance Applicative f => Category (Build r f) where-  id = Build (pure id)-  Build f . Build g-    = Build ((>>>) <$> g <*> f)---- | Finish a construction given a constructor.-build :: (Functor f, Buildable r y) => x -> Build r f x y -> f r-build x (Build b)-  = (\f -> give $ f x) <$> b---- | Infix version of `build`.-($>>) :: (Functor f, Buildable r y) => x -> Build r f x y -> f r-($>>) = build-infixr 1 $>>---- | A constructor for a given record and a way to check whether it has it.-data Con r x = Con x (r -> Bool)

@@ -1,89 +0,0 @@-module Data.Codec.TH (genFields) where--import Control.Applicative-import Data.Foldable (foldl')-import Data.Traversable (for, traverse)-import Language.Haskell.TH as TH-import Language.Haskell.TH.Syntax as TH--import Data.Codec.Field as F--replaceAt :: a -> Int -> [ a ] -> [ a ]-replaceAt x i xs = pr ++ x : suf-  where ( pr, _ : suf ) = splitAt i xs--deleteAt :: Int -> [ a ] -> [ a ]-deleteAt i xs = pr ++ suf-  where ( pr, _ : suf ) = splitAt i xs--fun :: Type -> Type -> Type-fun x = AppT (AppT ArrowT x)--genField :: [ Name ] -> Type -> Int -> ( Int, VarStrictType ) -> Q [ Dec ]-genField recVars recType fc ( i, ( fn, _, ft ) ) = do-  polyNames <- for [1..fc] $ \j -> do-    let pn = "arg" ++ show j-    if any (\rv -> nameBase rv == pn) recVars-      then newName pn-      else return $ mkName pn-  let polyTypes = map VarT polyNames-      polyArgs = map (\j -> mkName $ "arg" ++ show j) [1..fc]-      fieldVars = map PlainTV $ recVars ++ deleteAt i polyNames-      fieldName = mkName ("f_" ++ nameBase fn)-      r = pure recType-      a = pure ft-      x = pure $ foldr fun recType $ replaceAt ft i polyTypes-      y = pure $ foldr fun recType $ replaceAt (ConT ''X) i polyTypes-      mkApplicator c v = pure $ LamE argPats app-        where-          app = foldl' AppE (VarE c) $ map VarE $ replaceAt v i polyArgs-          argPats = replaceAt WildP i $ map VarP polyArgs-      -- \c x -> \a1 -> .. \_ -> .. \an -> c a1 .. x .. an-      applicator = [|\v c -> $(mkApplicator 'c 'v)|]-      extractor = pure $ VarE fn-  fieldType <- ForallT fieldVars [] <$>-    [t|Field $r $a $x $y|]-  fieldBody <--    [|Field $applicator $extractor|]-  return [ SigD fieldName fieldType, ValD (VarP fieldName) (NormalB fieldBody) [] ]--genCon :: [ Name ] -> Type -> Int -> TH.Con -> Q [ Dec ]-genCon recVars recType cc-  = \case-    RecC cName fields -> genCon' cName fields-    NormalC cName [] -> genCon' cName []-    _ -> fail "Unsupported constructor."-  where-    genCon' cName fields = do-      let fieldTypes = [ ft | ( _, _, ft ) <- fields ]-          conName = mkName ("c_" ++ nameBase cName)-          cType = foldr fun recType fieldTypes-          conMatch-            | cc == 1 = [|const True|]-            | otherwise = [|\r -> $(mkConMatch 'r)|]-          mkConMatch r = pure $ CaseE (VarE r)-                         [ Match (RecP cName []) (NormalB (ConE 'True)) []-                         , Match WildP (NormalB (ConE 'False)) []-                         ]-          fc = length fields-      conType <- ForallT (map PlainTV recVars) [] <$> [t|F.Con $(pure recType) $(pure cType)|]-      conBody <- [|F.Con $(pure $ ConE cName) $conMatch|]-      fDecs <- traverse (genField recVars recType fc) $ zip [0..] fields-      return $-        [ SigD conName conType-        , ValD (VarP conName) (NormalB conBody) []-        ] ++ concat fDecs---- | Generate `Field`s for a given data type. Currently only single-constructor records are supported.--- Each record field @a@ will be turned into a `Field` @f_a@, and all constructors will be turned into `Con`s.-genFields :: Name -> Q [ Dec ]-genFields n = reify n >>= \case-  TyConI (DataD [] _ vs cs _) -> do-      recVars <- for vs $ \case-        PlainTV vn -> return vn-        KindedTV vn k | k == starK -> return vn-        _ -> fail "Only simple type variables supported."-      let recType = foldl' (\t v -> AppT t (VarT v)) (ConT n) recVars-          cc = length cs-      concat <$> traverse (genCon recVars recType cc) cs-  _ -> fail "Unsupported record type."

@@ -1,34 +0,0 @@-module Data.Codec.Testing-  ( -- * Testing-    ParseResult(..)-  , roundTrip, roundTripStorable-  )-where--import Data.Aeson.Types (Result(..))-import Data.Codec.Codec-import Foreign--class ParseResult f where-  toEither :: f a -> Either String a--instance ParseResult (Either String) where-  toEither = id--instance ParseResult Maybe where-  toEither = maybe (Left "Nothing") Right--instance ParseResult Result where-  toEither = \case-    Error err -> Left err-    Success x -> Right x---- | Round-trip a value through a `ConcreteCodec` to an `Either String a`.-roundTrip :: ParseResult f => ConcreteCodec c f a -> a -> Either String a-roundTrip cd-  = toEither . parseVal cd . produceVal cd---- | Round-trip a value through its `Storable` instance.-roundTripStorable :: Storable a => a -> IO a-roundTripStorable x-  = with x peek

@@ -1,32 +0,0 @@-module Data.Codec.Tuple-  ( Field1(..), Field2(..)-  , c_Left, c_Right, f_left, f_right-  ) where--import Data.Either--import Data.Codec.Field (Field(..), Con(..), X)--class Field1 r a x y | r x -> y, r y -> x, r -> a, x y -> r where-  f_1 :: Field r a x y--instance Field1 ( a, b ) a (a -> a2 -> ( a, b )) (X -> a2 -> ( a, b )) where-  f_1 = Field (\x c _ a2 -> c x a2) fst--class Field2 r a x y | r x -> y, r y -> x, r -> a, x y -> r where-  f_2 :: Field r a x y--instance Field2 ( a, b ) b (a1 -> b -> ( a, b )) (a1 -> X -> ( a, b )) where-  f_2 = Field (\x c a1 _ -> c a1 x) snd--c_Left :: Con (Either a b) (a -> Either a b)-c_Left = Con Left (\case { Left _ -> True; _ -> False })--c_Right :: Con (Either a b) (b -> Either a b)-c_Right = Con Right (\case { Right _ -> True; _ -> False })--f_left :: Field (Either a b) a (a -> Either a b) (X -> Either a b)-f_left = Field (\x c _ -> c x) (\(Left l) -> l)--f_right :: Field (Either a b) b (b -> Either a b) (X -> Either a b)-f_right = Field (\x c _ -> c x) (\(Right l) -> l)

@@ -1,75 +0,0 @@-module Examples.Foreign where--#include "time.h"--#let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)--import Foreign-import Foreign.C-import Data.Codec-import Foreign.Codec--data TM = TM-  { seconds :: Int-  , minutes :: Int-  , hours :: Int-  , monthDay :: Int-  , month :: Int-  , year :: Int-  , weekDay :: Int-  , yearDay :: Int-  , daylightSavingTime :: Bool-  } deriving Show--genFields ''TM---- convenience macro that enforces the correct codec type for a field-#define hsc_numField(s, f) \-  hsc_printf("field (%ld) . codecFor (undefined :: ", offsetof(s, f)); \-  hsc_type(typeof(((s*)0)->f)); \-  hsc_printf(")");--cTimeCodec :: ForeignCodec TM-cTimeCodec =-  TM-    $>> f_seconds            >-< (#numField struct tm, tm_sec)  cast-    >>> f_minutes            >-< (#numField struct tm, tm_min)  cast-    >>> f_hours              >-< (#numField struct tm, tm_hour) cast-    >>> f_monthDay           >-< (#numField struct tm, tm_mday) cast-    >>> f_month              >-< (#numField struct tm, tm_mon)  cast-    >>> f_year               >-< (#numField struct tm, tm_year) cast-    >>> f_weekDay            >-< (#numField struct tm, tm_wday) cast-    >>> f_yearDay            >-< (#numField struct tm, tm_yday) cast-    >>> f_daylightSavingTime >-< (#numField struct tm, tm_yday) cBool--instance Storable TM where-  sizeOf _ = #{size struct tm}-  alignment _ = #{alignment struct tm}-  peek = peekWith cTimeCodec-  poke = pokeWith cTimeCodec--foreign import ccall "time.h strftime" strftime-  :: CString -> CInt -> CString -> Ptr TM -> IO CSize--formatTM :: String -> TM -> IO String-formatTM fmt tm-  = allocaBytes maxSize $ \str -> do-      _ <- withCString fmt $ \cfmt ->-        with tm $ \tmp ->-          strftime str (fromIntegral maxSize) cfmt tmp-      peekCString str-  where-    maxSize = 512--testTime :: TM-testTime = TM-  { seconds = 42-  , minutes = 49-  , hours = 13-  , monthDay = 4-  , month = 4-  , year = 115-  , weekDay = 0-  , yearDay = 0-  , daylightSavingTime = False-  }

@@ -1,40 +0,0 @@-module Examples.IP where--import Data.Codec-import Data.Binary.Bits.Codec-import Data.Word--data IPv4 = IPv4-  { version :: Word8-  , ihl :: Word8-  , dscp :: Word8-  , ecn :: Word8-  , totalLength :: Word16-  , identification :: Word16-  , flags :: Word8-  , fragmentOffset :: Word16-  , timeToLive :: Word8-  , protocol :: Word8-  , headerChecksum :: Word16-  , sourceIP :: Word32-  , destIP :: Word32-  }--genFields ''IPv4--ipv4Codec :: BitCodec IPv4-ipv4Codec = -  IPv4-    $>> f_version        >-< word8 4-    >>> f_ihl            >-< word8 4-    >>> f_dscp           >-< word8 6-    >>> f_ecn            >-< word8 2-    >>> f_totalLength    >-< word16be 16-    >>> f_identification >-< word16be 16-    >>> f_flags          >-< word8 3-    >>> f_fragmentOffset >-< word16be 13-    >>> f_timeToLive     >-< word8 8-    >>> f_protocol       >-< word8 8-    >>> f_headerChecksum >-< word16be 16-    >>> f_sourceIP       >-< word32be 32-    >>> f_destIP         >-< word32be 32

@@ -1,31 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.JSON where--import Data.Aeson-import Data.Aeson.Codec-import Data.Codec-import Data.Text (Text)--data User = User-  { username :: Text-  , userEmail :: Text-  , userLanguages :: [ Text ]-  , userReferrer :: Maybe User-  } deriving Show--genFields ''User--userCodec :: JSONCodec User-userCodec = obj "user object" $-  User-    $>> f_username      >-< "user" -- entry with FromJSON/ToJSON serialization-    >>> f_userEmail     >-< "email"-    >>> f_userLanguages >-< "languages"-    >>> f_userReferrer  >-< opt (entry "referrer" userCodec) -- entry with specific codec--instance FromJSON User where-  parseJSON = parseVal userCodec--instance ToJSON User where-  toJSON = produceVal userCodec

@@ -1,27 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module Examples.Multi where--import Data.Aeson-import Data.Aeson.Codec-import Data.Codec--data Multi a-  = Con1 { foo :: String, bar :: Int }-  | Con2 { baz :: a }-  | Con3-  deriving Show--genFields ''Multi--multiCodec :: (ToJSON a, FromJSON a) => JSONCodec (Multi a)-multiCodec = obj "multi object" $ covered $ (-  cbuild c_Con1-    $   f_foo >-< "foo"-    >>> f_bar >-< "bar"-  ) <-> (-  cbuild c_Con2-    $ f_baz >-< "baz"-  ) <-> (-  cbuild c_Con3 done-  )

@@ -1,78 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}--module Examples.Tar where--import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Data.Codec-import Data.Word-import Data.Binary.Codec-import Numeric---- stolen from tar-conduit-data Header = Header {-    headerName :: B.ByteString, -- ^ 100 bytes long-    headerMode :: Word64,-    headerOwnerUID :: Word64,-    headerOwnerGID :: Word64,-    headerFileSize :: Integer, -- ^ 12 bytes-    headerModifyTime :: Integer, -- ^ 12 bytes-    headerChecksum :: Word64,-    headerType :: Word8, -- ^ 1 byte-    headerLinkName :: B.ByteString, -- ^ 100 bytes-    headerMagic :: B.ByteString, -- ^ 6 bytes-    headerVersion :: Word16,-    headerOwnerUserName :: B.ByteString, -- ^ 32 bytes-    headerOwnerGroupName :: B.ByteString, -- ^ 32 bytes-    headerDeviceMajorNumber :: Word64,-    headerDeviceMinorNumber :: Word64,-    headerFilenamePrefix :: B.ByteString -- ^ 155 bytes-    }-    deriving (Eq, Show, Read)--genFields ''Header---- easy peasy-headerCodec :: BinaryCodec Header-headerCodec =-  Header-    $>> f_headerName              >-< bytes' 100 -- Codec will de/serialize in this order-    >>> f_headerMode              >-< octal 8-    >>> f_headerOwnerUID          >-< octal 8-    >>> f_headerOwnerGID          >-< octal 8-    >>> f_headerFileSize          >-< octal 12-    >>> f_headerModifyTime        >-< octal 12-    >>> f_headerChecksum          >-< octal 8-    >>> f_headerType              >-< word8-    >>> f_headerLinkName          >-< bytes' 100-    >>> f_headerMagic             >-< bytes' 6-    >>> f_headerVersion           >-< octal 2-    >>> f_headerOwnerUserName     >-< bytes' 32-    >>> f_headerOwnerGroupName    >-< bytes' 32-    >>> f_headerDeviceMajorNumber >-< octal 8-    >>> f_headerDeviceMinorNumber >-< octal 8-    >>> f_headerFilenamePrefix    >-< bytes' 155---- byte field with trailing nulls stripped-bytes' :: Int -> BinaryCodec B.ByteString-bytes' n = mapCodecM trim pad (byteString n)-  where-    trim bs = return (fst $ B.spanEnd (==0) bs)-    pad bs-      | B.length bs <= n = return $ bs `B.append` B.replicate (n - B.length bs) 0-      | otherwise = fail "Serialized ByteString too large for field."---- zero-padded null/space-terminated ASCII octal-octal :: (Show i, Integral i) => Int -> BinaryCodec i-octal n = mapCodecM parseOct makeOct (byteString n)-  where-    parseOct bs-      | B.null trimmed = return 0-      | otherwise = case readOct (BC.unpack trimmed) of-          [ ( x, _ ) ] -> return x-          _ -> fail $ "Could not parse octal value: " ++ show bs-        where trimmed = BC.takeWhile (`notElem` " \NUL") bs-    makeOct x-      | B.length octBS > n - 1 = fail "Octal value too large for field."-      | otherwise = return $ BC.replicate (n - 1 - B.length octBS) '0' `B.append` octBS `B.snoc` 0-        where octBS = BC.pack $ showOct x ""

@@ -1,57 +0,0 @@-module Foreign.Codec-  ( -- * Foreign codecs-  ForeignContext, ForeignCodec, ForeignCodec'-  , peekWith, pokeWith, storable, field-  , cast, cBool-  , codecFor-  ) where--import Control.Monad.Reader-import Foreign--import Data.Codec.Codec--type ForeignContext a = ReaderT (Ptr a) IO--- | A foreign codec for @a@ given a pointer to @p@.-type ForeignCodec' p a = Codec (ForeignContext p) (ForeignContext p) a--- | A foreign codec for @a@ given a pointer to itself.--- Use `def` from `Default` to get a codec that uses a `Storable` instance,-type ForeignCodec a = ForeignCodec' a a---- | Peek a value using a `ForeignCodec'`.-peekWith :: ForeignCodec' p a -> Ptr p -> IO a-peekWith (Codec r _)-  = runReaderT r---- | Poke a value using a `ForeignCodec'`.-pokeWith :: ForeignCodec' p a -> Ptr p -> a -> IO ()-pokeWith (Codec _ w) ptr x-  = 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@.-field :: Int -> ForeignCodec' f a -> ForeignCodec' p a-field off cd = Codec-  { parse = inField $ parse cd-  , produce = inField . produce cd-  } where inField = withReaderT (`plusPtr` off)---- | A `ForeignCodec` for any `Storable` type.-storable :: Storable a => ForeignCodec a-storable = Codec (ReaderT peek) (\x -> ReaderT (`poke`x))--castContext :: ForeignCodec' c a -> ForeignCodec' c' a-castContext = mapCodecF castc castc-  where castc = withReaderT castPtr---- | Store any integral type.-cast :: (Integral c, Storable c, Integral a) => ForeignCodec' c a-cast = mapCodec fromIntegral fromIntegral storable---- | Store a `Bool` in any `Integral` `Ptr`.-cBool :: Integral c => ForeignCodec' c Bool-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

@@ -1,14 +0,0 @@-module Main where---- No testing yet, just check that the examples all build.--import Examples.Foreign-import Examples.IP-import Examples.JSON-import Examples.Multi-import Examples.Tar--import System.Exit--main :: IO ()-main = exitSuccess

@@ -1,83 +1,15 @@ name:                codec-version:             0.1.1+version:             0.2 license:             BSD3 license-file:        LICENSE-synopsis:            First-class record construction and bidirectional serialization-description:-  Tired of writing complementary @parseJSON@\/@toJSON@, @peek@\/@poke@ or-  Binary @get@\/@put@ functions?-  .-  @codec@ provides easy bidirectional serialization of plain Haskell-  records in any Applicative context. All you need to do is provide a-  de\/serializer for every record field in any order you like, and you get-  a de\/serializer for the whole structure. The type system ensures that-  you provide every record exactly once. It also includes a library for-  general record construction in an Applicative context, of which creating-  codecs is just one application.-  .-  JSON!-  .-  > userCodec :: JSONCodec User-  > userCodec = obj "user object" $-  > User-  >   $>> f_username      >-< "user"-  >   >>> f_userEmail     >-< "email"-  >   >>> f_userLanguages >-< "languages"-  >   >>> f_userReferrer  >-< opt "referrer"-  >-  > instance FromJSON User where-  >   parseJSON = parseVal userCodec-  >-  > instance ToJSON User where-  >   toJSON = produceVal userCodec-  .-  Bit fields!-  .-  > ipv4Codec :: BinaryCodec IPv4-  > ipv4Codec = toBytes $-  >   IPv4-  >     $>> f_version         >-< word8 4-  >     >>> f_ihl             >-< word8 4-  >     >>> f_dscp            >-< word8 6-  >     >>> f_ecn             >-< word8 2-  >     >>> f_totalLength     >-< word16be 16-  >     >>> f_identification  >-< word16be 16-  >     >>> f_flags           >-< word8 3-  >     >>> f_fragmentOffset  >-< word16be 13-  >     >>> f_timeToLive      >-< word8 8-  >     >>> f_protocol        >-< word8 8-  >     >>> f_headerChecksum  >-< word16be 16-  >     >>> f_sourceIP        >-< word32be 32-  >     >>> f_destIP          >-< word32be 32-  >-  > instance Binary IPv4 where-  >   get = parse ipv4Codec-  >   put = produce ipv4Codec-  .-  Storable!-  .-  > timeSpecCodec :: ForeignCodec TimeSpec-  > timeSpecCodec =-  >   TimeSpec-  >     $>> f_seconds     >-< field (#offset struct timespec, tv_sec)  cInt-  >     >>> f_nanoseconds >-< field (#offset struct timespec, tv_nsec) cInt-  >-  > instance Storable TimeSpec where-  >   peek = peekWith timeSpecCodec-  >   poke = pokeWith timeSpecCodec-  >   ...-  .-  All of these examples use the same types and logic for constructing-  Codecs, and it\'s very easy to create Codecs for any-  parsing\/serialization library.-  .-  See "Data.Codec" for an introduction.+synopsis:            Simple bidirectional serialization+description:         See README.md author:              Patrick Chilton maintainer:          chpatrick@gmail.com--- copyright:           +-- copyright: category:            Data build-type:          Simple--- extra-source-files:  +-- extra-source-files: cabal-version:       >=1.10 homepage:            https://github.com/chpatrick/codec @@ -86,65 +18,39 @@   location:            https://github.com/chpatrick/codec.git  library-  exposed-modules:     Data.Codec,-                       Data.Codec.Field,-                       Data.Codec.Codec,-                       Data.Codec.TH,-                       Data.Codec.Tuple,-                       Data.Codec.Testing,-+  exposed-modules:     Control.Monad.Codec,                        Data.Aeson.Codec,                        Data.Binary.Codec,-                       Data.Binary.Bits.Codec,-                       Foreign.Codec-  -- other-modules:       -  default-extensions:  TemplateHaskell,-                       MultiParamTypeClasses,-                       FlexibleContexts,-                       FlexibleInstances,-                       LambdaCase,-                       FunctionalDependencies,-                       DeriveFunctor,-                       ScopedTypeVariables-  build-depends:       base >=4.6 && < 4.9,-                       bytestring >=0.10,-                       binary >=0.7,-                       binary-bits >=0.5,-                       template-haskell >=2.8,-                       mtl >= 2.2.1,-                       aeson >= 0.8.0.2,-                       text >= 1.2.0.4,-                       unordered-containers >= 0.2.5.1,-                       data-default-class >= 0.0.1,-                       transformers >= 0.4.2.0-  -- hs-source-dirs:      +                       Data.Binary.Bits.Codec+  build-depends:       base >=4.6 && < 6,+                       bytestring,+                       binary,+                       binary-bits,+                       template-haskell,+                       mtl,+                       aeson >= 1.0.0.0,+                       text,+                       unordered-containers,+                       transformers,+                       profunctors,+                       vector+  hs-source-dirs:      src   default-language:    Haskell2010-  ghc-options:         -Wall -fno-warn-orphans+  ghc-options:         -Wall -test-suite Examples-  default-language:    Haskell2010+test-suite codec-tests   type:                exitcode-stdio-1.0-  main-is:             TestExamples.hs-  other-modules:       Examples.Foreign,-                       Examples.IP,-                       Examples.JSON,-                       Examples.Multi,-                       Examples.Tar-  build-depends:       base >=4.6,-                       bytestring >=0.10,-                       binary >=0.7,-                       binary-bits >=0.5,-                       template-haskell >=2.8,-                       mtl >= 2.2.1,-                       aeson >= 0.8.0.2,-                       text >= 1.2.0.4,-                       unordered-containers >= 0.2.5.1,-                       data-default-class >= 0.0.1,-                       transformers >= 0.4.2.0-  default-extensions:  TemplateHaskell,-                       MultiParamTypeClasses,-                       FlexibleInstances,-                       DeriveFunctor,-                       FunctionalDependencies,-                       LambdaCase,-                       ScopedTypeVariables+  hs-source-dirs:      test+  main-is:             test.hs+  other-modules:       Data.Aeson.Codec.Test+                       Data.Binary.Codec.Test+  build-depends:       base,+                       bytestring,+                       aeson,+                       codec,+                       tasty,+                       tasty-quickcheck,+                       generic-arbitrary,+                       binary+  ghc-options:         -Wall+  default-language:    Haskell2010

@@ -0,0 +1,55 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiParamTypeClasses #-}++module Control.Monad.Codec+  ( CodecFor(..)+  , Codec+  , (=.)+  , fmapArg+  ) where++import           Data.Profunctor++-- | A serializer/deserializer pair reading @a@ in context @r@ and writing @c@ in context @w@.+data CodecFor r w c a = Codec+  { codecIn :: r a+  , codecOut :: c -> w a+  } deriving (Functor)++type Codec r w a = CodecFor r w a a++instance (Applicative r, Applicative w) => Applicative (CodecFor r w c) where+  pure x = Codec+    { codecIn = pure x+    , codecOut = \_ -> pure x+    }+  f <*> x = Codec+    { codecIn = codecIn f <*> codecIn x+    , codecOut = \c -> codecOut f c <*> codecOut x c+    }++instance (Monad r, Monad w) => Monad (CodecFor r w c) where+  return = pure+  m >>= f = Codec+    { codecIn = codecIn m >>= \x -> codecIn (f x)+    , codecOut = \c -> codecOut m c >>= \x -> codecOut (f x) c+    }++instance (Functor r, Functor w) => Profunctor (CodecFor r w) where+  dimap fIn fOut Codec {..} = Codec+    { codecIn = fmap fOut codecIn+    , codecOut = fmap fOut . codecOut . fIn+    }++-- | Compose a function into the serializer of a `Codec`.+-- Useful to modify a `Codec` so that it writes a particular record field.+(=.) :: (c' -> c) -> CodecFor r w c a -> CodecFor r w c' a+fIn =. codec = codec { codecOut = codecOut codec . fIn }++-- | Modify a serializer function so that it also returns the serialized value,+-- Useful for implementing codecs.+fmapArg :: Functor f => (a -> f ()) -> a -> f a+fmapArg f x = x <$ f x

@@ -0,0 +1,130 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}++module Data.Aeson.Codec+  ( JSONCodec(..)+  , defJSON++  -- * JSON object codecs+  , ObjectParser, ObjectBuilder, ObjectCodec+  , field, field'+  , asObject++  -- * JSON array codecs+  , ArrayParser, ArrayBuilder, ArrayCodec+  , element, element'+  , asArray+  , arrayOf, arrayOf'+  ) where++import           Control.Monad.Codec+import           Data.Aeson+import           Data.Aeson.Encoding+import qualified Data.Aeson.Encoding.Internal as AEI+import           Data.Aeson.Types (Parser, Pair)+import           Control.Monad.Reader+import           Control.Monad.State+import           Control.Monad.Writer.Strict+import qualified Data.Text as T+import qualified Data.Vector as V++-- | Describes the de/serialization of a type @a@. Equivalent to a `ToJSON` and a `FromJSON` instance.+data JSONCodec a = JSONCodec+  { parseJSONCodec :: Value -> Parser a+  , toJSONCodec :: a -> Value+  , toEncodingCodec :: a -> Encoding+  }++-- | Encode/decode a value with its `ToJSON` and `FromJSON` instances.+defJSON :: (FromJSON a, ToJSON a) => JSONCodec a+defJSON = JSONCodec+  { parseJSONCodec = parseJSON+  , toJSONCodec = toJSON+  , toEncodingCodec = toEncoding+  }++type ObjectParser = ReaderT Object Parser+type ObjectBuilder = Writer ( Series, Endo [ Pair ] )++-- | A codec that parses values out of a given `Object`, and produces+-- key-value pairs into a new one.+type ObjectCodec a = Codec ObjectParser ObjectBuilder a++-- | Store/retrieve a value in a given JSON field, with a given JSONCodec.+field' :: T.Text -> JSONCodec a -> ObjectCodec a+field' key valCodec = Codec+  { codecIn = ReaderT $ \obj -> (obj .: key) >>= parseJSONCodec valCodec+  , codecOut = \val ->+    writer+      ( val+      , ( pair key (toEncodingCodec valCodec val)+        , Endo ((key .= toJSONCodec valCodec val) :)+        )+      )+  }++-- | Store/retrieve a value in a given JSON field, with the default JSON serialization.+field :: (FromJSON a, ToJSON a) => T.Text -> ObjectCodec a+field key = field' key defJSON++-- | Turn an `ObjectCodec` into a `JSONCodec` with an expected name (see `withObject`).+asObject :: String -> ObjectCodec a -> JSONCodec a+asObject err objCodec = JSONCodec+  { parseJSONCodec = withObject err (runReaderT (codecIn objCodec))+  , toJSONCodec = object . (`appEndo` []) . snd . execOut+  , toEncodingCodec = pairs . fst . execOut+  } where execOut = execWriter . codecOut objCodec++type ArrayParser = StateT [ Value ] Parser+type ArrayBuilder = Writer ( Series, [ Value ] )++-- | A codec that serializes data to a sequence of JSON array elements.+type ArrayCodec a = Codec ArrayParser ArrayBuilder a++-- | Expect/append an array element, using a given `JSONCodec`.+element' :: JSONCodec a -> ArrayCodec a+element' valCodec = Codec+  { codecIn = StateT $ \case+    [] -> fail "Expected an element, got an empty list."+    x : xs -> do+      val <- parseJSONCodec valCodec x+      return ( val, xs )++  , codecOut = \val -> writer ( val, ( AEI.Value $ AEI.retagEncoding $ toEncodingCodec valCodec val, [ toJSONCodec valCodec val ] ) )+  }++-- | Expect/append an array element, using the default serialization.+element :: (FromJSON a, ToJSON a) => ArrayCodec a+element = element' defJSON++-- | A codec that parses values out of a given `Array`, and produces+-- key-value pairs into a new one.+asArray :: String -> ArrayCodec a -> JSONCodec a+asArray err arrCodec = JSONCodec+  { parseJSONCodec = withArray err $ \arr -> do+      ( val, leftover ) <- runStateT (codecIn arrCodec) (V.toList arr)+      unless (null leftover) $ fail "Elements left over in parsed array."+      return val+  , toJSONCodec = Array . V.fromList . snd . execOut+  , toEncodingCodec = \val -> case fst (execOut val) of+      AEI.Empty -> emptyArray_+      AEI.Value enc -> AEI.wrapArray enc+  } where execOut = execWriter . codecOut arrCodec++-- | Given a `JSONCodec` for @b@ and a way to turn @a@ into @[ b ]@ and back,+-- create a `JSONCodec` for @a@.+arrayOf' :: (a -> [ b ]) -> ([ b ] -> a) -> JSONCodec b -> JSONCodec a+arrayOf' aToList listToA elemCodec = JSONCodec+  { parseJSONCodec = \arr -> do+      vals <- parseJSON arr+      parsedVals <- traverse (parseJSONCodec elemCodec) (vals :: [ Value ])+      return (listToA parsedVals)+  , toJSONCodec = Array . V.fromList . map (toJSONCodec elemCodec) . aToList+  , toEncodingCodec = AEI.list (toEncodingCodec elemCodec) . aToList+  }++-- | Given a a way to turn @a@ into @[ b ]@ and back, create a `JSONCodec` for @a@.+arrayOf :: (FromJSON b, ToJSON b) => (a -> [ b ]) -> ([ b ] -> a) -> JSONCodec a+arrayOf aToList listToA = arrayOf' aToList listToA defJSON

@@ -0,0 +1,42 @@+module Data.Binary.Bits.Codec+  ( BitCodec+  , bool+  , word8, word16be, word32be, word64be+  , toBytes+  )+where++import           Control.Monad+import           Control.Monad.Codec+import qualified Data.Binary.Bits.Get as G+import           Data.Binary.Bits.Put+import qualified Data.Binary.Codec as B++import           Data.Word++type BitCodec a = Codec G.Block BitPut a++bool :: BitCodec Bool+bool = Codec G.bool (fmapArg putBool)++bitCodec :: (Int -> G.Block a) -> (Int -> a -> BitPut ()) -> Int -> BitCodec a+bitCodec r w n = Codec (r n) (fmapArg (w n))++word8 :: Int -> BitCodec Word8+word8 = bitCodec G.word8 putWord8++word16be :: Int -> BitCodec Word16+word16be = bitCodec G.word16be putWord16be++word32be :: Int -> BitCodec Word32+word32be = bitCodec G.word32be putWord32be++word64be :: Int -> BitCodec Word64+word64be = bitCodec G.word64be putWord64be++-- | Convert a `BitCodec` into a `B.BinaryCodec`.+toBytes :: BitCodec a -> B.BinaryCodec a+toBytes c = Codec+  { codecIn = G.runBitGet $ G.block $ codecIn c+  , codecOut = fmapArg (runBitPut . void . codecOut c)+  }

@@ -0,0 +1,101 @@+module Data.Binary.Codec+  (+  -- * Binary codecs+    BinaryCodec+  , byteString+  , word8+  , word16be, word16le, word16host+  , word32be, word32le, word32host+  , word64be, word64le, word64host+  , wordhost+  , int8+  , int16be, int16le, int16host+  , int32be, int32le, int32host+  , int64be, int64le, int64host+  , inthost+  )+ where++import           Control.Monad.Codec+import qualified Data.ByteString as BS+import           Data.Binary.Get+import           Data.Binary.Put+import           Data.Int+import           Data.Word++type BinaryCodec a = Codec Get PutM a++-- | Get/put an n-byte field.+byteString :: Int -> BinaryCodec BS.ByteString+byteString n = Codec+  { codecIn = getByteString n+  , codecOut = \bs -> if BS.length bs == n+      then bs <$ putByteString bs+      else fail $ "Expected a ByteString of size " ++ show n+  }++word8 :: BinaryCodec Word8+word8 = Codec getWord8 (fmapArg putWord8)++word16be :: BinaryCodec Word16+word16be = Codec getWord16be (fmapArg putWord16be)++word16le :: BinaryCodec Word16+word16le = Codec getWord16le (fmapArg putWord16le)++word16host :: BinaryCodec Word16+word16host = Codec getWord16host (fmapArg putWord16host)++word32be :: BinaryCodec Word32+word32be = Codec getWord32be (fmapArg putWord32be)++word32le :: BinaryCodec Word32+word32le = Codec getWord32le (fmapArg putWord32le)++word32host :: BinaryCodec Word32+word32host = Codec getWord32host (fmapArg putWord32host)++word64be :: BinaryCodec Word64+word64be = Codec getWord64be (fmapArg putWord64be)++word64le :: BinaryCodec Word64+word64le = Codec getWord64le (fmapArg putWord64le)++word64host :: BinaryCodec Word64+word64host = Codec getWord64host (fmapArg putWord64host)++wordhost :: BinaryCodec Word+wordhost = Codec getWordhost (fmapArg putWordhost)++int8 :: BinaryCodec Int8+int8 = Codec getInt8 (fmapArg putInt8)++int16be :: BinaryCodec Int16+int16be = Codec getInt16be (fmapArg putInt16be)++int16le :: BinaryCodec Int16+int16le = Codec getInt16le (fmapArg putInt16le)++int16host :: BinaryCodec Int16+int16host = Codec getInt16host (fmapArg putInt16host)++int32be :: BinaryCodec Int32+int32be = Codec getInt32be (fmapArg putInt32be)++int32le :: BinaryCodec Int32+int32le = Codec getInt32le (fmapArg putInt32le)++int32host :: BinaryCodec Int32+int32host = Codec getInt32host (fmapArg putInt32host)++int64be :: BinaryCodec Int64+int64be = Codec getInt64be (fmapArg putInt64be)++int64le :: BinaryCodec Int64+int64le = Codec getInt64le (fmapArg putInt64le)++int64host :: BinaryCodec Int64+int64host = Codec getInt64host (fmapArg putInt64host)++inthost :: BinaryCodec Int+inthost = Codec getInthost (fmapArg putInthost)

@@ -0,0 +1,73 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Data.Aeson.Codec.Test+  ( aesonTests+  ) where++import           Data.Aeson+import           Data.Aeson.Encoding+import           Data.Aeson.Types+import           GHC.Generics (Generic)+import           Test.Tasty+import           Test.Tasty.QuickCheck+import           Test.QuickCheck.Arbitrary.Generic++import           Control.Monad.Codec+import           Data.Aeson.Codec++data RecordA = RecordA+  { recordAInt :: Int+  , recordANestedObj :: RecordB+  , recordANestedArr :: RecordB+  , recordANestedObjs :: [ RecordB ]+  } deriving (Eq, Ord, Show, Generic)++instance Arbitrary RecordA where+  arbitrary = genericArbitrary+  shrink = genericShrink++data RecordB = RecordB+  { recordBString :: String+  , recordBDouble :: Double+  } deriving (Eq, Ord, Show, Generic)++instance Arbitrary RecordB where+  arbitrary = genericArbitrary+  shrink = genericShrink++recordACodec :: JSONCodec RecordA+recordACodec = asObject "RecordA" $+  RecordA+    <$> recordAInt =. field "int"+    <*> recordANestedObj =. field' "nestedObj" recordBObjCodec+    <*> recordANestedArr =. field' "nestedArr" recordBArrCodec+    <*> recordANestedObjs =. field' "nestedObjs" (arrayOf' id id recordBObjCodec)++recordBObjCodec :: JSONCodec RecordB+recordBObjCodec = asObject "RecordB" $+  RecordB+    <$> recordBString =. field "string"+    <*> recordBDouble =. field "double"++recordBArrCodec :: JSONCodec RecordB+recordBArrCodec = asArray "RecordB" $+  RecordB+    <$> recordBString =. element+    <*> recordBDouble =. element++jsonRoundTrip :: (Eq a, Show a) => JSONCodec a -> a -> Property+jsonRoundTrip codec x = Right x === roundTripValue .&&. Right x === roundTripEncoding+  where+    roundTripValue = parseEither (parseJSONCodec codec) (toJSONCodec codec x)+    roundTripEncoding = do+      let bs = encodingToLazyByteString (toEncodingCodec codec x)+      val <- eitherDecode bs+      parseEither (parseJSONCodec codec) val++aesonTests :: TestTree+aesonTests = testGroup "Data.Aeson.Codec"+  [ testProperty "Complex" $ jsonRoundTrip recordACodec+  , testProperty "Object codec" $ jsonRoundTrip recordBObjCodec+  , testProperty "Array codec" $ jsonRoundTrip recordBArrCodec+  ]

@@ -0,0 +1,72 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}++module Data.Binary.Codec.Test+  ( binaryTests+  ) where++import           Control.Monad+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import           Data.Binary.Get (runGetOrFail)+import           Data.Binary.Put (runPutM)+import           Data.Int+import           Data.Word+import           GHC.Generics (Generic)+import           Test.Tasty+import           Test.Tasty.QuickCheck+import           Test.QuickCheck.Arbitrary.Generic++import           Control.Monad.Codec+import           Data.Binary.Codec++data RecordA = RecordA+  { recordAInt64 :: Int64+  , recordAWord8 :: Word8+  , recordANestedB :: RecordB+  } deriving (Eq, Ord, Show, Generic)++instance Arbitrary RecordA where+  arbitrary = genericArbitrary+  shrink = genericShrink++data RecordB = RecordB+  { recordBWord16 :: Word16+  , recordBByteString64 :: BS.ByteString+  } deriving (Eq, Ord, Show, Generic)++instance Arbitrary RecordB where+  arbitrary =+    RecordB+      <$> arbitrary+      <*> (BS.pack <$> (replicateM 64 arbitrary))+  shrink (RecordB word bs) =+    RecordB <$> shrink word <*> pure bs++recordACodec :: BinaryCodec RecordA+recordACodec =+  RecordA+    <$> recordAInt64 =. int64le+    <*> recordAWord8 =. word8+    <*> recordANestedB =. recordBCodec++recordBCodec :: BinaryCodec RecordB+recordBCodec =+  RecordB+    <$> recordBWord16 =. word16host+    <*> recordBByteString64 =. byteString 64++binaryRoundTrip :: (Eq a, Show a) => BinaryCodec a -> a -> Property+binaryRoundTrip codec x = Right x === roundTripValue+  where+    roundTripValue = do+      let ( _, encoded ) = runPutM (codecOut codec x)+      ( leftover, _, val ) <- runGetOrFail (codecIn codec) encoded+      unless (LBS.null leftover) $ fail "Codec produced leftover bytes."+      return val++binaryTests :: TestTree+binaryTests = testGroup "Data.Aeson.Codec"+  [ testProperty "Simple" $ binaryRoundTrip recordBCodec+  , testProperty "Nested" $ binaryRoundTrip recordACodec+  ]

@@ -0,0 +1,15 @@+import           Test.Tasty+import           Test.Tasty.Ingredients.Basic (consoleTestReporter)++import           Data.Aeson.Codec.Test+import           Data.Binary.Codec.Test++main :: IO ()+main = defaultMainWithIngredients [ consoleTestReporter ] allTests++allTests :: TestTree+allTests =+  testGroup "Codec"+    [ aesonTests+    , binaryTests+    ]