FormatSing.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE GADTs                 #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds             #-}
{-# LANGUAGE RankNTypes            #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}

module Format where

-- Provided by the singletons library
data family Sing (a :: k)
class SingI (a :: k) where
  sing :: Sing a

data Version = V1 | V2

-- Can be automatically generated by the singletons library
data instance Sing (v :: Version) where
  SV1 :: Sing 'V1
  SV2 :: Sing 'V2

data Foo    = Foo    { _bar :: Bar }             deriving Show
data Bar    = Bar    { _baz :: Baz }             deriving Show
data Baz    = Baz    { _booyah :: Booyah }       deriving Show
data Booyah = Booyah { _i :: Int, _s :: String } deriving Show

type Json = String

class Format (v :: Version) a where
  format :: Sing v -> a -> Json

-- Generic instances
instance Format v Baz => Format v Bar where -- requires UndecidableInstances :'(
  format v (Bar baz) = "Bar (" ++ format v baz ++ ")" -- could be auto derived

instance Format v Booyah where
  format _ = show -- could be auto derived

-- Version-specific instances
instance Format 'V1 Foo where
  format v (Foo bar) = "FooV1 (" ++ format v bar ++ ")"

instance Format 'V1 Baz where
  format v (Baz booyah) = "BazV1 (" ++ format v booyah ++ ")"

instance Format 'V2 Foo where
  format v (Foo bar) = "FooV2 (" ++ format v bar ++ ")"

instance Format 'V2 Baz where
  format v (Baz booyah) = "BazV2 (" ++ format v booyah ++ ")"

sendToV1Server :: Foo -> (Json -> IO ()) -> IO ()
sendToV1Server foo send = send (format SV1 foo)

sendToV2Server :: Foo -> (Json -> IO ()) -> IO ()
sendToV2Server foo send = send (format SV2 foo)

foo :: Foo
foo = Foo (Bar (Baz (Booyah 42 "Hello, World!")))

main :: IO ()
main = do
  sendToV1Server foo putStrLn
  -- > FooV1 (Bar (BazV1 (Booyah {_i = 42, _s = "Hello, World!"})))
  sendToV2Server foo putStrLn
  -- > FooV2 (Bar (BazV2 (Booyah {_i = 42, _s = "Hello, World!"})))