public
Created

Applicative, bidirectional serialization combinators

  • Download Gist
ADTShow.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 96 97 98 99 100 101 102 103 104 105 106 107 108 109
{-# 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)

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.