├── .gitignore ├── Setup.hs ├── test ├── test.hs └── Data │ ├── Binary │ └── Codec │ │ └── Test.hs │ └── Aeson │ └── Codec │ └── Test.hs ├── src ├── Data │ ├── Binary │ │ ├── Bits │ │ │ └── Codec.hs │ │ └── Codec.hs │ └── Aeson │ │ └── Codec.hs └── Control │ └── Monad │ └── Codec.hs ├── LICENSE ├── codec.cabal ├── stack.yaml ├── README.md └── .travis.yml /.gitignore: -------------------------------------------------------------------------------- 1 | cabal.sandbox.config 2 | dist/ 3 | .stack-work -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/test.hs: -------------------------------------------------------------------------------- 1 | import Test.Tasty 2 | import Test.Tasty.Ingredients.Basic (consoleTestReporter) 3 | 4 | import Data.Aeson.Codec.Test 5 | import Data.Binary.Codec.Test 6 | 7 | main :: IO () 8 | main = defaultMainWithIngredients [ consoleTestReporter ] allTests 9 | 10 | allTests :: TestTree 11 | allTests = 12 | testGroup "Codec" 13 | [ aesonTests 14 | , binaryTests 15 | ] 16 | -------------------------------------------------------------------------------- /src/Data/Binary/Bits/Codec.hs: -------------------------------------------------------------------------------- 1 | module Data.Binary.Bits.Codec 2 | ( BitCodec 3 | , bool 4 | , word8, word16be, word32be, word64be 5 | , toBytes 6 | ) 7 | where 8 | 9 | import Control.Monad 10 | import Control.Monad.Codec 11 | import qualified Data.Binary.Bits.Get as G 12 | import Data.Binary.Bits.Put 13 | import qualified Data.Binary.Codec as B 14 | 15 | import Data.Word 16 | 17 | type BitCodec a = Codec G.Block BitPut a 18 | 19 | bool :: BitCodec Bool 20 | bool = Codec G.bool (fmapArg putBool) 21 | 22 | bitCodec :: (Int -> G.Block a) -> (Int -> a -> BitPut ()) -> Int -> BitCodec a 23 | bitCodec r w n = Codec (r n) (fmapArg (w n)) 24 | 25 | word8 :: Int -> BitCodec Word8 26 | word8 = bitCodec G.word8 putWord8 27 | 28 | word16be :: Int -> BitCodec Word16 29 | word16be = bitCodec G.word16be putWord16be 30 | 31 | word32be :: Int -> BitCodec Word32 32 | word32be = bitCodec G.word32be putWord32be 33 | 34 | word64be :: Int -> BitCodec Word64 35 | word64be = bitCodec G.word64be putWord64be 36 | 37 | -- | Convert a `BitCodec` into a `B.BinaryCodec`. 38 | toBytes :: BitCodec a -> B.BinaryCodec a 39 | toBytes c = Codec 40 | { codecIn = G.runBitGet $ G.block $ codecIn c 41 | , codecOut = fmapArg (runBitPut . void . codecOut c) 42 | } 43 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2015, Patrick Chilton 2 | All rights reserved. 3 | 4 | Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 5 | 6 | 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 7 | 8 | 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 9 | 10 | 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. 11 | 12 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 13 | -------------------------------------------------------------------------------- /src/Control/Monad/Codec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RecordWildCards #-} 2 | {-# LANGUAGE DeriveFunctor #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE RankNTypes #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | 7 | module Control.Monad.Codec 8 | ( CodecFor(..) 9 | , Codec 10 | , (=.) 11 | , fmapArg 12 | ) where 13 | 14 | import Data.Profunctor 15 | 16 | -- | A serializer/deserializer pair reading @a@ in context @r@ and writing @c@ in context @w@. 17 | data CodecFor r w c a = Codec 18 | { codecIn :: r a 19 | , codecOut :: c -> w a 20 | } deriving (Functor) 21 | 22 | type Codec r w a = CodecFor r w a a 23 | 24 | instance (Applicative r, Applicative w) => Applicative (CodecFor r w c) where 25 | pure x = Codec 26 | { codecIn = pure x 27 | , codecOut = \_ -> pure x 28 | } 29 | f <*> x = Codec 30 | { codecIn = codecIn f <*> codecIn x 31 | , codecOut = \c -> codecOut f c <*> codecOut x c 32 | } 33 | 34 | instance (Monad r, Monad w) => Monad (CodecFor r w c) where 35 | return = pure 36 | m >>= f = Codec 37 | { codecIn = codecIn m >>= \x -> codecIn (f x) 38 | , codecOut = \c -> codecOut m c >>= \x -> codecOut (f x) c 39 | } 40 | 41 | instance (Functor r, Functor w) => Profunctor (CodecFor r w) where 42 | dimap fIn fOut Codec {..} = Codec 43 | { codecIn = fmap fOut codecIn 44 | , codecOut = fmap fOut . codecOut . fIn 45 | } 46 | 47 | -- | Compose a function into the serializer of a `Codec`. 48 | -- Useful to modify a `Codec` so that it writes a particular record field. 49 | (=.) :: (c' -> c) -> CodecFor r w c a -> CodecFor r w c' a 50 | fIn =. codec = codec { codecOut = codecOut codec . fIn } 51 | 52 | -- | Modify a serializer function so that it also returns the serialized value, 53 | -- Useful for implementing codecs. 54 | fmapArg :: Functor f => (a -> f ()) -> a -> f a 55 | fmapArg f x = x <$ f x 56 | -------------------------------------------------------------------------------- /codec.cabal: -------------------------------------------------------------------------------- 1 | name: codec 2 | version: 0.2.1 3 | license: BSD3 4 | license-file: LICENSE 5 | synopsis: Simple bidirectional serialization 6 | description: See the README 7 | author: Patrick Chilton 8 | maintainer: chpatrick@gmail.com 9 | -- copyright: 10 | category: Data 11 | build-type: Simple 12 | -- extra-source-files: 13 | cabal-version: >=1.10 14 | homepage: https://github.com/chpatrick/codec 15 | extra-source-files: README.md 16 | 17 | source-repository head 18 | type: git 19 | location: https://github.com/chpatrick/codec.git 20 | 21 | library 22 | exposed-modules: Control.Monad.Codec, 23 | Data.Aeson.Codec, 24 | Data.Binary.Codec, 25 | Data.Binary.Bits.Codec 26 | build-depends: base >=4.6 && < 6, 27 | bytestring, 28 | binary, 29 | binary-bits, 30 | template-haskell, 31 | mtl, 32 | aeson >= 1.0.0.0, 33 | text, 34 | unordered-containers, 35 | transformers, 36 | profunctors, 37 | vector 38 | hs-source-dirs: src 39 | default-language: Haskell2010 40 | ghc-options: -Wall 41 | 42 | test-suite codec-tests 43 | type: exitcode-stdio-1.0 44 | hs-source-dirs: test 45 | main-is: test.hs 46 | other-modules: Data.Aeson.Codec.Test 47 | Data.Binary.Codec.Test 48 | build-depends: base, 49 | bytestring, 50 | aeson, 51 | codec, 52 | tasty, 53 | tasty-quickcheck, 54 | generic-arbitrary, 55 | binary 56 | ghc-options: -Wall 57 | default-language: Haskell2010 -------------------------------------------------------------------------------- /test/Data/Binary/Codec/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Data.Binary.Codec.Test 5 | ( binaryTests 6 | ) where 7 | 8 | import Control.Monad 9 | import qualified Data.ByteString as BS 10 | import qualified Data.ByteString.Lazy as LBS 11 | import Data.Binary.Get (runGetOrFail) 12 | import Data.Binary.Put (runPutM) 13 | import Data.Int 14 | import Data.Word 15 | import GHC.Generics (Generic) 16 | import Test.Tasty 17 | import Test.Tasty.QuickCheck 18 | import Test.QuickCheck.Arbitrary.Generic 19 | 20 | import Control.Monad.Codec 21 | import Data.Binary.Codec 22 | 23 | data RecordA = RecordA 24 | { recordAInt64 :: Int64 25 | , recordAWord8 :: Word8 26 | , recordANestedB :: RecordB 27 | } deriving (Eq, Ord, Show, Generic) 28 | 29 | instance Arbitrary RecordA where 30 | arbitrary = genericArbitrary 31 | shrink = genericShrink 32 | 33 | data RecordB = RecordB 34 | { recordBWord16 :: Word16 35 | , recordBByteString64 :: BS.ByteString 36 | } deriving (Eq, Ord, Show, Generic) 37 | 38 | instance Arbitrary RecordB where 39 | arbitrary = 40 | RecordB 41 | <$> arbitrary 42 | <*> (BS.pack <$> (replicateM 64 arbitrary)) 43 | shrink (RecordB word bs) = 44 | RecordB <$> shrink word <*> pure bs 45 | 46 | recordACodec :: BinaryCodec RecordA 47 | recordACodec = 48 | RecordA 49 | <$> recordAInt64 =. int64le 50 | <*> recordAWord8 =. word8 51 | <*> recordANestedB =. recordBCodec 52 | 53 | recordBCodec :: BinaryCodec RecordB 54 | recordBCodec = 55 | RecordB 56 | <$> recordBWord16 =. word16host 57 | <*> recordBByteString64 =. byteString 64 58 | 59 | binaryRoundTrip :: (Eq a, Show a) => BinaryCodec a -> a -> Property 60 | binaryRoundTrip codec x = Right x === roundTripValue 61 | where 62 | roundTripValue = do 63 | let ( _, encoded ) = runPutM (codecOut codec x) 64 | ( leftover, _, val ) <- runGetOrFail (codecIn codec) encoded 65 | unless (LBS.null leftover) $ fail "Codec produced leftover bytes." 66 | return val 67 | 68 | binaryTests :: TestTree 69 | binaryTests = testGroup "Data.Aeson.Codec" 70 | [ testProperty "Simple" $ binaryRoundTrip recordBCodec 71 | , testProperty "Nested" $ binaryRoundTrip recordACodec 72 | ] 73 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by 'stack init' 2 | # 3 | # Some commonly used options have been documented as comments in this file. 4 | # For advanced use and comprehensive documentation of the format, please see: 5 | # http://docs.haskellstack.org/en/stable/yaml_configuration/ 6 | 7 | # Resolver to choose a 'specific' stackage snapshot or a compiler version. 8 | # A snapshot resolver dictates the compiler version and the set of packages 9 | # to be used for project dependencies. For example: 10 | # 11 | # resolver: lts-3.5 12 | # resolver: nightly-2015-09-21 13 | # resolver: ghc-7.10.2 14 | # resolver: ghcjs-0.1.0_ghc-7.10.2 15 | # resolver: 16 | # name: custom-snapshot 17 | # location: "./custom-snapshot.yaml" 18 | resolver: lts-8.9 19 | 20 | # User packages to be built. 21 | # Various formats can be used as shown in the example below. 22 | # 23 | # packages: 24 | # - some-directory 25 | # - https://example.com/foo/bar/baz-0.0.2.tar.gz 26 | # - location: 27 | # git: https://github.com/commercialhaskell/stack.git 28 | # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a 29 | # - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a 30 | # extra-dep: true 31 | # subdirs: 32 | # - auto-update 33 | # - wai 34 | # 35 | # A package marked 'extra-dep: true' will only be built if demanded by a 36 | # non-dependency (i.e. a user package), and its test suites and benchmarks 37 | # will not be run. This is useful for tweaking upstream packages. 38 | packages: 39 | - '.' 40 | # Dependency packages to be pulled from upstream that are not in the resolver 41 | # (e.g., acme-missiles-0.3) 42 | extra-deps: 43 | - generic-arbitrary-0.1.0 44 | 45 | # Override default flag values for local packages and extra-deps 46 | flags: {} 47 | 48 | # Extra package databases containing global packages 49 | extra-package-dbs: [] 50 | 51 | # Control whether we use the GHC we find on the path 52 | # system-ghc: true 53 | # 54 | # Require a specific version of stack, using version ranges 55 | # require-stack-version: -any # Default 56 | # require-stack-version: ">=1.2" 57 | # 58 | # Override the architecture used by stack, especially useful on Windows 59 | # arch: i386 60 | # arch: x86_64 61 | # 62 | # Extra directories used by stack for building 63 | # extra-include-dirs: [/path/to/dir] 64 | # extra-lib-dirs: [/path/to/dir] 65 | # 66 | # Allow a newer minor version of GHC than the snapshot specifies 67 | # compiler-check: newer-minor -------------------------------------------------------------------------------- /test/Data/Aeson/Codec/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | 4 | module Data.Aeson.Codec.Test 5 | ( aesonTests 6 | ) where 7 | 8 | import Data.Aeson 9 | import Data.Aeson.Encoding 10 | import Data.Aeson.Types 11 | import GHC.Generics (Generic) 12 | import Test.Tasty 13 | import Test.Tasty.QuickCheck 14 | import Test.QuickCheck.Arbitrary.Generic 15 | 16 | import Control.Monad.Codec 17 | import Data.Aeson.Codec 18 | 19 | data RecordA = RecordA 20 | { recordAInt :: Int 21 | , recordANestedObj :: RecordB 22 | , recordANestedArr :: RecordB 23 | , recordANestedObjs :: [ RecordB ] 24 | } deriving (Eq, Ord, Show, Generic) 25 | 26 | instance Arbitrary RecordA where 27 | arbitrary = genericArbitrary 28 | shrink = genericShrink 29 | 30 | data RecordB = RecordB 31 | { recordBString :: String 32 | , recordBDouble :: Double 33 | } deriving (Eq, Ord, Show, Generic) 34 | 35 | instance Arbitrary RecordB where 36 | arbitrary = genericArbitrary 37 | shrink = genericShrink 38 | 39 | recordACodec :: JSONCodec RecordA 40 | recordACodec = asObject "RecordA" $ 41 | RecordA 42 | <$> recordAInt =. field "int" 43 | <*> recordANestedObj =. field' "nestedObj" recordBObjCodec 44 | <*> recordANestedArr =. field' "nestedArr" recordBArrCodec 45 | <*> recordANestedObjs =. field' "nestedObjs" (arrayOf' id id recordBObjCodec) 46 | 47 | recordBObjCodec :: JSONCodec RecordB 48 | recordBObjCodec = asObject "RecordB" $ 49 | RecordB 50 | <$> recordBString =. field "string" 51 | <*> recordBDouble =. field "double" 52 | 53 | recordBArrCodec :: JSONCodec RecordB 54 | recordBArrCodec = asArray "RecordB" $ 55 | RecordB 56 | <$> recordBString =. element 57 | <*> recordBDouble =. element 58 | 59 | jsonRoundTrip :: (Eq a, Show a) => JSONCodec a -> a -> Property 60 | jsonRoundTrip codec x = Right x === roundTripValue .&&. Right x === roundTripEncoding 61 | where 62 | roundTripValue = parseEither (parseJSONCodec codec) (toJSONCodec codec x) 63 | roundTripEncoding = do 64 | let bs = encodingToLazyByteString (toEncodingCodec codec x) 65 | val <- eitherDecode bs 66 | parseEither (parseJSONCodec codec) val 67 | 68 | aesonTests :: TestTree 69 | aesonTests = testGroup "Data.Aeson.Codec" 70 | [ testProperty "Complex" $ jsonRoundTrip recordACodec 71 | , testProperty "Object codec" $ jsonRoundTrip recordBObjCodec 72 | , testProperty "Array codec" $ jsonRoundTrip recordBArrCodec 73 | ] 74 | -------------------------------------------------------------------------------- /src/Data/Binary/Codec.hs: -------------------------------------------------------------------------------- 1 | module Data.Binary.Codec 2 | ( 3 | -- * Binary codecs 4 | BinaryCodec 5 | , byteString 6 | , word8 7 | , word16be, word16le, word16host 8 | , word32be, word32le, word32host 9 | , word64be, word64le, word64host 10 | , wordhost 11 | , int8 12 | , int16be, int16le, int16host 13 | , int32be, int32le, int32host 14 | , int64be, int64le, int64host 15 | , inthost 16 | ) 17 | where 18 | 19 | import Control.Monad.Codec 20 | import qualified Data.ByteString as BS 21 | import Data.Binary.Get 22 | import Data.Binary.Put 23 | import Data.Int 24 | import Data.Word 25 | 26 | type BinaryCodec a = Codec Get PutM a 27 | 28 | -- | Get/put an n-byte field. 29 | byteString :: Int -> BinaryCodec BS.ByteString 30 | byteString n = Codec 31 | { codecIn = getByteString n 32 | , codecOut = \bs -> if BS.length bs == n 33 | then bs <$ putByteString bs 34 | else fail $ "Expected a ByteString of size " ++ show n 35 | } 36 | 37 | word8 :: BinaryCodec Word8 38 | word8 = Codec getWord8 (fmapArg putWord8) 39 | 40 | word16be :: BinaryCodec Word16 41 | word16be = Codec getWord16be (fmapArg putWord16be) 42 | 43 | word16le :: BinaryCodec Word16 44 | word16le = Codec getWord16le (fmapArg putWord16le) 45 | 46 | word16host :: BinaryCodec Word16 47 | word16host = Codec getWord16host (fmapArg putWord16host) 48 | 49 | word32be :: BinaryCodec Word32 50 | word32be = Codec getWord32be (fmapArg putWord32be) 51 | 52 | word32le :: BinaryCodec Word32 53 | word32le = Codec getWord32le (fmapArg putWord32le) 54 | 55 | word32host :: BinaryCodec Word32 56 | word32host = Codec getWord32host (fmapArg putWord32host) 57 | 58 | word64be :: BinaryCodec Word64 59 | word64be = Codec getWord64be (fmapArg putWord64be) 60 | 61 | word64le :: BinaryCodec Word64 62 | word64le = Codec getWord64le (fmapArg putWord64le) 63 | 64 | word64host :: BinaryCodec Word64 65 | word64host = Codec getWord64host (fmapArg putWord64host) 66 | 67 | wordhost :: BinaryCodec Word 68 | wordhost = Codec getWordhost (fmapArg putWordhost) 69 | 70 | int8 :: BinaryCodec Int8 71 | int8 = Codec getInt8 (fmapArg putInt8) 72 | 73 | int16be :: BinaryCodec Int16 74 | int16be = Codec getInt16be (fmapArg putInt16be) 75 | 76 | int16le :: BinaryCodec Int16 77 | int16le = Codec getInt16le (fmapArg putInt16le) 78 | 79 | int16host :: BinaryCodec Int16 80 | int16host = Codec getInt16host (fmapArg putInt16host) 81 | 82 | int32be :: BinaryCodec Int32 83 | int32be = Codec getInt32be (fmapArg putInt32be) 84 | 85 | int32le :: BinaryCodec Int32 86 | int32le = Codec getInt32le (fmapArg putInt32le) 87 | 88 | int32host :: BinaryCodec Int32 89 | int32host = Codec getInt32host (fmapArg putInt32host) 90 | 91 | int64be :: BinaryCodec Int64 92 | int64be = Codec getInt64be (fmapArg putInt64be) 93 | 94 | int64le :: BinaryCodec Int64 95 | int64le = Codec getInt64le (fmapArg putInt64le) 96 | 97 | int64host :: BinaryCodec Int64 98 | int64host = Codec getInt64host (fmapArg putInt64host) 99 | 100 | inthost :: BinaryCodec Int 101 | inthost = Codec getInthost (fmapArg putInthost) 102 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Codec [![Build Status](https://travis-ci.org/chpatrick/codec.svg?branch=master)](https://travis-ci.org/chpatrick/codec) [![Hackage](https://img.shields.io/hackage/v/codec.svg)](http://hackage.haskell.org/package/codec) 2 | 3 | Codec makes it simple to write composable bidirectional serializers with a consistent interface. 4 | 5 | Just define your data type normally: 6 | 7 | ```haskell 8 | data RecordB = RecordB 9 | { recordBString :: String 10 | , recordBDouble :: Double 11 | } deriving (Eq, Ord, Show) 12 | ``` 13 | 14 | and then associate each field with a codec using the `=.` operator: 15 | 16 | ```haskell 17 | recordBObjCodec :: JSONCodec RecordB 18 | recordBObjCodec = asObject "RecordB" $ 19 | RecordB 20 | <$> recordBString =. field "string" 21 | <*> recordBDouble =. field "double" 22 | ``` 23 | 24 | That's it! If you want, you can now define `ToJSON` and `FromJSON` instances, or just use it directly: 25 | 26 | ```haskell 27 | instance ToJSON RecordB where 28 | toJSON = toJSONCodec recordBObjCodec 29 | toEncoding = toEncodingCodec recordBObjCodec 30 | 31 | instance FromJSON RecordB where 32 | parseJSON = parseJSONCodec recordBObjCodec 33 | ``` 34 | 35 | Support can be added for almost any serialization library, but `aeson` and `binary` support are included. 36 | 37 | JSON example: 38 | ```haskell 39 | data RecordA = RecordA 40 | { recordAInt :: Int 41 | , recordANestedObj :: RecordB 42 | , recordANestedArr :: RecordB 43 | , recordANestedObjs :: [ RecordB ] 44 | } deriving (Eq, Ord, Show) 45 | 46 | data RecordB = RecordB 47 | { recordBString :: String 48 | , recordBDouble :: Double 49 | } deriving (Eq, Ord, Show) 50 | 51 | recordACodec :: JSONCodec RecordA 52 | recordACodec = asObject "RecordA" $ 53 | RecordA 54 | <$> recordAInt =. field "int" 55 | <*> recordANestedObj =. field' "nestedObj" recordBObjCodec 56 | <*> recordANestedArr =. field' "nestedArr" recordBArrCodec 57 | <*> recordANestedObjs =. field' "nestedObjs" (arrayOf' id id recordBObjCodec) 58 | 59 | recordBObjCodec :: JSONCodec RecordB 60 | recordBObjCodec = asObject "RecordB" $ 61 | RecordB 62 | <$> recordBString =. field "string" 63 | <*> recordBDouble =. field "double" 64 | 65 | -- serialize to array elements 66 | recordBArrCodec :: JSONCodec RecordB 67 | recordBArrCodec = asArray "RecordB" $ 68 | RecordB 69 | <$> recordBString =. element 70 | <*> recordBDouble =. element 71 | ``` 72 | 73 | Binary example: 74 | ```haskell 75 | data RecordA = RecordA 76 | { recordAInt64 :: Int64 77 | , recordAWord8 :: Word8 78 | , recordANestedB :: RecordB 79 | } deriving (Eq, Ord, Show) 80 | 81 | data RecordB = RecordB 82 | { recordBWord16 :: Word16 83 | , recordBByteString64 :: BS.ByteString 84 | } deriving (Eq, Ord, Show) 85 | 86 | recordACodec :: BinaryCodec RecordA 87 | recordACodec = 88 | RecordA 89 | <$> recordAInt64 =. int64le 90 | <*> recordAWord8 =. word8 91 | <*> recordANestedB =. recordBCodec 92 | 93 | recordBCodec :: BinaryCodec RecordB 94 | recordBCodec = 95 | RecordB 96 | <$> recordBWord16 =. word16host 97 | <*> recordBByteString64 =. byteString 64 98 | ``` 99 | 100 | A `Codec` is just a combination of a deserializer `r a`, and a serializer `c -> w a`. 101 | ```haskell 102 | data CodecFor r w c a = Codec 103 | { codecIn :: r a 104 | , codecOut :: c -> w a 105 | } 106 | 107 | type Codec r w a = CodecFor r w a a 108 | ``` 109 | With `binary` for example, `r` is `Get` and `w` is `PutM`. The reason we have an extra parameter `c` is so that we can associate a `Codec` with a particular field using the `=.` operator: 110 | 111 | `(=.) :: (c' -> c) -> CodecFor r w c a -> CodecFor r w c' a` 112 | 113 | `Codec` is an instance of `Functor`, `Applicative`, `Monad` and `Profunctor`. You can serialize in any order you like, regardless of field order in the data type: 114 | 115 | ```haskell 116 | recordBCodecFlipped :: BinaryCodec RecordB 117 | recordBCodecFlipped = do 118 | bs64 <- recordBByteString64 =. byteString 64 119 | RecordB 120 | <$> recordBWord16 =. word16host 121 | <*> pure bs64 122 | ``` 123 | 124 | ### Contributors 125 | 126 | `=.` operator and `Profunctor` approach thanks to [Xia Li-yao](https://github.com/lysxia) 127 | -------------------------------------------------------------------------------- /src/Data/Aeson/Codec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE LambdaCase #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | 6 | module Data.Aeson.Codec 7 | ( JSONCodec(..) 8 | , defJSON 9 | 10 | -- * JSON object codecs 11 | , ObjectParser, ObjectBuilder, ObjectCodec 12 | , field, field' 13 | , asObject 14 | 15 | -- * JSON array codecs 16 | , ArrayParser, ArrayBuilder, ArrayCodec 17 | , element, element' 18 | , asArray 19 | , arrayOf, arrayOf' 20 | ) where 21 | 22 | import Control.Monad.Codec 23 | import Data.Aeson 24 | import Data.Aeson.Encoding 25 | import qualified Data.Aeson.Encoding.Internal as AEI 26 | import Data.Aeson.Types (Parser, Pair) 27 | import Control.Monad.Reader 28 | import Control.Monad.State 29 | import Control.Monad.Writer.Strict 30 | import qualified Data.Text as T 31 | import qualified Data.Vector as V 32 | 33 | -- | Describes the de/serialization of a type @a@. Equivalent to a `ToJSON` and a `FromJSON` instance. 34 | data JSONCodec a = JSONCodec 35 | { parseJSONCodec :: Value -> Parser a 36 | , toJSONCodec :: a -> Value 37 | , toEncodingCodec :: a -> Encoding 38 | } 39 | 40 | -- | Encode/decode a value with its `ToJSON` and `FromJSON` instances. 41 | defJSON :: (FromJSON a, ToJSON a) => JSONCodec a 42 | defJSON = JSONCodec 43 | { parseJSONCodec = parseJSON 44 | , toJSONCodec = toJSON 45 | , toEncodingCodec = toEncoding 46 | } 47 | 48 | type ObjectParser = ReaderT Object Parser 49 | type ObjectBuilder = Writer ( Series, Endo [ Pair ] ) 50 | 51 | -- | A codec that parses values out of a given `Object`, and produces 52 | -- key-value pairs into a new one. 53 | type ObjectCodec a = Codec ObjectParser ObjectBuilder a 54 | 55 | -- | Store/retrieve a value in a given JSON field, with a given JSONCodec. 56 | field' :: T.Text -> JSONCodec a -> ObjectCodec a 57 | field' key valCodec = Codec 58 | { codecIn = ReaderT $ \obj -> (obj .: key) >>= parseJSONCodec valCodec 59 | , codecOut = \val -> 60 | writer 61 | ( val 62 | , ( pair key (toEncodingCodec valCodec val) 63 | , Endo ((key .= toJSONCodec valCodec val) :) 64 | ) 65 | ) 66 | } 67 | 68 | -- | Store/retrieve a value in a given JSON field, with the default JSON serialization. 69 | field :: (FromJSON a, ToJSON a) => T.Text -> ObjectCodec a 70 | field key = field' key defJSON 71 | 72 | -- | Turn an `ObjectCodec` into a `JSONCodec` with an expected name (see `withObject`). 73 | asObject :: String -> ObjectCodec a -> JSONCodec a 74 | asObject err objCodec = JSONCodec 75 | { parseJSONCodec = withObject err (runReaderT (codecIn objCodec)) 76 | , toJSONCodec = object . (`appEndo` []) . snd . execOut 77 | , toEncodingCodec = pairs . fst . execOut 78 | } where execOut = execWriter . codecOut objCodec 79 | 80 | type ArrayParser = StateT [ Value ] Parser 81 | type ArrayBuilder = Writer ( Series, [ Value ] ) 82 | 83 | -- | A codec that serializes data to a sequence of JSON array elements. 84 | type ArrayCodec a = Codec ArrayParser ArrayBuilder a 85 | 86 | -- | Expect/append an array element, using a given `JSONCodec`. 87 | element' :: JSONCodec a -> ArrayCodec a 88 | element' valCodec = Codec 89 | { codecIn = StateT $ \case 90 | [] -> fail "Expected an element, got an empty list." 91 | x : xs -> do 92 | val <- parseJSONCodec valCodec x 93 | return ( val, xs ) 94 | 95 | , codecOut = \val -> writer ( val, ( AEI.Value $ AEI.retagEncoding $ toEncodingCodec valCodec val, [ toJSONCodec valCodec val ] ) ) 96 | } 97 | 98 | -- | Expect/append an array element, using the default serialization. 99 | element :: (FromJSON a, ToJSON a) => ArrayCodec a 100 | element = element' defJSON 101 | 102 | -- | A codec that parses values out of a given `Array`, and produces 103 | -- key-value pairs into a new one. 104 | asArray :: String -> ArrayCodec a -> JSONCodec a 105 | asArray err arrCodec = JSONCodec 106 | { parseJSONCodec = withArray err $ \arr -> do 107 | ( val, leftover ) <- runStateT (codecIn arrCodec) (V.toList arr) 108 | unless (null leftover) $ fail "Elements left over in parsed array." 109 | return val 110 | , toJSONCodec = Array . V.fromList . snd . execOut 111 | , toEncodingCodec = \val -> case fst (execOut val) of 112 | AEI.Empty -> emptyArray_ 113 | AEI.Value enc -> AEI.wrapArray enc 114 | } where execOut = execWriter . codecOut arrCodec 115 | 116 | -- | Given a `JSONCodec` for @b@ and a way to turn @a@ into @[ b ]@ and back, 117 | -- create a `JSONCodec` for @a@. 118 | arrayOf' :: (a -> [ b ]) -> ([ b ] -> a) -> JSONCodec b -> JSONCodec a 119 | arrayOf' aToList listToA elemCodec = JSONCodec 120 | { parseJSONCodec = \arr -> do 121 | vals <- parseJSON arr 122 | parsedVals <- traverse (parseJSONCodec elemCodec) (vals :: [ Value ]) 123 | return (listToA parsedVals) 124 | , toJSONCodec = Array . V.fromList . map (toJSONCodec elemCodec) . aToList 125 | , toEncodingCodec = AEI.list (toEncodingCodec elemCodec) . aToList 126 | } 127 | 128 | -- | Given a a way to turn @a@ into @[ b ]@ and back, create a `JSONCodec` for @a@. 129 | arrayOf :: (FromJSON b, ToJSON b) => (a -> [ b ]) -> ([ b ] -> a) -> JSONCodec a 130 | arrayOf aToList listToA = arrayOf' aToList listToA defJSON -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This is the complex Travis configuration, which is intended for use 2 | # on open source libraries which need compatibility across multiple GHC 3 | # versions, must work with cabal-install, and should be 4 | # cross-platform. For more information and other options, see: 5 | # 6 | # https://docs.haskellstack.org/en/stable/travis_ci/ 7 | # 8 | # Copy these contents into the root directory of your Github project in a file 9 | # named .travis.yml 10 | 11 | # Use new container infrastructure to enable caching 12 | sudo: false 13 | 14 | # Do not choose a language; we provide our own build tools. 15 | language: generic 16 | 17 | # Caching so the next build will be fast too. 18 | cache: 19 | directories: 20 | - $HOME/.ghc 21 | - $HOME/.cabal 22 | - $HOME/.stack 23 | 24 | # The different configurations we want to test. We have BUILD=cabal which uses 25 | # cabal-install, and BUILD=stack which uses Stack. More documentation on each 26 | # of those below. 27 | # 28 | # We set the compiler values here to tell Travis to use a different 29 | # cache file per set of arguments. 30 | # 31 | # If you need to have different apt packages for each combination in the 32 | # matrix, you can use a line such as: 33 | # addons: {apt: {packages: [libfcgi-dev,libgmp-dev]}} 34 | matrix: 35 | include: 36 | # We grab the appropriate GHC and cabal-install versions from hvr's PPA. See: 37 | # https://github.com/hvr/multi-ghc-travis 38 | #- env: BUILD=cabal GHCVER=7.0.4 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 39 | # compiler: ": #GHC 7.0.4" 40 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.0.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 41 | #- env: BUILD=cabal GHCVER=7.2.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 42 | # compiler: ": #GHC 7.2.2" 43 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.2.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 44 | #- env: BUILD=cabal GHCVER=7.4.2 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 45 | # compiler: ": #GHC 7.4.2" 46 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.4.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 47 | #- env: BUILD=cabal GHCVER=7.6.3 CABALVER=1.16 HAPPYVER=1.19.5 ALEXVER=3.1.7 48 | # compiler: ": #GHC 7.6.3" 49 | # addons: {apt: {packages: [cabal-install-1.16,ghc-7.6.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 50 | #- env: BUILD=cabal GHCVER=7.8.4 CABALVER=1.18 HAPPYVER=1.19.5 ALEXVER=3.1.7 51 | # compiler: ": #GHC 7.8.4" 52 | # addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 53 | #- env: BUILD=cabal GHCVER=7.10.3 CABALVER=1.22 HAPPYVER=1.19.5 ALEXVER=3.1.7 54 | # compiler: ": #GHC 7.10.3" 55 | # addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 56 | - env: BUILD=cabal GHCVER=8.0.2 CABALVER=1.24 HAPPYVER=1.19.5 ALEXVER=3.1.7 57 | compiler: ": #GHC 8.0.2" 58 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 59 | 60 | # Build with the newest GHC and cabal-install. This is an accepted failure, 61 | # see below. 62 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 63 | compiler: ": #GHC HEAD" 64 | addons: {apt: {packages: [cabal-install-head,ghc-head,happy-1.19.5,alex-3.1.7], sources: [hvr-ghc]}} 65 | 66 | # The Stack builds. We can pass in arbitrary Stack arguments via the ARGS 67 | # variable, such as using --stack-yaml to point to a different file. 68 | - env: BUILD=stack ARGS="" 69 | compiler: ": #stack default" 70 | addons: {apt: {packages: [libgmp-dev]}} 71 | 72 | # - env: BUILD=stack ARGS="--resolver lts-2" 73 | # compiler: ": #stack 7.8.4" 74 | # addons: {apt: {packages: [libgmp-dev]}} 75 | # 76 | # - env: BUILD=stack ARGS="--resolver lts-3" 77 | # compiler: ": #stack 7.10.2" 78 | # addons: {apt: {packages: [libgmp-dev]}} 79 | # 80 | # - env: BUILD=stack ARGS="--resolver lts-6" 81 | # compiler: ": #stack 7.10.3" 82 | # addons: {apt: {packages: [libgmp-dev]}} 83 | # 84 | # - env: BUILD=stack ARGS="--resolver lts-7" 85 | # compiler: ": #stack 8.0.1" 86 | # addons: {apt: {packages: [libgmp-dev]}} 87 | 88 | - env: BUILD=stack ARGS="--resolver lts-8" 89 | compiler: ": #stack 8.0.2" 90 | addons: {apt: {packages: [libgmp-dev]}} 91 | 92 | # Nightly builds are allowed to fail 93 | - env: BUILD=stack ARGS="--resolver nightly" 94 | compiler: ": #stack nightly" 95 | addons: {apt: {packages: [libgmp-dev]}} 96 | 97 | # Build on macOS in addition to Linux 98 | - env: BUILD=stack ARGS="" 99 | compiler: ": #stack default osx" 100 | os: osx 101 | 102 | # Travis includes an macOS which is incompatible with GHC 7.8.4 103 | #- env: BUILD=stack ARGS="--resolver lts-2" 104 | # compiler: ": #stack 7.8.4 osx" 105 | # os: osx 106 | 107 | # - env: BUILD=stack ARGS="--resolver lts-3" 108 | # compiler: ": #stack 7.10.2 osx" 109 | # os: osx 110 | # 111 | # - env: BUILD=stack ARGS="--resolver lts-6" 112 | # compiler: ": #stack 7.10.3 osx" 113 | # os: osx 114 | # 115 | # - env: BUILD=stack ARGS="--resolver lts-7" 116 | # compiler: ": #stack 8.0.1 osx" 117 | # os: osx 118 | 119 | - env: BUILD=stack ARGS="--resolver lts-8" 120 | compiler: ": #stack 8.0.2 osx" 121 | os: osx 122 | 123 | - env: BUILD=stack ARGS="--resolver nightly" 124 | compiler: ": #stack nightly osx" 125 | os: osx 126 | 127 | allow_failures: 128 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 129 | - env: BUILD=stack ARGS="--resolver nightly" 130 | 131 | before_install: 132 | # Using compiler above sets CC to an invalid value, so unset it 133 | - unset CC 134 | 135 | # We want to always allow newer versions of packages when building on GHC HEAD 136 | - CABALARGS="" 137 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 138 | 139 | # Download and unpack the stack executable 140 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 141 | - mkdir -p ~/.local/bin 142 | - | 143 | if [ `uname` = "Darwin" ] 144 | then 145 | travis_retry curl --insecure -L https://www.stackage.org/stack/osx-x86_64 | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 146 | else 147 | travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 148 | fi 149 | 150 | # Use the more reliable S3 mirror of Hackage 151 | mkdir -p $HOME/.cabal 152 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 153 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 154 | 155 | if [ "$CABALVER" != "1.16" ] 156 | then 157 | echo 'jobs: $ncpus' >> $HOME/.cabal/config 158 | fi 159 | 160 | install: 161 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 162 | - if [ -f configure.ac ]; then autoreconf -i; fi 163 | - | 164 | set -ex 165 | case "$BUILD" in 166 | stack) 167 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 168 | ;; 169 | cabal) 170 | cabal --version 171 | travis_retry cabal update 172 | 173 | # Get the list of packages from the stack.yaml file 174 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 175 | 176 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 177 | ;; 178 | esac 179 | set +ex 180 | 181 | script: 182 | - | 183 | set -ex 184 | case "$BUILD" in 185 | stack) 186 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 187 | ;; 188 | cabal) 189 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 190 | 191 | ORIGDIR=$(pwd) 192 | for dir in $PACKAGES 193 | do 194 | cd $dir 195 | cabal check || [ "$CABALVER" == "1.16" ] 196 | cabal sdist 197 | PKGVER=$(cabal info . | awk '{print $2;exit}') 198 | SRC_TGZ=$PKGVER.tar.gz 199 | cd dist 200 | tar zxfv "$SRC_TGZ" 201 | cd "$PKGVER" 202 | cabal configure --enable-tests 203 | cabal build 204 | cd $ORIGDIR 205 | done 206 | ;; 207 | esac 208 | set +ex --------------------------------------------------------------------------------