Data Types A La Carte

Main.hs

-- http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf

{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeFamilies #-}

main :: IO ()
main = do
  let
    x :: Expr (Add :+: Val)
    x = val 30000 .+. val 1330
  print (eval x)

newtype Expr f = In (f (Expr f))

newtype Val e = Val Int
  deriving (Functor)

data Add e = Add e e
  deriving (Functor)

data (f :+: g) e = Inl (f e) | Inr (g e)
  deriving (Show, Functor)

foldExpr :: Functor f => (f a -> a) -> Expr f -> a
foldExpr f (In t) = f (fmap (foldExpr f) t)

class Functor f => Eval f where
  evalAlgebra :: f Int -> Int

instance Eval Val where
  evalAlgebra (Val x) = x

instance Eval Add where
  evalAlgebra (Add x y) = x + y

instance (Eval f, Eval g) => Eval (f :+: g) where
  evalAlgebra (Inl x) = evalAlgebra x
  evalAlgebra (Inr x) = evalAlgebra x

eval :: Eval f => Expr f -> Int
eval = foldExpr evalAlgebra

class (Functor sub, Functor sup) => sub :<: sup where
  inj :: sub a -> sup a

instance {-# OVERLAPS #-} (Functor f, Functor g, f ~ g) => f :<: g where
  inj = id

instance {-# OVERLAPPABLE #-} (Functor f, Functor g) => f :<: (f :+: g) where
  inj = Inl

instance {-# OVERLAPPABLE #-} (Functor f, Functor g, Functor h, f :<: g) => f :<: (h :+: g) where
  inj = Inr . inj

inject :: (g :<: f) => g (Expr f) -> Expr f
inject = In . inj

val :: (Val :<: f) => Int -> Expr f
val x = inject (Val x)

infixl 6 .+.
(.+.) :: (Add :<: f) => Expr f -> Expr f -> Expr f
x .+. y = inject (Add x y)