Where I'm at with datatypes a la carte

Alacarte.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverlappingInstances #-}
module Main where

data Expr f = In (f (Expr f))

foldExpr f (In t) = f (fmap (foldExpr f) t)

data Val e = Val Int
data Add e = Add e e
data Mul x = Mul x x

data (f :+: g) e = Inl (f e) | Inr (g e)

instance (Functor f, Functor g) => Functor (f :+: g) where
  fmap f (Inl e) = Inl (fmap f e)
  fmap g (Inr e) = Inr (fmap g e)

instance Functor Val where
  fmap f (Val x) = Val x

instance Functor Add where
  fmap f (Add e1 e2) = Add (f e1) (f e2)

instance Functor Mul where
  fmap f (Mul x y) = Mul (f x) (f y)

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

instance Eval Val where
  evalgebra (Val x) = x
instance Eval Add where
  evalgebra (Add l r) = l + r
instance Eval Mul where
  evalgebra (Mul x y) = x * y

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

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

instance Functor f => f :<: f where
  inj = id
--instance {-# OVERLAPPING #-} (Functor f, Functor g) => f :<: (f :+: g) where
instance (Functor f, Functor g) => f :<: (f :+: g) where
  inj = Inl
instance (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)

infixl 7 ⊗
(⊗) :: (Mul :<: f) => Expr f -> Expr f -> Expr f
x ⊗ y = inject (Mul x y)

eval :: Eval f => Expr f -> Int
eval expr = foldExpr evalgebra expr

ex1 :: Expr (Add :+: Val)
ex1 = val 300 ⊕ val 7 ⊕ val 7

ex2 :: Expr (Mul :+: Val)
ex2 = val 200 ⊗ val 2

ex3 :: Expr (Val :+: Mul :+: Add)
ex3 = val 200 ⊗ val 2 ⊕ val 7

main :: IO ()
main = do
  putStrLn "hello world"