Composable Applicative bidirectional serialization

codec.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}

-- actual imports :)
import Control.Category
import Prelude hiding (id, (.))

-- example imports
import Control.Monad.Reader
import Control.Monad.Writer
import Data.Aeson hiding (parseJSON)
import Data.Aeson.Types hiding (parse, parseJSON)
import Data.Binary.Put
import Data.Binary.Get
import qualified Data.Text as T
import Data.Word

-- TL;DR you can do this:

-- a regular Haskell type
data TestType = Const1 { arg1 :: Word8, arg2 :: Word16 }
  deriving Show

-- specify TestType's representation
testTypeCodec :: Codec Get PutM TestType
testTypeCodec
  = codec Const1
    $ field r_arg2 word16be -- fields will be de/serialized in this order
    . field r_arg1 word8

-- and you get these for free!
parseTest :: Get TestType
parseTest = parse testTypeCodec

produceTest :: TestType -> Put
produceTest = produce testTypeCodec

-- works for JSON too
testTypeJSON :: Codec ObjectParser ObjectBuilder TestType
testTypeJSON
  = codec Const1
    $ field r_arg2 (entry "arg2")
    . field r_arg1 (entry "arg1")

parseJSONTest :: Value -> Parser TestType
parseJSONTest = parseJSON testTypeJSON

produceJSONTest :: TestType -> Value
produceJSONTest = produceJSON testTypeJSON

-- here's how it works

-- a "knocked-out" constructor parameter (we could use ())
data X = X

-- produce an r from a fully knocked-out function
class KO r a where
  give :: a -> r

instance KO r b => KO r (X -> b) where
  give f = give $ f X

instance KO r r where
  give = id

-- 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.
-- x: (Int -> a2 -> MyRecord) y: (X -> a2 -> MyRecord)
data Field r a x y = Field (a -> x -> y) (r -> a)

-- Field application equipped with serializers and deserializers
data Build fr fw r x y = Build (fr (x -> y)) (r -> fw ())

-- Finished product with serializer and deserializer
data Codec fr fw r = Codec { parse :: fr r, produce :: r -> fw () }

-- turn an Field into an Build with the given serializers
build :: Functor fr => Field r a x y -> fr a -> (a -> fw ()) -> Build fr fw r x y
build (Field ct ex) r w = Build (ct <$> r) (w . ex)

-- Category instance for Build to make it composable
instance (Applicative fr, Applicative fw) => Category (Build fr fw r) where
  id = Build (pure id) (const $ pure ())
  Build r1 w1 . Build r2 w2
    = Build ((.) <$> r1 <*> r2) (\x -> w1 x *> w2 x)

-- turn a Build into a Codec with a given constructor
codec :: (Functor fr, KO r y) => x -> Build fr fw r x y -> Codec fr fw r
codec f (Build r w) = Codec ((\g -> give $ g f) <$> r) w

-- Niceties

-- A pair of complementary serializers/deserializers
type FieldCodec fr fw a = ( fr a, a -> fw () )

-- Apply a pair to an Field to produce an Build
field :: Functor fr => Field r a x y -> FieldCodec fr fw a -> Build fr fw r x y
field a = uncurry (build a)

-- example cont'd

-- ugly type but easy to generate!
r_arg1 :: Field TestType Word8 (Word8 -> arg2 -> TestType) (X -> arg2 -> TestType)
r_arg1 = Field (\x field X a2 -> field x a2) arg1

r_arg2 :: Field TestType Word16 (arg1 -> Word16 -> TestType) (arg1 -> X -> TestType)
r_arg2 = Field (\x field a1 X -> field a1 x) arg2

word8 :: FieldCodec Get PutM Word8
word8 = ( getWord8, putWord8 )

word16be :: FieldCodec Get PutM Word16
word16be = ( getWord16be, putWord16be )

-- JSON-specific stuff

type ObjectParser = ReaderT Object Parser
type ObjectBuilder = Writer [ Pair ]
type JSONCodec = Codec ObjectParser ObjectBuilder

entry :: (FromJSON a, ToJSON a) => T.Text -> FieldCodec ObjectParser ObjectBuilder a
entry fn = ( ReaderT $ \o -> o .: fn, \x -> tell [ fn .= x ] )

-- suitable for FromJSON
parseJSON :: Codec ObjectParser fw a -> Value -> Parser a
parseJSON cd = withObject "" $ runReaderT (parse cd)

-- suitable for ToJSON
produceJSON :: Codec fr ObjectBuilder a -> a -> Value
produceJSON cd x = object $ execWriter $ produce cd x