public
Last active

Tagless, Applicative, bidirectional serialization combinators

  • Download Gist
TaglessSerialization.hs
Haskell
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95
{-# 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)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.