alacarte.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE DeriveFunctor         #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}

----------------------------------------------------------------
-- Sum types over type lists
----------------------------------------------------------------

data family FSum (xs :: [* -> *]) :: * -> *

data instance FSum (f ': '[]    ) a = Tail (f a)
data instance FSum (f ': g ': gs) a = InL (f a)
                                    | InR (FSum (g ': gs) a)



deriving instance (Functor f) => Functor (FSum (f ': '[]))
deriving instance (Functor f
                  , Functor (FSum (g ': gs))
                  ) => Functor (FSum (f ': g ': gs))

class Inject f fs where
  inj :: f a -> FSum fs a

instance f ~ g => Inject f '[g] where
  inj = Tail

instance {-# OVERLAPPABLE #-} Inject f (h ': gs) =>  Inject f (g ': h ': gs) where
  inj = InR . inj

instance {-# OVERLAPPING #-} Inject f (f ': h ': gs) where
  inj = InL


----------------------------------------------------------------
-- Expr
----------------------------------------------------------------

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

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 (FSum '[f]) where
  evalAlgebra (Tail x) = evalAlgebra x
instance (Eval f, Eval (FSum (g ': gs))) => Eval (FSum (f ': g ': gs)) where
  evalAlgebra (InL x) = evalAlgebra x
  evalAlgebra (InR y) = evalAlgebra y


----------------------------------------------------------------
-- Scratchpad
----------------------------------------------------------------


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

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

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

instance Eval Mul where
  evalAlgebra (Mul x y) = x * y

newtype Val e = Val Int deriving (Functor, Show, Eq)

instance Eval Val where
  evalAlgebra (Val i) = i


inject :: (Inject g xs) => g (Expr (FSum xs)) -> Expr (FSum xs)
inject = In . inj

val :: (Inject Val xs) => Int -> Expr (FSum xs)
val = inject . Val

(.+.) :: (Inject Add xs) => Expr (FSum xs) -> Expr (FSum xs) -> Expr (FSum xs)
x .+. y = inject (Add x y)
infixl 6 .+.

(.*.) :: (Inject Mul xs) => Expr (FSum xs) -> Expr (FSum xs) -> Expr (FSum xs)
x .*. y = inject (Mul x y)
infixl 7 .*.