Code for LambdaConf 2018 Unconference talk about generics

Idea.hs

module Idea where

data Person = Person String (Maybe Gender)
data Gender = Male | Female | Other String

Person is like String :*: Maybe Gender
Gender is like NoFields :+: NoFields :+: String

data Pet = Dog String
         | Cat Color String
         | Fish

String :+: (Color :*: String) :+: NoFields

OurOwnGenerics.hs

{-# language TypeOperators #-}
{-# language TypeFamilies #-}
module OurOwnGenerics where

data Color

data U1 a = U1
data NoFields a = NoFields

data K1 r t a = K1 t
data Field t a = Field t

data (c :+: d) a = OneOnTheLeft  (c a)
                 | OneOnTheRight (d a) 

data (f :*: g) a = Both (f a) (g a)

data Metadata m c a = Metadata (c a)

data Pet = Dog String
         | Cat Color String
         | Fish

type RepresentationOfPet = Field String :+: ((Field Color :*: Field String) :+: NoFields)

petToRepr :: Pet -> RepresentationOfPet a
petToRepr (Dog n)   = OneOnTheLeft (Field n)
petToRepr Fish      = OneOnTheRight (OneOnTheRight NoFields)
petToRepr (Cat c n) = OneOnTheRight (OneOnTheLeft (Both (Field c) (Field n)))

class Generic t where
  type Repr t :: * -> *
  to   :: t -> Repr t a
  from :: Repr t a -> t

instance Generic Pet where
  type Repr Pet = RepresentationOfPet
  to   = petToRepr
  from = error "Exercise to the reader"

SOP.hs

{-# language DataKinds #-}
{-# language PolyKinds #-}
{-# language GADTs #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language ConstraintKinds #-}
module SOP where

import GHC.Exts

data Pet = Dog String
         | Cat Color String
         | Fish

data Color = RGB Int Int Int

type CodeOfPet = '[ '[ String ], '[ Color, String ], '[] ]
-- which is the kind of ReprOfPet??

class Generic t where
  type Code t :: [[*]]
  from :: t -> Repr (Code t)
  to   :: Repr (Code t) -> t

data Repr (dt :: [[*]]) :: * where
  Here  :: Fields c -> Repr (c ': cs)
  There :: Repr cs  -> Repr (c ': cs)

data Nat = Z | S Nat

type family Lookup (n :: Nat) (xs :: [k]) :: k where
  Lookup Z     (x ': xs) = x
  Lookup (S n) (x ': xs) = Lookup n xs

data SNat (n :: Nat) where
  SZ :: SNat Z
  SS :: SNat n -> SNat (S n)

data Repr2 (dt :: [[*]]) :: * where
  Ix :: SNat n -> Fields (Lookup n xs) -> Repr2 xs

data Fields (const :: [*]) :: * where
  Done :: Fields '[]
  (:*) :: t -> Fields ts -> Fields (t ': ts)

type family All2 c (xs :: [[*]]) :: Constraint where
  All2 c '[] = ()
  All2 c (x ': xs) = (All1 c x, All2 c xs)

type family All1 c (xs :: [*]) :: Constraint where
  All1 c '[] = ()
  All1 c (x ': xs) = (c x, All1 c xs)

geq :: All2 Eq c => Repr c -> Repr c -> Bool
geq (Here x) (Here y) = geq' x y
 where
    geq' :: All1 Eq t => Fields t -> Fields t -> Bool
    geq' Done Done = True
    geq' (x :* y) (x' :* y') = x == x' && geq' y y'
geq (There x) (There y) = geq x y
geq _ _ = False

UsingGHCGenerics.hs

{-# language DeriveGeneric #-}
{-# language TypeFamilies #-}
{-# language TypeOperators #-}
{-# language DefaultSignatures #-}
{-# language FlexibleContexts #-}
{-# language DeriveAnyClass #-}
module UsingGHCGenerics where

import GHC.Generics

data Pet = Dog String
         | Cat Color String
         | Fish
         deriving (Generic, Equality)

data Color = RGB Int Int Int
           deriving (Generic, Equality)

class GEquality r where
  equals :: r a -> r a -> Bool

instance GEquality U1 where
  equals U1 U1 = True
instance Equality t => GEquality (K1 r t) where
  equals (K1 x) (K1 y) = x === y
instance (GEquality f, GEquality g) => GEquality (f :*: g) where
  equals (x :*: x') (y :*: y')
    = equals x y && equals x' y'
instance (GEquality f, GEquality g) => GEquality (f :+: g) where
  equals (L1 x) (L1 y) = equals x y
  equals (R1 x) (R1 y) = equals x y
  equals _      _      = False
instance (GEquality f) => GEquality (M1 m n f) where
  equals (M1 x) (M1 y) = equals x y

class Equality t where
  (===) :: t -> t -> Bool
  (/==) :: t -> t -> Bool
  x /== y = not (x === y)

  default (===) :: (GEquality (Rep t), Generic t) => t -> t -> Bool
  x === y = equals (from x) (from y)

instance Eq a => Equality [a] where
  (===) = (==)
instance Equality Int where
  (===) = (==)