{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module Data.Morpheus.Server.TH.Declare.Decode
( deriveDecode,
)
where
import Data.Morpheus.Internal.TH
( instanceHeadT,
nameVarP,
)
import Data.Morpheus.Server.Deriving.Decode
( Decode (..),
DecodeType (..),
)
import Data.Morpheus.Server.Internal.TH.Decode
( decodeFieldWith,
decodeObjectExpQ,
withObject,
)
import Data.Morpheus.Server.Internal.TH.Types (ServerTypeDefinition (..))
import Data.Morpheus.Types.Internal.AST
( FieldName,
ValidValue,
)
import Data.Morpheus.Types.Internal.Resolving
( Eventless,
)
import Language.Haskell.TH
(.:) :: Decode a => ValidValue -> FieldName -> Eventless a
value .: selectorName = withObject (decodeFieldWith decode selectorName) value
deriveDecode :: ServerTypeDefinition cat -> Q [Dec]
deriveDecode ServerTypeDefinition {tName, tCons = [cons]} =
pure <$> instanceD (cxt []) appHead methods
where
appHead = instanceHeadT ''DecodeType tName []
methods = [funD 'decodeType [clause argsE (normalB body) []]]
where
argsE = map nameVarP ["o"]
body = decodeObjectExpQ [|(.:)|] cons
deriveDecode _ = pure []