Data types a la carte http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf

datatypes-a-la-carte.hs

-- Data types a la carte
-- http://www.cs.ru.nl/~W.Swierstra/Publications/DataTypesALaCarte.pdf

-- [Wadler's Blog: Data Types a la Carte](http://wadler.blogspot.com/2008/02/data-types-la-carte.html)

{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables #-}

----------------------------------------
-- Expression Problem
----------------------------------------
-- data Expr = Val Int | Add Expr Expr

-- eval :: Expr -> Int
-- eval (Val x) = x
-- eval (Add x y) = eval x + eval y

-- render :: Expr -> String
-- render (Val x) = show x
-- render (Add x y) = "(" ++ render x ++ " + " ++ render y ++ ")"

----------------------------------------
-- Recursion Scheme
----------------------------------------
-- https://github.com/ekmett/recursion-schemes/
newtype Fix f = Fix (f (Fix f))

unfix :: Fix f -> f (Fix f)
unfix (Fix f) = f

data ValF e = ValF Int
-- type Val = Fix ValF

data AddF e = AddF e e
-- type Add = Fix AddF

-- infixr 5 :+:

data (f :+: g) e = InL (f e) | InR (g e)

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

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

instance (Functor f, Functor g) => Functor (f :+: g) where
    fmap f (InL e1) = InL (fmap f e1)
    fmap f (InR e2) = InR (fmap f e2)

-- https://hackage.haskell.org/package/data-fix-0.2.0/docs/Data-Fix.html#v:cata
-- https://hackage.haskell.org/package/recursion-schemes-5.1.3/docs/Data-Functor-Foldable.html#v:cata
--   cata :: (Base t a -> a) -- ^ a (Base t)-algebra
--        -> t               -- ^ fixed point
--        -> a               -- ^ result
cata :: Functor f => (f a -> a) -> Fix f -> a
cata alg = alg . (fmap (cata alg)) . unfix

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

instance Eval ValF where
    evalAlg (ValF x) = x

instance Eval AddF where
    evalAlg (AddF x y) = x + y

instance (Eval f, Eval g) => Eval (f :+: g) where
    evalAlg (InL e1) = evalAlg e1
    evalAlg (InR e2) = evalAlg e2

eval :: Eval f => Fix f -> Int
eval = cata evalAlg

----------------------------------------
-- Smart Constructor
----------------------------------------
-- val :: Int -> Fix ValF:r
-- val x = Fix (ValF x)

infixl 6 ⊕

-- (⊕) :: Fix AddF -> Fix AddF -> Fix AddF
-- x ⊕ y = Fix (AddF x y)

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

instance Functor f => f :<: f where
    inj = id

instance (Functor f, Functor g) => f :<: (f :+: g) where
    inj = InL

-- My addition:
instance (Functor f, Functor g) => g :<: (f :+: g) where
    inj = InR

-- TODO: Can't work well
    -- Comment-Out: Prefers right associative, so `f :<: (f :+: g) :+: h` is not necessary
    -- instance (Functor f, Functor g, Functor h, f :<: g) => f :<: (g :+: h) where
    --     inj = InL . inj

    -- In Paper:
    -- instance (Functor f, Functor g, Functor h, f :<: h) => f :<: (g :+: h) where
    --     inj = InR . inj

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

val :: (ValF :<: f) => Int -> Fix f
val x = inject (ValF x)

(⊕) :: (AddF :<: f) => Fix f -> Fix f -> Fix f
x ⊕ y = inject (AddF x y)

----------------------------------------
-- Adding new data constructor
----------------------------------------
data MulF x = MulF x x

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

instance Eval MulF where
    evalAlg (MulF x y) = x * y

infixl 7 ⊗

(⊗) :: (MulF :<: f) => Fix f -> Fix f -> Fix f
x ⊗ y = inject (MulF x y)

----------------------------------------
-- Adding new interpreter
----------------------------------------

class Render f where
    renderAlg :: Render g => f (Fix g) -> String

pretty :: Render f => Fix f -> String
pretty (Fix t) = renderAlg t

instance Render ValF where
    renderAlg (ValF i) = show i

instance Render AddF where
    renderAlg (AddF x y) = "(" ++ pretty x ++ " + " ++ pretty y ++ ")"

instance Render MulF where
    renderAlg (MulF x y) = "(" ++ pretty x ++ " * " ++ pretty y ++ ")"

instance (Render f, Render g) => Render (f :+: g) where
    renderAlg (InL e1) = renderAlg e1
    renderAlg (InR e2) = renderAlg e2

----------------------------------------
-- main
----------------------------------------
main = do
    -- Without smart constructors
    do
        let expr :: Fix (ValF :+: AddF)
            expr = Fix (InR (AddF (Fix (InL (ValF 10))) (Fix (InL (ValF 2)))))
        print $ eval expr -- 12
        print $ pretty expr

    -- With smart constructors
    do
        let expr :: Fix (AddF :+: ValF)
            expr = val 300 ⊕ val 20 ⊕ val 1
        print $ eval expr -- 321
        print $ pretty expr

    do
        let expr :: Fix (MulF :+: ValF)
            expr = val 300 ⊗ val 20 ⊗ val 1
        print $ eval expr -- 6000
        print $ pretty expr

    -- do
    --     let expr :: Fix ((MulF :+: AddF) :+: ValF) = val 4 ⊗ val 3 -- ⊗ val 2
    --     print $ eval expr -- 24

    -- do
    --     let expr :: Fix (ValF :+: AddF :+: MulF) = val 4 ⊗ val 3 ⊗ val 2
    --     print $ eval expr -- 24

datatypes-a-la-carte2.hs

{-# LANGUAGE TypeOperators, MultiParamTypeClasses, FlexibleInstances, FlexibleContexts, ScopedTypeVariables, DeriveFunctor, RankNTypes #-}

----------------------------------------
-- Coproduct
----------------------------------------
data (f :+: g) e = InL (f e) | InR (g e)

instance (Functor f, Functor g) => Functor (f :+: g) where
    fmap f (InL e1) = InL (fmap f e1)
    fmap f (InR e2) = InR (fmap f e2)

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

instance Functor f => f :<: f where
    inj = id

instance (Functor f, Functor g) => f :<: (f :+: g) where
    inj = InL

-- My addition:
instance (Functor f, Functor g) => g :<: (f :+: g) where
    inj = InR

----------------------------------------
-- Free Monad
----------------------------------------
-- https://hackage.haskell.org/package/free-5.1.3/docs/Control-Monad-Free.html
data Free f a = Pure a | Impure (f (Free f a))

instance Functor f => Functor (Free f) where
    fmap f (Pure x) = Pure (f x)
    fmap f (Impure t) = Impure (fmap (fmap f) t)

instance Functor f => Applicative (Free f) where
    pure = Pure
    Pure a <*> Pure b = Pure $ a b
    Pure a <*> Impure mb = Impure $ fmap a <$> mb
    Impure ma <*> b = Impure $ (<*> b) <$> ma

instance Functor f => Monad (Free f) where
    return = pure
    Pure a >>= f = f a
    Impure m >>= f = Impure ((>>= f) <$> m)

data IncrF t = IncrF Int t deriving (Functor)
data RecallF t = RecallF (Int -> t) deriving (Functor)

inject :: (g :<: f) => g (Free f a) -> Free f a
inject = Impure . inj

incr :: (IncrF :<: f) => Int -> Free f ()
incr i = inject (IncrF i (Pure ()))

recall :: (RecallF :<: f) => Free f Int
recall = inject (RecallF Pure)

tick :: Free (RecallF :+: IncrF) Int
-- tick :: (RecallF :<: f, IncrF :<: f) => Free f Int -- TODO: doesn't work
tick = do
    y <- recall
    incr 1
    return y

-- from lib
foldFree :: Monad m => (forall x . f x -> m x) -> Free f a -> m a
foldFree _ (Pure a)  = pure a
foldFree f (Impure as) = f as >>= foldFree f

-- In paper
foldFree' :: Functor f => (a -> b) -> (f b -> b) -> Free f a -> b
foldFree' pure imp (Pure x) = pure x
foldFree' pure imp (Impure t) = imp (fmap (foldFree' pure imp) t)

newtype Mem = Mem Int deriving (Show)

class Functor f => Run f where
    runAlg :: f (Mem -> (a, Mem)) -> (Mem -> (a, Mem))

instance Run IncrF where
    runAlg (IncrF k r) (Mem i) = r (Mem (i + k))

instance Run RecallF where
    runAlg (RecallF r) (Mem i) = r i (Mem i)

instance (Run f, Run g) => Run (f :+: g) where
    runAlg (InL e1) = runAlg e1
    runAlg (InR e2) = runAlg e2

run :: Run f => Free f a -> Mem -> (a, Mem)
run = foldFree' (,) runAlg

----------------------------------------
-- main
----------------------------------------
main = do
    print $ run tick (Mem 4)

http://www.staff.science.uu.nl/~swier004/publications/2008-jfp.pdf