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@gmail.com"]
    print $ execute seed $ ChangeEmail "email@gmail.com"
    print $ execute seed $ ChangeName "Te"