Generic records

Obj.hs

{-# 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