Codec Enterprise Edition - Easy bidirectional serialization with overloaded record fields

codec-enterprise-edition.hs

{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances, LambdaCase, DataKinds, ScopedTypeVariables, FunctionalDependencies, PartialTypeSignatures, FlexibleContexts, RankNTypes, KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}

-- actual imports :)
import Control.Applicative
import Control.Category
import Data.Proxy
import GHC.TypeLits
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 Data.Maybe
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 }
  | Const2 { arg1 :: Word8 } -- arg1 exists for both constructors
  deriving Show

-- specify TestType's representation
testTypeCodec :: Codec Get PutM TestType
testTypeCodec
  = (codec (Proxy :: Proxy "Const1")
    $ field r_arg2 word16be -- fields will be de/serialized in this order
    . field r_arg1 word8) <|-|>
    (codec (Proxy :: Proxy "Const2") -- alternative codec for other constructor
    $ field r_arg1 word8)


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

produceTest :: TestType -> Put
produceTest = fromJust . produce testTypeCodec

-- works for JSON too
testTypeJSON :: Codec ObjectParser ObjectBuilder TestType
testTypeJSON
  = (codec (Proxy :: Proxy "Const1")
    $ field r_arg2 (entry "arg2")
    . field r_arg1 (entry "arg1")) <|-|>
    (codec (Proxy :: Proxy "Const2")
    $ 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 (c :: Symbol) (f :: Symbol) a x y = Field (a -> x -> y) (r -> a)

-- Field application equipped with serializers and deserializers
data Build fr fw r (c :: Symbol) 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 -> Maybe (fw ()) }

-- turn a Field into a Build with the given serializers
build :: Functor fr => Field r c f a x y -> fr a -> (a -> fw ()) -> Build fr fw r c 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 c) 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 :: forall proxy fr fw r c x y. (Functor fr, KO r y, CSTR r c x) => proxy c -> Build fr fw r c x y -> Codec fr fw r
codec _ (Build r w) = Codec
  { parse = (\g -> give $ g $ getCSTR (Proxy :: Proxy c)) <$> r
  , produce = \x -> if hasCSTR (Proxy :: Proxy c) x then Just (w x) else Nothing
  }

-- combine codecs
-- serializers will try to serialize with either, deserializers will try to deserialize with either
(<|-|>) :: Alternative fr => Codec fr fw r -> Codec fr fw r -> Codec fr fw r
Codec r1 w1 <|-|> Codec r2 w2
  = Codec (r1 <|> r2) (\x -> w1 x <|> w2 x)

-- Typeclass for constructor singletons
class CSTR r (cs :: Symbol) c | cs r -> c, cs c -> r where
  getCSTR :: proxy cs -> c
  hasCSTR :: proxy cs -> r -> Bool

-- Typeclass for field accessors
class CSTR r cs c => Fld r cs c f a x y | cs f x -> a y, cs f y -> a x where
  fld :: Field r cs f a x y

type GField f = forall r cs c a x y. Fld r cs c f a x y => Field r cs f a x y

-- Niceties

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

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

-- example cont'd

-- these instances look horrible but would be produced by template haskell

instance CSTR TestType "Const1" (Word8 -> Word16 -> TestType) where
  getCSTR _ = Const1
  hasCSTR _ = \case
    Const1 _ _ -> True
    _ -> False

instance CSTR TestType "Const2" (Word8 -> TestType) where
  getCSTR _ = Const2
  hasCSTR _ = \case
    Const2 _ -> True
    _ -> False

instance Fld TestType "Const1" (Word8 -> Word16 -> TestType) "arg1" Word8 (Word8 -> arg2 -> TestType) (X -> arg2 -> TestType) where
  fld = Field (\x c _ a2 -> c x a2) arg1

instance Fld TestType "Const1" (Word8 -> Word16 -> TestType) "arg2" Word16 (arg1 -> Word16 -> TestType) (arg1 -> X -> TestType) where
  fld = Field (\x c a1 _ -> c a1 x) arg2

instance Fld TestType "Const2" (Word8 -> TestType) "arg1" Word8 (Word8 -> TestType) (X -> TestType) where
  fld = Field (\x c _ -> c x) arg1

r_arg1 :: GField "arg1"
r_arg1 = fld

r_arg2 :: GField "arg2"
r_arg2 = fld

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 $ fromJust $ produce cd x