{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}

module Eventium.TH.Projection
  ( mkProjection,
  )
where

import Data.Char (toLower)
import Eventium.Projection
import Language.Haskell.TH
import SumTypesX.TH

-- | 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
-- example:
--
-- @
--    data EventA = EventA
--    data EventB = EventB
--
--    data MyState = MyState Int
--
--    myStateDefault :: MyState
--    myStateDefault = MyState 0
--
--    mkProjection ''MyState 'myStateDefault [''EventA, ''EventB]
--
--    handleEventA :: MyState -> EventA -> MyState
--    handleEventA (MyState x) EventA = MyState (x + 1)
--
--    handleEventB :: MyState -> EventB -> MyState
--    handleEventB (MyState x) EventB = MyState (x - 1)
-- @
--
-- This will produce the following:
--
-- @
--    data MyStateEvent = MyStateEventA !EventA | MyStateEventB !EventB
--
--    handleMyStateEvent :: MyState -> MyStateEvent -> MyState
--    handleMyStateEvent state (MyStateEventA event) = handleEventA state event
--    handleMyStateEvent state (MyStateEventB event) = handleEventB state event
--
--    type MyStateProjection = Projection MyState MyStateEvent
--
--    myStateProjection :: MyStateProjection
--    myStateProjection = Projection myStateDefault handleMyStateEvent
-- @
mkProjection :: Name -> Name -> [Name] -> Q [Dec]
mkProjection :: Name -> Name -> [Name] -> Q [Dec]
mkProjection Name
stateName Name
stateDefault [Name]
events = do
  -- Make event sum type
  let eventTypeName :: [Char]
eventTypeName = Name -> [Char]
nameBase Name
stateName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Event"
  -- Make event sum type
  [Dec]
sumTypeDecls <- [Char] -> SumTypeOptions -> [Name] -> Q [Dec]
constructSumType [Char]
eventTypeName SumTypeOptions
defaultSumTypeOptions [Name]
events

  -- Make function to handle events from sum type to handlers.
  let handleFuncName :: Name
handleFuncName = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"handle" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
eventTypeName
  Type
handleFuncType <- [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
stateName) -> $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
eventTypeName) -> $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
stateName)|]
  [Clause]
handleFuncBodies <- (Name -> Q Clause) -> [Name] -> Q [Clause]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Name -> Name -> Q Clause
handleFuncBody Name
stateName) [Name]
events
  let handleTypeDecls :: [Dec]
handleTypeDecls =
        [ Name -> Type -> Dec
SigD Name
handleFuncName Type
handleFuncType,
          Name -> [Clause] -> Dec
FunD Name
handleFuncName [Clause]
handleFuncBodies
        ]

  -- Make the projection type
  Type
projectionType <- [t|Projection $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
stateName) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
eventTypeName)|]
  let projectionTypeName :: Name
projectionTypeName = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
stateName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Projection"
      projectionTypeDecl :: Dec
projectionTypeDecl = Name -> [TyVarBndr BndrVis] -> Type -> Dec
TySynD Name
projectionTypeName [] Type
projectionType

  -- Make the projection
  Exp
projectionFuncExpr <- [e|Projection $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
stateDefault) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
handleFuncName)|]
  let projectionFuncName :: Name
projectionFuncName = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
firstCharToLower (Name -> [Char]
nameBase Name
stateName) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"Projection"
      projectionFuncClause :: Clause
projectionFuncClause = [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
projectionFuncExpr) []
      projectionDecls :: [Dec]
projectionDecls =
        [ Name -> Type -> Dec
SigD Name
projectionFuncName (Name -> Type
ConT Name
projectionTypeName),
          Name -> [Clause] -> Dec
FunD Name
projectionFuncName [Clause
projectionFuncClause]
        ]

  [Dec] -> Q [Dec]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec] -> Q [Dec]) -> [Dec] -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ [Dec]
sumTypeDecls [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
handleTypeDecls [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec
projectionTypeDecl] [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
projectionDecls

handleFuncBody :: Name -> Name -> Q Clause
handleFuncBody :: Name -> Name -> Q Clause
handleFuncBody Name
stateName Name
event = do
  let statePattern :: Pat
statePattern = Name -> Pat
VarP ([Char] -> Name
mkName [Char]
"state")
      eventPattern :: Pat
eventPattern = Name -> [Type] -> [Pat] -> Pat
ConP ([Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
nameBase Name
stateName [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameBase Name
event) [] [Name -> Pat
VarP ([Char] -> Name
mkName [Char]
"event")]
      handleFuncName :: Name
handleFuncName = [Char] -> Name
mkName ([Char] -> Name) -> [Char] -> Name
forall a b. (a -> b) -> a -> b
$ [Char]
"handle" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
nameBase Name
event
  Exp
constructor <- [e|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
handleFuncName) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"state") $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Char] -> Name
mkName [Char]
"event")|]
  Clause -> Q Clause
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> Q Clause) -> Clause -> Q Clause
forall a b. (a -> b) -> a -> b
$ [Pat] -> Body -> [Dec] -> Clause
Clause [Pat
statePattern, Pat
eventPattern] (Exp -> Body
NormalB Exp
constructor) []

firstCharToLower :: String -> String
firstCharToLower :: [Char] -> [Char]
firstCharToLower [] = []
firstCharToLower (Char
x : [Char]
xs) = Char -> Char
toLower Char
x Char -> [Char] -> [Char]
forall a. a -> [a] -> [a]
: [Char]
xs