Skip to content

Instantly share code, notes, and snippets.

@basvandijk
Created September 8, 2012 10:31
Show Gist options
  • Save basvandijk/3673316 to your computer and use it in GitHub Desktop.
Save basvandijk/3673316 to your computer and use it in GitHub Desktop.
Tagless, Applicative, bidirectional serialization combinators
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment