syntax-tricks.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedLabels #-}

module X where

import Data.Functor.Identity (Identity (..))
import Data.Kind (Type)
import GHC.OverloadedLabels (IsLabel (..))
import GHC.TypeLits (KnownSymbol, Symbol)

type (:::) :: Symbol -> Type -> Type
data (:::) s a

data Record :: (Type -> Type) -> [Type] -> Type where
  RNil :: Record f '[]
  RCons :: KnownSymbol s => f a -> Record f xs -> Record f (s ::: a : xs)

infixr 5 `RCons`

singleton :: KnownSymbol s => f a -> Record f '[s ::: a]
singleton x = x `RCons` RNil

type FieldName :: Symbol -> Type
data FieldName s where
  FieldName :: KnownSymbol s => FieldName s

instance (x ~ s, KnownSymbol s) => IsLabel x (FieldName s) where
  fromLabel = FieldName

(=.) :: FieldName s -> f a -> Record f '[s ::: a]
(=.) FieldName = singleton

type Append :: [k] -> [k] -> [k]
type family Append xs ys where
  Append '[] ys = ys
  Append (x : xs) ys = x : Append xs ys

append :: Record f xs -> Record f ys -> Record f (Append xs ys)
append RNil ys = ys
append (x `RCons` xs) ys = x `RCons` append xs ys

(>>) :: Record f xs -> Record f ys -> Record f (Append xs ys)
(>>) = append

example :: Record Identity '["foo" ::: Float, "bar" ::: Bool]
example = X.do
  #foo =. Identity 42.0
  #bar =. Identity True