{-# OPTIONS 
 -fglasgow-exts 
 -fallow-overlapping-instances 
 #-}

module WouterRecords where

infixr 6 :@:
data (f :@: g) e = Recb (f e) (g e) deriving Eq

instance (Functor f, Functor g) => Functor (f :@: g) where
    fmap f (Recb r1 r2) = Recb (fmap f r1) (fmap f r2)

class (Functor sub, Functor sup) => sub :<@: sup where
    rGet :: sup a -> sub a
    rSet :: sub a -> sup a -> sup a

instance Functor f => (:<@:) f f where
    rGet = id
    rSet x _ = x

instance (Functor f, Functor g) => (:<@:) f (f :@: g) where
    rGet (Recb x y) = x
    rSet x (Recb _ y) = Recb x y

instance (Functor f, Functor g, Functor h, (:<@:) f g) =>
    (:<@:) f (h :@: g) where
    rGet (Recb _ y) = rGet y
    rSet x (Recb y z) = Recb y (rSet x z)


data Record f = Rec (f (Record f))

class Functor f => DefaultingField f where
    dVal :: f a

instance (DefaultingField f, DefaultingField g) =>
    DefaultingField (f :@: g) where
    dVal = Recb dVal dVal

dRec :: DefaultingField f => Record f
dRec = Rec dVal

data Name e = Name String
instance Functor Name where
    fmap f (Name n) = Name n
instance DefaultingField Name where
    dVal = Name ""
name :: (:<@:) Name f => Record f -> String
name (Rec r) = (\ (Name n) -> n) $ rGet r
setName :: (:<@:) Name f => String -> Record f -> Record f
setName n (Rec r) = Rec $ rSet (Name n) r

data Age e = Age Int
instance Functor Age where
    fmap f (Age a) = Age a
instance DefaultingField Age where
    dVal = Age 0
age :: (:<@:) Age f => Record f -> Int
age (Rec r) = (\ (Age a) -> a) $ rGet r
setAge :: (:<@:) Age f => Int -> Record f -> Record f
setAge a (Rec r) = Rec $ rSet (Age a) r

data Location e = Location String
instance Functor Location where 
    fmap f (Location l) = Location l
instance DefaultingField Location where
    dVal = Location ""
location :: (:<@:) Location f => Record f -> String
location (Rec r) = (\ (Location l) -> l) $ rGet r
setLocation :: (:<@:) Location f => String -> Record f -> Record f
setLocation l (Rec r) = Rec $ rSet (Location l) r


data Living e = Living Bool
instance Functor Living where
    fmap f (Living b) = Living b
instance DefaultingField Living where
    dVal = Living False
living :: (:<@:) Living f => Record f -> Bool
living (Rec r) = (\ (Living l) -> l) $ rGet r
setLiving :: (:<@:) Living f => Bool -> Record f -> Record f
setLiving l (Rec r) = Rec $ rSet (Living l) r


test1 :: Record (Name :@: Age :@: Living)
test1 = setName "George" $ setAge 21 $ setLiving True $ dRec
test2 = dRec :: Record (Name :@: Age :@: Location)
test3 = dRec :: Record (Name :@: Age :@: Location :@: Living)