DDD/Event Sourcing in Haskell. Implemented an aggregate as a type class and type families to couple event, command and error types specific to the aggregate. Errors are returned by using Either (Error e) (Event e). Applying Applicative Functors fits here well to sequentially check if the command suffice.

Aggregate.hs

{-# LANGUAGE TypeFamilies #-}

import Data.Function (on)
import Control.Applicative

data EventData e = EventData {
    eventId :: Int,
    body :: Event e
}

instance Show (EventData e) where
    show = show . eventId

instance Eq (EventData e) where
    (==) = (==) `on` eventId

instance Ord (EventData e) where
    compare = compare `on` eventId

class Aggregate s where
    data Error s :: *
    data Command s :: *
    data Event s :: *

    execute :: s -> Command s -> Either (Error s) (Event s)
    apply :: s -> Event s -> s
    seed :: s



data User = User {
    name :: String,
    email :: String
} deriving (Show)

instance Aggregate User where

    data Error User = NotAllowed
                    | TooShortUsername Int Int
                    | EmptyUsername
                    | EmptyEmail
                    deriving (Show)

    data Event User = NameChanged String 
                    | EmailChanged String 
                    deriving (Show)
    
    data Command User = ChangeName String 
                      | ChangeEmail String
                      deriving (Show) 

    _ `execute` ChangeName n = NameChanged 
        <$> validate notEmpty EmptyUsername n
        <* validate (lengthBetween 4 8) (TooShortUsername 4 8) n

    _ `execute` ChangeEmail e = EmailChanged 
        <$> validate notEmpty EmptyEmail e

    state `apply` NameChanged n = state { name = n }
    state `apply` EmailChanged e = state { email = e }

    seed = User "" ""

load :: (Aggregate a) => [EventData a] -> a
load = foldl folder seed
    where
        folder state = apply state . body

validate :: (a -> Bool) -> e -> a -> Either e a
validate f err x
    | f x = Right x
    | otherwise = Left err

notEmpty :: [a] -> Bool
notEmpty = (> 0) . length

lengthBetween :: Int -> Int -> String -> Bool
lengthBetween s e str
    | len >= s && len <= e = True
    | otherwise = False
    where len = length str

main :: IO()
main = do

    print $ load $ map (EventData 1) [NameChanged "Borak", NameChanged "Fristi", EmailChanged "[email protected]"]
    print $ execute seed $ ChangeEmail "[email protected]"
    print $ execute seed $ ChangeName "Te"

I just wanted to share that I found some utility in splitting up the Aggregate class here into Projection and Aggregate:

class Projection s where
  data Event s :: *

  seed :: s
  apply :: s -> Event s -> s

class (Projection s) => Aggregate s where
  data Command s :: *
  data Error s :: *

  execute :: s -> Command s -> Either (Error s) (Event s)

Very nice! I think it would be better for 'aggregate' to accept an arbitrary monad that 'execute' operates in (instead of encoding Error and Either in the types), that way you could interleave various effects (IO, exceptions) when executing a command.

Anybody have an example of how a repository for this aggregate would look?

@jdreaver: would you mind explaining the utility you get from adding a Projection class?

State is not an Aggregate. An aggregate is just a function which keeps invariant and produces event/error.