Applicative, bidirectional serialization combinators

ADTShow.hs

{-# LANGUAGE 
    RankNTypes
  , TypeFamilies
  , ConstraintKinds
  , FlexibleInstances
  , ScopedTypeVariables
  , TypeSynonymInstances
  #-}

import GHC.Prim (Constraint)
import Control.Applicative
import Data.Functor.Identity
import Data.Functor.Constant
import Data.Monoid

import Data.Maybe (fromJust)


-------------------------------------------
-- This is to be part of a generics library
-------------------------------------------
data FieldInfo t a = FieldInfo
  { fieldName    :: String
  , fieldExtract :: t -> a
  }

data For (c :: * -> Constraint) = For

class ADT t where

  ctorIndex :: t -> Int

  type Constraints t c :: Constraint
  buildsA :: (Constraints t c, Applicative f) 
          => For c -> (forall s. c s => FieldInfo t s -> f s) -> [f t]

builds :: (ADT t, Constraints t c) => For c -> (forall s. c s => FieldInfo t s -> s) -> [t]
builds for f = fmap runIdentity $ buildsA for (Identity . f)  

mbuilds :: forall t c m. (ADT t, Constraints t c, Monoid m) 
        => For c -> (forall s. c s => FieldInfo t s -> m) -> [m]
mbuilds for f = fmap getConstant ms
  where
    ms :: [Constant m t]
    ms = buildsA for (Constant . f)


----------------------------
-- This is the specific part
----------------------------
class Field a where
  fieldType :: a -> String  -- Should work with 'undefined'
  fieldRead :: String -> a
  fieldShow :: a -> String

instance Field String where
  fieldType = const "TEXT"
  fieldRead = id  -- We need proper escaping here
  fieldShow = id
    
instance Field Int where
  fieldType = const "INTEGER"
  fieldRead = read
  fieldShow = show

metaRecord :: forall t. (ADT t, Constraints t Field) => t -> [(String, String)]
metaRecord _ = head $ mbuilds (For :: For Field) f
  where
    f :: forall s. Field s => FieldInfo t s -> [(String, String)]
    f info = [(fieldName info, fieldType (undefined :: s))]

toRecord :: (ADT t, Constraints t Field) => t -> [(String, String)]
toRecord t = head $ mbuilds (For :: For Field) 
  (\info -> [(fieldName info, fieldShow $ fieldExtract info t)])

fromRecord :: (ADT t, Constraints t Field) => [(String, String)] -> t
fromRecord rec = fromJust $ head $ buildsA (For :: For Field)
  (\info -> fieldRead <$> lookup (fieldName info) rec)

printRecord :: [(String, String)] -> IO ()
printRecord = putStrLn . unlines . map (\(x, y) -> x ++ " = " ++ y)


data Food = Food
    { foodName :: String
    , foodCost :: Int
    } deriving (Show)

instance ADT Food where
  ctorIndex Food{} = 0
  type Constraints Food c = (c String, c Int)
  buildsA For f = [Food
    <$> f (FieldInfo "name" foodName)
    <*> f (FieldInfo "cost" foodCost)]


ramen :: Food
ramen = Food "ラーメン" 800

main :: IO ()
main = do
    putStrLn "Meta record (used in CREATE TABLE... etc.):"
    printRecord $ metaRecord (undefined :: Food)

    putStrLn "Serialized ramen:"
    printRecord (toRecord ramen)

    putStrLn "Deserialized sashimi:"
    print (fromRecord [("name", "刺身"), ("cost", "1200")] :: Food)