Skip to content

Instantly share code, notes, and snippets.

@emilaxelsson
Created March 23, 2017 20:40
Show Gist options
  • Save emilaxelsson/bdd7ac0c818c164f01f8bf5c688f3bfa to your computer and use it in GitHub Desktop.
Save emilaxelsson/bdd7ac0c818c164f01f8bf5c688f3bfa to your computer and use it in GitHub Desktop.
Generic records
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wall #-}
{-# OPTIONS_GHC -Wno-missing-signatures #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module Obj where
import Data.Functor.Const
import Data.Functor.Identity
import Data.Proxy
import GHC.OverloadedLabels
{-
We want:
1. Heterogeneous maps
2. Type-safe (and efficient) accessing
3. Easy construction
4. Extensibility
5. Ability to form related structures from a heterogeneous map (i.e. same
field names and types, but different representation of elements)
6. Generic operations (mapping, folding, etc.)
Why do we need #5?
* May want to map each field to a description of it (e.g. a text value)
- ... while still only being able to refer to existing fields
* May want to make the map contain expressions rather than plain values
- ... without losing type safety; an integer field should map to an
integer expression
-}
--------------------------------------------------------------------------------
-- #1 - #3 are provided by plain Haskell records:
data Person = Person
{ name :: String
, age :: Int
}
deriving (Show)
isOld :: Person -> Bool
isOld = (>60) . age
person1 = Person "Sven" 55
--------------------------------------------------------------------------------
-- #4 is provided by `OverloadedLabels`:
class Access obj fld a | obj fld -> a where
access :: obj -> label fld -> a
instance Access obj fld a => IsLabel fld (obj -> a) where
fromLabel _ = \o -> access o (Proxy :: Proxy fld)
instance Access Person "name" String where access o _ = name o
instance Access Person "age" Int where access o _ = age o
data PersonExt = PersonExt
{ nameExt :: String
, ageExt :: Int
, addressExt :: String
}
deriving (Show)
instance Access PersonExt "name" String where access o _ = nameExt o
instance Access PersonExt "age" Int where access o _ = ageExt o
instance Access PersonExt "address" String where access o _ = addressExt o
isOld' :: Access obj "age" Int => obj -> Bool
isOld' o = #age o > 60
-- Or even: isOld' = (>60) . #age
person2 = PersonExt "Sven" 55 "here"
testIsOld = do
print $ isOld' person1
print $ isOld' person2
--------------------------------------------------------------------------------
-- Simplifying extension:
data o1 :*: o2 = ObjPair
{ fstObj :: o1
, sndObj :: o2
}
deriving (Show)
data AddressField = AddressField {address :: String}
deriving (Show)
newtype PersonExt2 = PersonExt2 {unPersonExt2 :: Person :*: AddressField}
deriving (Show)
instance Access PersonExt2 "name" String where access o _ = name $ fstObj $ unPersonExt2 o
instance Access PersonExt2 "age" Int where access o _ = age $ fstObj $ unPersonExt2 o
instance Access PersonExt2 "address" String where access o _ = address $ sndObj $ unPersonExt2 o
person3 = PersonExt2 $ ObjPair person1 (AddressField "here")
testIsOld2 = print $ isOld' person3
-- Note: `Access` instances can be generated using Template Haskell
-- Note: Unfortunately construction is not easy anymore...
--------------------------------------------------------------------------------
-- Special case when construction is easy: when there's only one value for each
-- type. Then we can use a type class:
class Example a where
example :: a
instance (Example a, Example b) => Example (a :*: b) where
example = ObjPair example example
instance Example Person where
example = Person "Arne" 42
instance Example AddressField where
example = AddressField "USA"
deriving instance Example PersonExt2
examplePerson :: PersonExt2
examplePerson = example
--------------------------------------------------------------------------------
-- #5 - #6 can be achieved by associating a generalized representation to each
-- record type, along with a type class to allow manipulating the
-- representation:
-- (The name `Obj` is temporary. Both `Record` and `Object` are taken in our
-- code.)
class Obj obj where
data GObj obj :: (* -> *) -> *
-- | Convert an object to its generalized form
toGObj :: obj -> GObj obj Identity
-- | Convert to an object from its generalized form
fromGObj :: GObj obj Identity -> obj
-- | Return the field names of an object
fieldNames :: GObj obj (Const String)
-- | Map over the fields of an object
mapObject :: (forall a . f a -> g a) -> GObj obj f -> GObj obj g
-- | List the fields of an object
listObject :: GObj obj f -> [(String, Exists f)]
data Exists f where
Ex :: f a -> Exists f
instance (Obj o1, Obj o2) => Obj (o1 :*: o2) where
data GObj (o1 :*: o2) c = ObjPair'
{ fstObj' :: GObj o1 c
, sndObj' :: GObj o2 c
}
toGObj (ObjPair o1 o2) = ObjPair' (toGObj o1) (toGObj o2)
fromGObj (ObjPair' o1 o2) = ObjPair (fromGObj o1) (fromGObj o2)
fieldNames = ObjPair' fieldNames fieldNames
mapObject f (ObjPair' o1 o2) = ObjPair' (mapObject f o1) (mapObject f o2)
listObject (ObjPair' o1 o2) = listObject o1 ++ listObject o2
-- Example: default objects
class Obj obj => Default obj where
def :: GObj obj Maybe
instance (Default o1, Default o2) => Default (o1 :*: o2) where
def = ObjPair' def def
instance Default Person where
def = Person'
{ name' = Nothing
, age' = Just 40
}
instance Default AddressField where
def = AddressField' {address' = Just "Africa"}
-- Generic operations:
-- | List the fields that have default values
listDefaults :: forall proxy obj . Default obj => proxy obj -> [String]
listDefaults _ = [f | (f, Ex (Just _)) <- listObject (def :: GObj obj Maybe)]
test3 = do
print $ listDefaults (Proxy :: Proxy Person)
print $ listDefaults (Proxy :: Proxy PersonExt2)
--------------------------------------------------------------------------------
-- Boilerplate that can be generated:
instance Obj Person where
data GObj Person c = Person'
{ name' :: c String
, age' :: c Int
}
toGObj (Person n a) = Person' (return n) (return a)
fromGObj (Person' n a) = Person (runIdentity n) (runIdentity a)
fieldNames = Person' (Const "name") (Const "age")
mapObject f (Person' n a) = Person' (f n) (f a)
listObject (Person' n a) = [("name", Ex n), ("age", Ex a)]
instance Obj AddressField where
data GObj AddressField c = AddressField' {address' :: c String}
toGObj (AddressField a) = AddressField' (return a)
fromGObj (AddressField' a) = AddressField (runIdentity a)
fieldNames = AddressField' (Const "address")
mapObject f (AddressField' a) = AddressField' (f a)
listObject (AddressField' a) = [("address", Ex a)]
instance Obj PersonExt2 where
newtype GObj PersonExt2 c = PersonExt2'
{unPersonExt2' :: GObj (Person :*: AddressField) c}
toGObj = PersonExt2' . toGObj . unPersonExt2
fromGObj = PersonExt2 . fromGObj . unPersonExt2'
fieldNames = PersonExt2' fieldNames
mapObject f = PersonExt2' . mapObject f . unPersonExt2'
listObject = listObject . unPersonExt2'
instance Default PersonExt2 where
def = PersonExt2' def
-- Can't be newtype-derived for some reason
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment