content: {-# LANGUAGE QuasiQuotes #-}
  {-# LANGUAGE TemplateHaskell #-}
  
  module Eventful.TH.Projection
    ( mkProjection
    ) where
  
  import Data.Char (toLower)
  import Language.Haskell.TH
  import SumTypes.TH
  
  import Eventful.Projection
  
  -- | 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"
    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
  