Tagless, Applicative, bidirectional serialization combinators

TaglessSerialization.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}

import Control.Applicative

class Field a where
    fieldType :: a -> String
    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

class Column table t where
    column :: Field a => String -> (t -> a) -> table t a

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

newtype MetaRecord t a = MetaRecord {metaRecord :: [(String, String)]}

instance Functor (MetaRecord t) where
    fmap _ = MetaRecord . metaRecord

instance Applicative (MetaRecord t) where
    pure _ = MetaRecord []

    m1 <*> m2 = MetaRecord $ metaRecord m1 ++ metaRecord m2

instance Column MetaRecord t where
    column s f = MetaRecord [(s, fieldType (f (undefined :: t)))]

newtype ToRecord t a = ToRecord {toRecord :: t -> [(String, String)]}

instance Functor (ToRecord t) where
    fmap _ = ToRecord . toRecord

instance Applicative (ToRecord t) where
    pure _ = ToRecord $ \_ -> []

    m1 <*> m2 = ToRecord $ \t -> toRecord m1 t ++ toRecord m2 t

instance Column ToRecord t where
    column s f = ToRecord $ \t -> [(s, fieldShow $ f t)]

newtype FromRecord t a = FromRecord {fromRecord :: [(String, String)] -> a}

instance Functor (FromRecord t) where
    fmap f m = FromRecord $ f . fromRecord m

instance Applicative (FromRecord t) where
    pure x = FromRecord $ \_ -> x

    m1 <*> m2 = FromRecord $ \xs -> fromRecord m1 xs (fromRecord m2 xs)

instance Column FromRecord t where
    column s f = FromRecord $ \xs ->
                   case lookup s xs of
                     Nothing -> error $ "Missing field: " ++ s
                     Just str -> fieldRead str

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

class HasTable t where
    table :: (Applicative (table t), Column table t) => table t t

instance HasTable Food where
    table = Food <$> column "name" foodName
                 <*> column "cost" foodCost

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

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

    putStrLn "Serialized ramen:"
    printRecord (toRecord table ramen)

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