eventful-core 0.1.1 → 0.1.2

raw patch · 13 files changed

+185/−232 lines, 13 filesdep +sum-type-boilerplatePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: sum-type-boilerplate

API changes (from Hackage documentation)

Files

• eventful-core.cabal +4/−8
• src/Eventful/Aggregate.hs +25/−6
• src/Eventful/ProcessManager.hs +19/−55
• src/Eventful/Projection.hs +42/−0
• src/Eventful/ReadModel/Class.hs +4/−1
• src/Eventful/Serializer.hs +4/−1
• src/Eventful/Store/Class.hs +70/−7
• src/Eventful/TH.hs +0/−1
• src/Eventful/TH/Projection.hs +3/−2
• src/Eventful/TH/SumType.hs +0/−51
• src/Eventful/TH/SumTypeSerializer.hs +11/−79
• tests/Eventful/SerializerSpec.hs +3/−0
• tests/Eventful/TH/SumTypeSpec.hs +0/−21

@@ -3,7 +3,7 @@ -- see: https://github.com/sol/hpack  name:           eventful-core-version:        0.1.1+version:        0.1.2 synopsis:       Core module for eventful description:    Core module for eventful category:       Database,Eventsourcing@@ -27,7 +27,6 @@ library   hs-source-dirs:       src-  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies   ghc-options: -Wall   build-depends:       base >= 4.9 && < 5@@ -35,6 +34,7 @@     , containers     , http-api-data     , path-pieces+    , sum-type-boilerplate     , template-haskell     , text     , transformers@@ -50,7 +50,6 @@       Eventful.Store.Class       Eventful.TH       Eventful.TH.Projection-      Eventful.TH.SumType       Eventful.TH.SumTypeSerializer       Eventful.UUID   default-language: Haskell2010@@ -61,7 +60,6 @@   hs-source-dirs:       tests       src-  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies   ghc-options: -Wall   build-depends:       base >= 4.9 && < 5@@ -69,6 +67,7 @@     , containers     , http-api-data     , path-pieces+    , sum-type-boilerplate     , template-haskell     , text     , transformers@@ -77,7 +76,6 @@     , HUnit   other-modules:       Eventful.SerializerSpec-      Eventful.TH.SumTypeSpec       HLint       Eventful       Eventful.Aggregate@@ -89,7 +87,6 @@       Eventful.Store.Class       Eventful.TH       Eventful.TH.Projection-      Eventful.TH.SumType       Eventful.TH.SumTypeSerializer       Eventful.UUID   default-language: Haskell2010@@ -99,7 +96,6 @@   main-is: HLint.hs   hs-source-dirs:       tests-  default-extensions: ConstraintKinds DeriveFunctor DeriveGeneric DeriveTraversable FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving MultiParamTypeClasses OverloadedStrings QuasiQuotes RankNTypes RecordWildCards ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeFamilies   ghc-options: -Wall   build-depends:       base >= 4.9 && < 5@@ -107,6 +103,7 @@     , containers     , http-api-data     , path-pieces+    , sum-type-boilerplate     , template-haskell     , text     , transformers@@ -114,6 +111,5 @@     , hlint   other-modules:       Eventful.SerializerSpec-      Eventful.TH.SumTypeSpec       Spec   default-language: Haskell2010

