Experiment for simple implementation of HasField for extensible records

has-field.hs

{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiParamTypeClasses #-}

import Data.Proxy
import GHC.TypeLits

data Field (l :: Symbol) a where
  Field :: a -> Field l a

class HasField a f where
  getField :: a -> f
  setField :: a -> f -> a

instance HasField (Field l a, b) (Field l a) where
  getField (x, _) = x
  setField (x, y) z = (z, y)

instance {-# OVERLAPPABLE #-} HasField a v => HasField (b, a) v where
  getField (_, x) = getField x
  setField (x, y) z = (x, setField y z)

instance (Show a, KnownSymbol l) => Show (Field l a) where
  show (Field x) = "[Field \"" ++ (symbolVal (Proxy :: Proxy l)) ++ "\" " ++ (show x) ++ "]"

getValue :: forall l a. Field l a -> a
getValue (Field x) = x

-- getEntry :: forall a v (l :: Symbol). (HasField a (Field l v)) => a -> v
-- getEntry x = let (Field y) = getField x in y
--
-- setEntry :: HasField a (Field l v) => a -> v -> a
-- setEntry x y = setField x (Field y)

type Foo = Field "Foo" String
type Bar = Field "Bar" String
type Baz = Field "Baz" String
type Inner a = Field "Inner" a

type Config a = (HasField a Foo, HasField a Bar, HasField a Baz)

getFoo :: HasField a Foo => a -> String
getFoo = (getValue :: Field "Foo" String -> String) . getField

setFoo :: HasField a Foo => a -> String -> a
setFoo x v = setField x (Field v :: Foo)

addBaz :: a -> String -> (Baz, a)
addBaz x y = (Field y :: Baz, x)

getInner :: HasField a (Inner b) => a -> b
getInner = (getValue :: Inner b -> b) . getField

config :: (Foo, (Bar, (Foo, ())))
config = (Field "baz", (Field "bar", (Field "foo", ())))

foo :: String
foo = getFoo config

config2 :: (Foo, (Bar, (Foo, ())))
config2 = setFoo config "fool"

config3 :: (Baz, (Foo, (Bar, (Foo, ()))))
config3 = addBaz config "buzz"

config4 :: (Inner (Bar, (Foo, ())), ())
config4 = (Field (Field "bar", (Field "foo", ())), ())

-- getInnerFoo :: forall a b. (HasField a (Inner b), HasField b Foo) => a -> String
-- getInnerFoo = getFoo . getInner

inner :: (Bar, (Foo, ()))
inner = getInner config4

foo2 :: String
foo2 = getFoo $ (getInner config4 :: (Bar, (Foo, ())))