labels.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

import GHC.OverloadedLabels (IsLabel (..))
import GHC.TypeLits (ErrorMessage (Text), Symbol, TypeError)

data family EntityField rec :: * -> *

data User = User

data instance EntityField User _ where
  UserId :: EntityField User Int
  UserName :: EntityField User String

data Mail = Mail

data instance EntityField Mail _ where
  MailId :: EntityField Mail Int
  MailAddress :: EntityField Mail String

class SymbolToField (sym :: Symbol) rec where
  getField :: EntityField rec (Res sym rec)

instance (typ ~ Res sym rec, SymbolToField sym rec) => IsLabel sym (EntityField rec typ) where
  fromLabel = getField @sym

instance SymbolToField "id" User where
  getField = UserId

instance SymbolToField "name" User where
  getField = UserName

instance SymbolToField "id" Mail where
  getField = MailId

instance SymbolToField "address" Mail where
  getField = MailAddress

type family Res (sym :: Symbol) rec where
  Res sym User = ResUser sym
  Res sym Mail = ResMail sym

type family ResUser (sym :: Symbol) where
  ResUser "id" = Int
  ResUser "name" = String
  ResUser _ = TypeError (Text "something useful")

type family ResMail (sym :: Symbol) where
  ResMail "id" = Int
  ResMail "address" = String
  ResMail _ = TypeError (Text "something useful")

(^.) :: val -> EntityField val typ -> typ
(^.) = undefined

(==.) :: typ -> typ -> Bool
(==.) = undefined

-- > :t (User ^. #id) ==. (Mail ^. #id)
-- (User ^. #id) ==. (Mail ^. #id) :: Bool