Projection.hs

{-# 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 stateName stateDefault events = do
  -- Make event sum type
  let eventTypeName = nameBase stateName ++ "Event"
  -- Make event sum type
  sumTypeDecls <- constructSumType eventTypeName defaultSumTypeOptions events

  -- Make function to handle events from sum type to handlers.
  let handleFuncName = mkName $ "handle" ++ eventTypeName
  handleFuncType <- [t|$(conT stateName) -> $(conT $ mkName eventTypeName) -> $(conT stateName)|]
  handleFuncBodies <- mapM (handleFuncBody stateName) events
  let handleTypeDecls =
        [ SigD handleFuncName handleFuncType,
          FunD handleFuncName handleFuncBodies
        ]

  -- Make the projection type
  projectionType <- [t|Projection $(conT stateName) $(conT $ mkName eventTypeName)|]
  let projectionTypeName = mkName $ nameBase stateName ++ "Projection"
      projectionTypeDecl = TySynD projectionTypeName [] projectionType

  -- Make the projection
  projectionFuncExpr <- [e|Projection $(varE stateDefault) $(varE handleFuncName)|]
  let projectionFuncName = mkName $ firstCharToLower (nameBase stateName) ++ "Projection"
      projectionFuncClause = Clause [] (NormalB projectionFuncExpr) []
      projectionDecls =
        [ SigD projectionFuncName (ConT projectionTypeName),
          FunD projectionFuncName [projectionFuncClause]
        ]

  return $ sumTypeDecls ++ handleTypeDecls ++ [projectionTypeDecl] ++ projectionDecls

handleFuncBody :: Name -> Name -> Q Clause
handleFuncBody stateName event = do
  let statePattern = VarP (mkName "state")
      eventPattern = ConP (mkName $ nameBase stateName ++ nameBase event) [] [VarP (mkName "event")]
      handleFuncName = mkName $ "handle" ++ nameBase event
  constructor <- [e|$(varE handleFuncName) $(varE $ mkName "state") $(varE $ mkName "event")|]
  return $ Clause [statePattern, eventPattern] (NormalB constructor) []

firstCharToLower :: String -> String
firstCharToLower [] = []
firstCharToLower (x : xs) = toLower x : xs