Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}

module Main where

import Projectable

data CounterEvent = Created | Increased | Decreased deriving (Show)
data Counter = Counter Int deriving (Show)

instance Projectable Counter CounterEvent where
  apply Nothing Created = Right $ Counter 0
  apply Nothing _       = Left $ ProjectError "Counter not created"

  apply (Just(Counter i)) Increased = Right $ Counter $ i + 1
  apply (Just(Counter i)) Decreased = Right $ Counter $ i - 1
  apply (Just c) Created            = Right $ c

main :: IO ()
main = do
  proj <- return $ projectCounter [Created, Increased, Increased, Decreased]
  putStrLn $ show proj

projectCounter :: [CounterEvent] -> Either ProjectError Counter
projectCounter = project Nothing

Projectable.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FunctionalDependencies #-}

module Projectable (
    ProjectError(..)
  , Projectable(..)
  , project
) where

import Data.Text (Text)
import Data.List (foldl')

newtype ProjectError = ProjectError Text deriving (Show)

-- | Projects a list of events `e` to final state `s`
class Projectable s e | s -> e where
  -- | apply will be given Nothing if there is no state yet and Just s if there is.
  apply :: Maybe s -> e -> Either ProjectError s

-- | Project will generate state from the given events and can continue
-- from a given state.
project :: (Projectable s e) => Maybe s -> [e] -> Either ProjectError s
project Nothing (e:es) = (apply Nothing e) >>= \s -> project (Just s) es

project (Just s) es =
  foldl' foldEither (Right s) es

  where
    foldEither s' e = s' >>= \ns -> apply (Just ns) e

project Nothing [] = Left $ ProjectError "Unable to project state without events"