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

module Eventium.TH.SumTypeSerializer
  ( mkSumTypeSerializer,
  )
where

import Data.Char (toLower)
import Language.Haskell.TH
import SumTypesX.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.
-- This is useful in situations where you define all the events in your system
-- in one type, and you want to create sum types that are subsets for each
-- 'Projection'.
--
-- For example, assume we have the following three event types and two sum
-- types holding these events:
--
-- @
--    data EventA = EventA
--    data EventB = EventB
--    data EventC = EventC
--
--    data AllEvents
--      = AllEventsEventA EventA
--      | AllEventsEventB EventB
--      | AllEventsEventC EventC
--
--    data MyEvents
--      = MyEventsEventA EventA
--      | MyEventsEventB EventB
-- @
--
-- In this case, @AllEvents@ holds all the events in our system, and @MyEvents@
-- holds some subset of @AllEvents@. If we run
--
-- @
--    mkSumTypeSerializer "myEventsSerializer" ''MyEvents ''AllEvents
-- @
--
-- we will produce the following code:
--
-- @
--    -- Serialization function
--    myEventsToAllEvents :: MyEvents -> AllEvents
--    myEventsToAllEvents (MyEventsEventA e) = AllEventsEventA e
--    myEventsToAllEvents (MyEventsEventB e) = AllEventsEventB e
--
--    -- Deserialization function
--    allEventsToMyEvents :: AllEvents -> Maybe MyEvents
--    allEventsToMyEvents (AllEventsEventA e) = Just (MyEventsEventA e)
--    allEventsToMyEvents (AllEventsEventB e) = Just (MyEventsEventB e)
--    allEventsToMyEvents _ = Nothing
--
--    -- Serializer
--    myEventsSerializer :: Serializer MyEvents AllEvents
--    myEventsSerializer = simpleSerializer myEventsToAllEvents allEventsToMyEvents
-- @
mkSumTypeSerializer :: String -> Name -> Name -> Q [Dec]
mkSumTypeSerializer :: String -> Name -> Name -> Q [Dec]
mkSumTypeSerializer String
serializerName Name
sourceType Name
targetType = do
  -- Construct the serialization function
  let serializeFuncName :: String
serializeFuncName = String -> String
firstCharToLower (Name -> String
nameBase Name
sourceType) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"To" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
targetType
      deserializeFuncName :: String
deserializeFuncName = String -> String
firstCharToLower (Name -> String
nameBase Name
targetType) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"To" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
nameBase Name
sourceType
  -- Generate the sum type converter functions
  [Dec]
serializeDecls <- String -> Name -> Name -> Q [Dec]
sumTypeConverter String
serializeFuncName Name
sourceType Name
targetType
  [Dec]
deserializeDecls <- String -> Name -> Name -> Q [Dec]
partialSumTypeConverter String
deserializeFuncName Name
targetType Name
sourceType

  -- Construct the serializer
  Type
serializerTypeDecl <- [t|$(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT (Name -> Q Type) -> Name -> Q Type
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"Serializer") $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
sourceType) $(Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
targetType)|]
  Exp
serializerExp <- [e|$(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
"simpleSerializer") $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
serializeFuncName) $(Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ String -> Name
mkName String
deserializeFuncName)|]
  let serializerClause :: Clause
serializerClause = [Pat] -> Body -> [Dec] -> Clause
Clause [] (Exp -> Body
NormalB Exp
serializerExp) []

  [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
$
    [ Name -> Type -> Dec
SigD (String -> Name
mkName String
serializerName) Type
serializerTypeDecl,
      Name -> [Clause] -> Dec
FunD (String -> Name
mkName String
serializerName) [Clause
serializerClause]
    ]
      [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
serializeDecls
      [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
deserializeDecls

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