POC of eventsource-api using an extensible-effects interface

extensible.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs            #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE UndecidableInstances #-}
module Main where

import Control.Monad (foldM)
import Data.Foldable (for_)
import Data.Maybe (catMaybes)
import Data.Typeable (Typeable, cast)

import Control.Eff
import Control.Eff.Reader.Strict
import Control.Eff.State.Strict

type ExpectedVersion = Int
type Error = String

data StoredEvent = forall e. Typeable e => StoredEvent e

type Store = [StoredEvent]

getEvents :: [StoredEvent] -> [e]
getEvents _ = [] -- Not implemented

data EventStore a where
    Persist :: Typeable event => event -> EventStore ()
    Load    :: EventStore [StoredEvent]

persist :: (Member EventStore r, Typeable event) => event -> Eff r ()
persist event = send (Persist event)

load :: Member EventStore r => Eff r [StoredEvent]
load = send Load

emptyStore :: Store
emptyStore = []

useLocalEventStore :: Eff (EventStore ': r) a -> Eff r a
useLocalEventStore =
    handle_relay_s emptyStore (\_ a -> pure a)
                              (\store sreq k ->
                                    case sreq of
                                        Persist e -> k (StoredEvent e:store) ()
                                        Load      -> k store (reverse store))

data Agg s = Agg !s

class Aggregate r a where
    type Id a    :: *
    type Event a :: *

    apply :: a -> Event a -> Eff r a

class Aggregate r a => Validate r a where
    type Command a :: *
    type Failure a :: *

    validate :: a -> Command a -> Eff r (Either (Failure a) (Event a))

data ExternalDependency = ExternalDependency

data Foo = Foo Int

data FooCmd
    = Incr Int
    | Decr Int

data FooEvent
    = FooIncred Int
    | FooDecred Int

instance Member (Reader ExternalDependency) r => Aggregate r Foo where
    type Id Foo    = String
    type Event Foo = FooEvent

    apply (Foo i) evt = do
        fooDep :: ExternalDependency <- ask -- Not useful, just making a point :-)
        case evt of
            FooIncred n -> pure (Foo $ i + n)
            FooDecred n -> pure (Foo $ i - n)

instance Member (Reader ExternalDependency) r => Validate r Foo where
    type Command Foo = FooCmd
    type Failure Foo = String

    validate (Foo i) cmd =
        case cmd of
            Incr n ->
                if n + i > 10
                then pure (Left "You can't have Foo > 10")
                else pure (Right $ FooIncred n)

            Decr n ->
                if i - n < 0
                then pure (Left "You can't have Foo < 0")
                else pure (Right $ FooDecred n)


loadAgg :: (Member EventStore r, Aggregate r a) => a -> Eff r (Agg a)
loadAgg seed = do
    evts  <- getEvents <$> load
    state <- foldM apply seed evts
    pure (Agg state)

main :: IO ()
main = do

  let app :: Eff '[EventStore, Reader ExternalDependency] (Agg Foo)
      app = loadAgg (Foo 0)

      temp :: Eff '[Reader ExternalDependency] (Agg Foo)
      temp = useLocalEventStore app

      temp2 :: Eff '[] (Agg Foo)
      temp2 = runReader ExternalDependency temp

      result :: Agg Foo
      result = run temp2

  putStrLn "Extensible effects are really expressive!"