alacarte.hs

{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}

module ALaCarte where


(∘) = (.)

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

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

class sub ≺ sup where
  inj :: sub a -> sup a

instance (Functor sub) => sub ≺ sub where
  inj = id

instance {-# OVERLAPPING #-} (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

foldExpr :: Functor f => (f a -> a) -> Expr f -> a
foldExpr f (In e) = f (foldExpr f <$> e)

eval :: forall f. (Functor f, Eval f) => Expr f -> Int
eval = foldExpr evalAlgebra

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

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

-- constructors
data Val e = Val Int deriving (Functor, Show, Eq)

instance Eval Val where
  evalAlgebra (Val i) = i

data Add e = Add e e deriving (Functor, Show, Eq)

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

-- smart constructors
inject :: (g ≺ f) => g (Expr f) -> Expr f
inject = In ∘ inj

val :: (Val ≺ f) => Int -> Expr f
val = inject ∘ Val

(⊕) :: (Add ≺ f) => Expr f -> Expr f -> Expr f
x ⊕ y = inject (Add x y)

infixl 7 ⊕

main = do
  let x ::Expr (Add + Val) = val 30000 ⊕ val 1330 ⊕ val 7
  print $ eval x