@@ -4,12 +4,14 @@   ( Aggregate (..)   , allAggregateStates   , commandStoredAggregate+  , serializedAggregate   ) where  import Data.Foldable (foldl') import Data.List (scanl')  import Eventful.Projection+import Eventful.Serializer import Eventful.Store.Class import Eventful.UUID @@ -18,17 +20,17 @@ -- service, it is common to simply load the latest projection state from the -- event store and handle the command. If the command is valid then the new -- events are applied to the projection in the event store.-data Aggregate state event cmd =+data Aggregate state event command =   Aggregate-  { aggregateCommandHandler :: state -> cmd -> [event]+  { aggregateCommandHandler :: state -> command -> [event]   , aggregateProjection :: Projection state event   }  -- | Given a list commands, produce all of the states the aggregate's -- projection sees. This is useful for unit testing aggregates. allAggregateStates-  :: Aggregate state event cmd-  -> [cmd]+  :: Aggregate state event command+  -> [command]   -> [state] allAggregateStates (Aggregate commandHandler (Projection seed eventHandler)) events =   scanl' go seed events@@ -41,9 +43,9 @@ commandStoredAggregate   :: (Monad m)   => EventStore serialized m-  -> Aggregate state serialized cmd+  -> Aggregate state serialized command   -> UUID-  -> cmd+  -> command   -> m [serialized] commandStoredAggregate store (Aggregate handler proj) uuid command = do   (latest, vers) <- getLatestProjection store proj uuid@@ -52,3 +54,20 @@   case mError of     (Just err) -> error $ "TODO: Create aggregate restart logic. " ++ show err     Nothing -> return events++-- | Use a pair of 'Serializer's to wrap a 'Aggregate' with event type @event@+-- and command type @command@ so it uses the @serializedEvent@ and+-- @serializedCommand@ types.+serializedAggregate+  :: Aggregate state event command+  -> Serializer event serializedEvent+  -> Serializer command serializedCommand+  -> Aggregate state serializedEvent serializedCommand+serializedAggregate (Aggregate commandHandler projection) eventSerializer commandSerializer =+  Aggregate serializedHandler serializedProjection'+  where+    serializedProjection' = serializedProjection projection eventSerializer+    -- Try to deserialize the command and apply the handler. If we can't+    -- deserialize, then just return no events. We also need to serialize the+    -- events after of course.+    serializedHandler state = map (serialize eventSerializer) . maybe [] (commandHandler state) . deserialize commandSerializer

@@ -1,9 +1,10 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE RecordWildCards #-}+ module Eventful.ProcessManager   ( ProcessManager (..)   , ProcessManagerCommand (..)-  , ProcessManagerEvent (..)-  , ProcessManagerRouter (..)-  , processManagerHandler+  , applyProcessManagerCommandsAndEvents   ) where  import Control.Monad (forM_, void)@@ -14,15 +15,15 @@ import Eventful.UUID  -- | A 'ProcessManager' manages interaction between aggregates. It works by--- listening to events on an event bus (see 'processManagerHandler') and--- applying events to its internal 'Projection'. Then, pending commands and--- events are plucked off of that Projection and applied to the appropriate--- Aggregates or Projections in other streams.+-- listening to events on an event bus and applying events to its internal+-- 'Projection' (see 'applyProcessManagerCommandsAndEvents'). Then, pending+-- commands and events are plucked off of that Projection and applied to the+-- appropriate Aggregates or Projections in other streams. data ProcessManager state event command   = ProcessManager-  { processManagerProjection :: Projection state event+  { processManagerProjection :: Projection state (ProjectionEvent event)   , processManagerPendingCommands :: state -> [ProcessManagerCommand event command]-  , processManagerPendingEvents :: state -> [ProcessManagerEvent event]+  , processManagerPendingEvents :: state -> [ProjectionEvent event]   }  -- | This is a @command@ along with the UUID of the target 'Aggregate', and@@ -37,56 +38,19 @@  instance (Show command, Show event) => Show (ProcessManagerCommand event command) where   show (ProcessManagerCommand uuid _ command) =-    "ProcessManagerCommand{ processManagerCommandAggregateId = " ++ show uuid ++-    ", processManagerCommandCommand = " ++ show command---- | This is an @event@ paired with the UUID of the stream to which the event--- will be applied.-data ProcessManagerEvent event-  = ProcessManagerEvent-  { processManagerEventProjectionId :: UUID-  , processManagerEventEvent :: event-  } deriving (Show, Eq)---- | A 'ProcessManagerRouter' decides which process manager projection ID to--- use for a given event.-data ProcessManagerRouter state event command-  = ProcessManagerRouter-  { processManagerRouterGetManagerId :: UUID -> event -> Maybe UUID-    -- TODO: Should this really be just "Maybe UUID"? We should consider-    -- allowing UUID creation as well when the first event for a process comes-    -- in so we know every process manager has a unique UUID. We could make an-    -- ADT for ProcessManagerRouteResult that returns either the UUID, a value-    -- saying we need to make a UUID, or a value saying the manager ignores-    -- that event.-  , processManagerRouterManager :: ProcessManager state event command-  }---- | This is an event handler for a 'ProcessManager' that applies all events to--- the 'ProcessManagerRouter', and then applied any pending commands or events--- to the appropriate places.-processManagerHandler-  :: (Monad m)-  => ProcessManagerRouter state event command-  -> EventStore event m-  -> UUID-  -> event-  -> m ()-processManagerHandler (ProcessManagerRouter getManagerId manager) store eventAggregateId event =-  maybe (return ()) (processManagerHandler' manager store event) (getManagerId eventAggregateId event)+    "ProcessManagerCommand{processManagerCommandAggregateId = " ++ show uuid +++    ", processManagerCommandCommand = " ++ show command ++ "}" -processManagerHandler'+-- | Plucks the pending commands and events off of the process manager's state+-- and applies them to the appropriate locations in the event store.+applyProcessManagerCommandsAndEvents   :: (Monad m)   => ProcessManager state event command   -> EventStore event m-  -> event-  -> UUID+  -> state   -> m ()-processManagerHandler' ProcessManager{..} store startEvent managerId = do-  -- TODO: Don't ignore storage errors-  _ <- storeEvents store AnyVersion managerId [startEvent]-  (managerState, _) <- getLatestProjection store processManagerProjection managerId-  forM_ (processManagerPendingCommands managerState) $ \(ProcessManagerCommand aggregateId aggregate command) ->+applyProcessManagerCommandsAndEvents ProcessManager{..} store state = do+  forM_ (processManagerPendingCommands state) $ \(ProcessManagerCommand aggregateId aggregate command) ->     void $ commandStoredAggregate store aggregate aggregateId command-  forM_ (processManagerPendingEvents managerState) $ \(ProcessManagerEvent projectionId event) ->+  forM_ (processManagerPendingEvents state) $ \(ProjectionEvent projectionId event) ->     storeEvents store AnyVersion projectionId [event]

@@ -1,14 +1,20 @@+{-# LANGUAGE RecordWildCards #-}+ module Eventful.Projection   ( Projection (..)   , latestProjection   , allProjections   , getLatestProjection+  , getLatestGlobalProjection+  , serializedProjection   )   where  import Data.Foldable (foldl') import Data.List (scanl')+import Data.Maybe (fromMaybe) +import Eventful.Serializer import Eventful.Store.Class import Eventful.UUID @@ -55,3 +61,39 @@   where     maxEventVersion [] = -1     maxEventVersion es = maximum $ storedEventVersion <$> es++-- | Gets globally ordered events from the event store and builds a+-- 'Projection' based on 'ProjectionEvent'. Optionally accepts the current+-- projection state as an argument.+getLatestGlobalProjection+  :: (Monad m)+  => GloballyOrderedEventStore serialized m+  -> Projection proj (ProjectionEvent serialized)+  -> Maybe (proj, SequenceNumber)+  -> m (proj, SequenceNumber)+getLatestGlobalProjection store proj mCurrentState = do+  let+    currentState = fromMaybe (projectionSeed proj) $ fst <$> mCurrentState+    startingSequenceNumber = maybe 0 (+1) $ snd <$> mCurrentState+  events <- getSequencedEvents store startingSequenceNumber+  let+    projectionEvents = globallyOrderedEventToProjectionEvent <$> events+    latestState = foldl' (projectionEventHandler proj) currentState projectionEvents+    latestSeq =+      case events of+        [] -> startingSequenceNumber+        _ -> globallyOrderedEventSequenceNumber $ last events+  return (latestState, latestSeq)++-- | Use a 'Serializer' to wrap a 'Projection' with event type @event@ so it+-- uses the @serialized@ type.+serializedProjection+  :: Projection state event+  -> Serializer event serialized+  -> Projection state serialized+serializedProjection (Projection seed eventHandler) Serializer{..} =+  Projection seed serializedHandler+  where+    -- Try to deserialize the event and apply the handler. If we can't+    -- deserialize, then just return the state.+    serializedHandler state = maybe state (eventHandler state) . deserialize

@@ -1,3 +1,6 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+ module Eventful.ReadModel.Class   ( ReadModel (..)   , runPollingReadModel@@ -13,7 +16,7 @@   ReadModel   { readModelModel :: model   , readModelLatestAppliedSequence :: model -> m SequenceNumber-  , readModelHandleEvents :: model -> [GloballyOrderedEvent (StoredEvent serialized)] -> m ()+  , readModelHandleEvents :: model -> [GloballyOrderedEvent serialized] -> m ()   }  type PollingPeriodSeconds = Double

@@ -1,4 +1,7 @@ {-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeOperators #-}  module Eventful.Serializer@@ -137,7 +140,7 @@   GloballyOrderedEventStore getSequencedEvents'   where     getSequencedEvents' sequenceNumber =-      mapMaybe (traverse (traverse deserialize)) <$> getSequencedEvents store sequenceNumber+      mapMaybe (traverse deserialize) <$> getSequencedEvents store sequenceNumber  -- | This is a type class for serializing sum types of events to 'Dynamic' -- without the associated constructor. This is useful when transforming between

@@ -1,3 +1,9 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+ module Eventful.Store.Class   ( -- * EventStore     EventStore (..)@@ -5,8 +11,13 @@   , ExpectedVersion (..)   , EventWriteError (..)     -- * Utility types+  , ProjectionEvent (..)   , StoredEvent (..)+  , storedEventToProjectionEvent   , GloballyOrderedEvent (..)+  , globallyOrderedEventToStoredEvent+  , globallyOrderedEventToProjectionEvent+  , storedEventToGloballyOrderedEvent   , EventVersion (..)   , SequenceNumber (..)     -- * Utility functions@@ -39,7 +50,7 @@ -- store. newtype GloballyOrderedEventStore serialized m =   GloballyOrderedEventStore-  { getSequencedEvents :: SequenceNumber -> m [GloballyOrderedEvent (StoredEvent serialized)]+  { getSequencedEvents :: SequenceNumber -> m [GloballyOrderedEvent serialized]   }  -- | ExpectedVersion is used to assert the event stream is at a certain version@@ -90,27 +101,79 @@   then storeEvents' uuid events >> return Nothing   else return $ Just $ EventStreamNotAtExpectedVersion latestVersion +-- | A 'ProjectionEvent' is an event that is associated with a 'Projection' via+-- the projection's 'UUID'.+data ProjectionEvent event+  = ProjectionEvent+  { projectionEventProjectionId :: !UUID+    -- ^ The UUID of the 'Projection' that the event belongs to.+  , projectionEventEvent :: !event+    -- ^ The actual event type. Note that this can be a serialized event or the+    -- actual Haskell event type.+  } deriving (Show, Eq, Functor, Foldable, Traversable)+ -- | A 'StoredEvent' is an event with associated storage metadata. data StoredEvent event   = StoredEvent-  { storedEventProjectionId :: UUID+  { storedEventProjectionId :: !UUID     -- ^ The UUID of the 'Projection' that the event belongs to.-  , storedEventVersion :: EventVersion+  , storedEventVersion :: !EventVersion     -- ^ The version of the Projection corresponding to this event.-  , storedEventEvent :: event+  , storedEventEvent :: !event     -- ^ The actual event type. Note that this can be a serialized event or the     -- actual Haskell event type.   } deriving (Show, Eq, Functor, Foldable, Traversable) --- | A 'GloballyOrderedEvent' is an event that has a global 'SequenceNumber'.+storedEventToProjectionEvent :: StoredEvent event -> ProjectionEvent event+storedEventToProjectionEvent StoredEvent{..} =+  ProjectionEvent+  { projectionEventProjectionId = storedEventProjectionId+  , projectionEventEvent = storedEventEvent+  }++-- | A 'GloballyOrderedEvent' is like a 'StoredEvent' but has a global+-- 'SequenceNumber'. data GloballyOrderedEvent event   = GloballyOrderedEvent-  { globallyOrderedEventSequenceNumber :: SequenceNumber+  { globallyOrderedEventProjectionId :: !UUID+    -- ^ The UUID of the 'Projection' that the event belongs to.+  , globallyOrderedEventVersion :: !EventVersion+    -- ^ The version of the Projection corresponding to this event.+  , globallyOrderedEventSequenceNumber :: !SequenceNumber     -- ^ The global sequence number of this event.-  , globallyOrderedEventEvent :: event+  , globallyOrderedEventEvent :: !event     -- ^ The actual event type. Note that this can be a serialized event or the     -- actual Haskell event type.   } deriving (Show, Eq, Functor, Foldable, Traversable)++-- | Extract the 'StoredEvent' from a 'GloballyOrderedEvent'+globallyOrderedEventToStoredEvent :: GloballyOrderedEvent event -> StoredEvent event+globallyOrderedEventToStoredEvent GloballyOrderedEvent{..} =+  StoredEvent+  { storedEventProjectionId = globallyOrderedEventProjectionId+  , storedEventVersion = globallyOrderedEventVersion+  , storedEventEvent = globallyOrderedEventEvent+  }++-- | Extract the 'ProjectionEvent' from a 'GloballyOrderedEvent'+globallyOrderedEventToProjectionEvent :: GloballyOrderedEvent event -> ProjectionEvent event+globallyOrderedEventToProjectionEvent GloballyOrderedEvent{..} =+  ProjectionEvent+  { projectionEventProjectionId = globallyOrderedEventProjectionId+  , projectionEventEvent = globallyOrderedEventEvent+  }++-- | Convert a 'StoredEvent' to a 'GloballyOrderedEvent' by adding the+-- 'SequenceNumber'. This is mainly used by event stores to create globally+-- ordered events.+storedEventToGloballyOrderedEvent :: SequenceNumber -> StoredEvent event -> GloballyOrderedEvent event+storedEventToGloballyOrderedEvent sequenceNumber StoredEvent{..} =+  GloballyOrderedEvent+  { globallyOrderedEventProjectionId = storedEventProjectionId+  , globallyOrderedEventVersion = storedEventVersion+  , globallyOrderedEventSequenceNumber = sequenceNumber+  , globallyOrderedEventEvent = storedEventEvent+  }  -- | Event versions are a strictly increasing series of integers for each -- projection. They allow us to order the events when they are replayed, and

@@ -3,5 +3,4 @@   ) where  import Eventful.TH.Projection as X-import Eventful.TH.SumType as X import Eventful.TH.SumTypeSerializer as X

@@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}  module Eventful.TH.Projection   ( mkProjection@@ -6,9 +7,9 @@  import Data.Char (toLower) import Language.Haskell.TH+import SumTypes.TH  import Eventful.Projection-import Eventful.TH.SumType  -- | Creates a 'Projection' for a given type and a list of events. The user of -- this function also needs to provide event handlers for each event. For@@ -50,7 +51,7 @@ mkProjection stateName stateDefault events = do   -- Make event sum type   let eventTypeName = nameBase stateName ++ "Event"-  sumTypeDecls <- mkSumType eventTypeName (nameBase stateName ++) events+  sumTypeDecls <- constructSumType eventTypeName defaultSumTypeOptions events    -- Make function to handle events from sum type to handlers.   let handleFuncName = mkName $ "handle" ++ eventTypeName

@@ -1,51 +0,0 @@-module Eventful.TH.SumType-  ( mkSumType-  , mkSumType'-  ) where--import Language.Haskell.TH---- | This is a template haskell function that creates a sum type from a list of--- types. This is very useful when creating an event type for a 'Projection'--- from a list of events in your system. Here is an example:------ @---    data EventA = EventA---    data EventB = EventB---    data EventC = EventC------    mkSumType "MyEvent" ("MyEvent" ++) [''EventA, ''EventB, ''EventC]--- @------ This will produce the following sum type:------ @---    data MyEvent---      = MyEventEventA EventA---      | MyEventEventB EventB---      | MyEventEventC EventC--- @------ Note that you can use standalone deriving to derive any instances you want:------ @---    deriving instance Show MyEvent---    deriving instance Eq MyEvent--- @-mkSumType :: String -> (String -> String) -> [Name] -> Q [Dec]-mkSumType typeName mkConstructorName eventTypes = do-  let-    mkConstructor eventName =-      NormalC-      (mkName . mkConstructorName . nameBase $ eventName)-      [(Bang NoSourceUnpackedness SourceStrict, ConT eventName)]-    constructors = map mkConstructor eventTypes-  return [DataD [] (mkName typeName) [] Nothing constructors []]---- | Variant of mkSumType that just appends a @'@ to each constructor.------ @---    mkSumType' name events = mkSumType name (++ "'") events--- @-mkSumType' :: String -> [Name] -> Q [Dec]-mkSumType' name = mkSumType name (++ "'")

@@ -1,12 +1,14 @@ {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}  module Eventful.TH.SumTypeSerializer   ( mkSumTypeSerializer   ) where  import Data.Char (toLower)-import Data.List (lookup) import Language.Haskell.TH+import SumTypes.TH  -- | This is a template haskell function that creates a 'Serializer' between -- two sum types. The first sum type must be a subset of the second sum type.@@ -59,93 +61,23 @@ -- @ mkSumTypeSerializer :: String -> Name -> Name -> Q [Dec] mkSumTypeSerializer serializerName sourceType targetType = do-  -- Get the constructors for both types and match them up based on event type.-  sourceConstructors <- typeConstructors sourceType-  targetConstructors <- typeConstructors targetType-  bothConstructors <- mapM (matchConstructor targetConstructors) sourceConstructors-   -- Construct the serialization function   let-    serializeFuncName = mkName $ firstCharToLower (nameBase sourceType) ++ "To" ++ nameBase targetType-    serializeFuncClauses = map mkSerializeFunc bothConstructors-  serializeTypeDecl <- [t| $(conT sourceType) -> $(conT targetType) |]--  -- Construct the deserialization function-  let-    deserializeFuncName = mkName $ firstCharToLower (nameBase targetType) ++ "To" ++ nameBase sourceType-    wildcardDeserializeClause = Clause [WildP] (NormalB (ConE 'Nothing)) []-    deserializeFuncClauses = map mkDeserializeFunc bothConstructors ++ [wildcardDeserializeClause]-  deserializeTypeDecl <- [t| $(conT targetType) -> Maybe $(conT sourceType) |]+    serializeFuncName = firstCharToLower (nameBase sourceType) ++ "To" ++ nameBase targetType+    deserializeFuncName = firstCharToLower (nameBase targetType) ++ "To" ++ nameBase sourceType+  serializeDecls <- sumTypeConverter serializeFuncName sourceType targetType+  deserializeDecls <- partialSumTypeConverter deserializeFuncName targetType sourceType    -- Construct the serializer   serializerTypeDecl <- [t| $(conT $ mkName "Serializer") $(conT sourceType) $(conT targetType) |]-  serializerExp <- [e| $(varE $ mkName "simpleSerializer") $(varE serializeFuncName) $(varE deserializeFuncName) |]+  serializerExp <- [e| $(varE $ mkName "simpleSerializer") $(varE $ mkName serializeFuncName) $(varE $ mkName deserializeFuncName) |]   let     serializerClause = Clause [] (NormalB serializerExp) [] -  return-    [ -- Serialization-      SigD serializeFuncName serializeTypeDecl-    , FunD serializeFuncName serializeFuncClauses--      -- Deserialization-    , SigD deserializeFuncName deserializeTypeDecl-    , FunD deserializeFuncName deserializeFuncClauses--      -- Serializer-    , SigD (mkName serializerName) serializerTypeDecl+  return $+    [ SigD (mkName serializerName) serializerTypeDecl     , FunD (mkName serializerName) [serializerClause]-    ]---- | Extract the constructors and event types for the given type.-typeConstructors :: Name -> Q [(Type, Name)]-typeConstructors typeName = do-  info <- reify typeName-  case info of-    (TyConI (DataD _ _ _ _ constructors _)) -> mapM go constructors-      where-        go (NormalC name []) = fail $ "Constructor " ++ nameBase name ++ " doesn't have any arguments"-        go (NormalC name [(_, type')]) = return (type', name)-        go (NormalC name _) = fail $ "Constructor " ++ nameBase name ++ " has more than one argument"-        go _ = fail $ "Invalid constructor in " ++ nameBase typeName-    _ -> fail $ nameBase typeName ++ " must be a sum type"---- | Find the corresponding target constructor for a given source constructor.-matchConstructor :: [(Type, Name)] -> (Type, Name) -> Q BothConstructors-matchConstructor targetConstructors (type', sourceConstructor) = do-  targetConstructor <--    maybe-    (fail $ "Can't find constructor in target type corresponding to " ++ nameBase sourceConstructor)-    return-    (lookup type' targetConstructors)-  return $ BothConstructors type' sourceConstructor targetConstructor---- | Utility type to hold the source and target constructors for a given event--- type.-data BothConstructors =-  BothConstructors-  { eventType :: Type-  , sourceConstructor :: Name-  , targetConstructor :: Name-  }---- | Construct the TH function 'Clause' for the serialization function for a--- given type.-mkSerializeFunc :: BothConstructors -> Clause-mkSerializeFunc BothConstructors{..} =-  let-    patternMatch = ConP sourceConstructor [VarP (mkName "e")]-    constructor = AppE (ConE targetConstructor) (VarE (mkName "e"))-  in Clause [patternMatch] (NormalB constructor) []---- | Construct the TH function 'Clause' for the deserialization function for a--- given type.-mkDeserializeFunc :: BothConstructors -> Clause-mkDeserializeFunc BothConstructors{..} =-  let-    patternMatch = ConP targetConstructor [VarP (mkName "e")]-    constructor = AppE (ConE 'Just) (AppE (ConE sourceConstructor) (VarE (mkName "e")))-  in Clause [patternMatch] (NormalB constructor) []+    ] ++ serializeDecls ++ deserializeDecls  firstCharToLower :: String -> String firstCharToLower [] = []

@@ -1,3 +1,6 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+ module Eventful.SerializerSpec (spec) where  import Data.Dynamic

@@ -1,21 +0,0 @@-module Eventful.TH.SumTypeSpec (spec) where--import Test.Hspec--import Eventful.TH.SumType--data EventA = EventA deriving (Show, Eq)-data EventB = EventB deriving (Show, Eq)-data EventC = EventC deriving (Show, Eq)--mkSumType' "MyEvent" [''EventA, ''EventB, ''EventC]--deriving instance Show MyEvent-deriving instance Eq MyEvent--spec :: Spec-spec = do-  describe "mkSumType" $ do-    it "can create events" $ do-      -- The real utility in this test is the fact that it compiles-      length [EventA' EventA, EventB' EventB, EventC' EventC] `shouldBe` 3