Skip to content

@sjoerdvisscher /ADTShow.hs
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Applicative, bidirectional serialization combinators
{-# 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)
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.