Datatypes a la carte

Datatypes-a-la-carte.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverlappingInstances #-}

data Fix f = In (f (Fix f))

--data Val e = Val e
data IntVal e = Val Int

data Add e = Add e e

-- examples
type ValExp = Fix IntVal
--ex1 :: 
--ex1 = In $ Val 9



type AddExp = Fix Add
-- :: Fix Val
-- _ = In $ Val 9

data Cprod f g e = Inl (f e) | Inr (g e)

ex :: Fix (Cprod IntVal Add)
ex = In $ Inr $ Add (In $ Inl $ Val 4) (In $ Inl $ Val 5)


-- adding another operation

data Mul e = Mul e e


-- 3 * 4 + 5
ex2 :: Fix (Cprod Mul (Cprod IntVal Add))
ex2 = In $ Inl $ Mul (In $ Inr $ Inl $ Val 3)
  (In $ Inr $ Inr $ Add
    (In $ Inr $ Inl $ Val 4)
    (In $ Inr $ Inl $ Val 5))

-- need 'In' when jumping into a new sub expression
-- use 'Inl and Inr' to 'steer' to right constructor inside nested coproducts

-- Note: although 'ex' is an encoding of 4 + 5 (using a different functor ) we cannot make it
-- a subexpression of 'ex2'


-- come back to the pain of automatically injecting constructors correctly...
-- first, look at how to evaluate one of these expressions..

instance Functor IntVal 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 e1 e2) = Mul (f e1) (f e2)

instance (Functor f, Functor g) => Functor (Cprod f g) where
  fmap f (Inl e1) = Inl (fmap f e1)
  fmap f (Inr e2) = Inr (fmap f e2)


fold :: Functor f => (f a -> a) -> Fix f -> a
fold f (In e) = f (fmap (fold f) e)

-- an algebra

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

instance Eval IntVal where
  evalAlg (Val x) = x

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

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

instance (Eval f, Eval g) => Eval (Cprod f g) where
  evalAlg (Inl x) = evalAlg x
  evalAlg (Inr y) = evalAlg y


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


-- automate injections

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

instance Functor f => (Rel f f) where
  inj = id

instance (Functor f, Functor g) => (Rel f (Cprod f g)) where
  inj = Inl

instance (Functor f, Functor g, Functor h, (Rel f g)) => (Rel f (Cprod h g)) where
  inj = Inr . inj


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


-- for each constructor
val :: Rel IntVal f => Int -> Fix f
val x = inject (Val x)

plus :: Rel Add f => Fix f -> Fix f -> Fix f
plus x y = inject (Add x y)

mul :: Rel Mul f => Fix f -> Fix f -> Fix f
mul x y = inject (Mul x y)



ex3 :: Fix IntVal
ex3 = val 8

type MAV = Fix (Cprod Mul (Cprod Add IntVal))
ex4 :: MAV
ex4 = mul (plus (val 2) (val 3)) (val 7)

type AV = Fix (Cprod Add IntVal)
-- can be given both types
--ex5 :: MAV
--ex5 :: AV
ex5 = (val 1) `plus` (val 6)