{-# LANGUAGE DataKinds #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.Declare.Type
  ( typeDeclarations,
  )
where

import Data.Morpheus.Client.Internal.Types
  ( ClientConstructorDefinition (..),
    ClientTypeDefinition (..),
    TypeNameTH (..),
  )
import Data.Morpheus.Client.Internal.Utils
  ( isEnum,
  )
import Data.Morpheus.CodeGen.Internal.TH
  ( camelCaseTypeName,
    declareTypeRef,
    toCon,
    toName,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    FieldDefinition (..),
    FieldName,
    TypeKind (..),
    TypeName,
    VALID,
  )
import Language.Haskell.TH
import Relude hiding (Type)

typeDeclarations :: TypeKind -> [ClientTypeDefinition -> Q Dec]
typeDeclarations :: TypeKind -> [ClientTypeDefinition -> Q Dec]
typeDeclarations TypeKind
KindScalar = []
typeDeclarations TypeKind
_ = [Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec)
-> (ClientTypeDefinition -> Dec) -> ClientTypeDefinition -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientTypeDefinition -> Dec
declareType]

declareType :: ClientTypeDefinition -> Dec
declareType :: ClientTypeDefinition -> Dec
declareType
  ClientTypeDefinition
    { clientTypeName :: ClientTypeDefinition -> TypeNameTH
clientTypeName = thName :: TypeNameTH
thName@TypeNameTH {[FieldName]
namespace :: TypeNameTH -> [FieldName]
namespace :: [FieldName]
namespace, TypeName
typename :: TypeNameTH -> TypeName
typename :: TypeName
typename},
      [ClientConstructorDefinition]
clientCons :: ClientTypeDefinition -> [ClientConstructorDefinition]
clientCons :: [ClientConstructorDefinition]
clientCons
    } =
    Cxt
-> Name
-> [TyVarBndr]
-> Maybe Kind
-> [Con]
-> [DerivClause]
-> Dec
DataD
      []
      ([FieldName] -> TypeName -> Name
mkConName [FieldName]
namespace TypeName
typename)
      []
      Maybe Kind
forall a. Maybe a
Nothing
      (TypeNameTH -> [ClientConstructorDefinition] -> [Con]
declareCons TypeNameTH
thName [ClientConstructorDefinition]
clientCons)
      ((Name -> DerivClause) -> [Name] -> [DerivClause]
forall a b. (a -> b) -> [a] -> [b]
map Name -> DerivClause
derive [''Generic, ''Show, ''Eq])
    where
      derive :: Name -> DerivClause
derive Name
className = Maybe DerivStrategy -> Cxt -> DerivClause
DerivClause Maybe DerivStrategy
forall a. Maybe a
Nothing [Name -> Kind
ConT Name
className]

declareCons :: TypeNameTH -> [ClientConstructorDefinition] -> [Con]
declareCons :: TypeNameTH -> [ClientConstructorDefinition] -> [Con]
declareCons TypeNameTH {[FieldName]
namespace :: [FieldName]
namespace :: TypeNameTH -> [FieldName]
namespace, TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename} [ClientConstructorDefinition]
clientCons
  | [ClientConstructorDefinition] -> Bool
isEnum [ClientConstructorDefinition]
clientCons = (ClientConstructorDefinition -> Con)
-> [ClientConstructorDefinition] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map ClientConstructorDefinition -> Con
consE [ClientConstructorDefinition]
clientCons
  | Bool
otherwise = (ClientConstructorDefinition -> Con)
-> [ClientConstructorDefinition] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map ClientConstructorDefinition -> Con
consR [ClientConstructorDefinition]
clientCons
  where
    consE :: ClientConstructorDefinition -> Con
consE ClientConstructorDefinition {TypeName
cName :: ClientConstructorDefinition -> TypeName
cName :: TypeName
cName} = Name -> [BangType] -> Con
NormalC ([FieldName] -> TypeName -> TypeName -> Name
mkTypeName [FieldName]
namespace TypeName
typename TypeName
cName) []
    consR :: ClientConstructorDefinition -> Con
consR ClientConstructorDefinition {TypeName
cName :: TypeName
cName :: ClientConstructorDefinition -> TypeName
cName, [FieldDefinition ANY VALID]
cFields :: ClientConstructorDefinition -> [FieldDefinition ANY VALID]
cFields :: [FieldDefinition ANY VALID]
cFields} =
      Name -> [VarBangType] -> Con
RecC
        ([FieldName] -> TypeName -> Name
mkConName [FieldName]
namespace TypeName
cName)
        ((FieldDefinition ANY VALID -> VarBangType)
-> [FieldDefinition ANY VALID] -> [VarBangType]
forall a b. (a -> b) -> [a] -> [b]
map FieldDefinition ANY VALID -> VarBangType
declareField [FieldDefinition ANY VALID]
cFields)

declareField :: FieldDefinition ANY VALID -> (Name, Bang, Type)
declareField :: FieldDefinition ANY VALID -> VarBangType
declareField FieldDefinition {FieldName
fieldName :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> FieldName
fieldName :: FieldName
fieldName, TypeRef
fieldType :: forall (cat :: TypeCategory) (s :: Stage).
FieldDefinition cat s -> TypeRef
fieldType :: TypeRef
fieldType} =
  ( FieldName -> Name
forall a. ToName a => a -> Name
toName FieldName
fieldName,
    SourceUnpackedness -> SourceStrictness -> Bang
Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness,
    (TypeName -> Kind) -> TypeRef -> Kind
declareTypeRef TypeName -> Kind
forall a b. ToCon a b => a -> b
toCon TypeRef
fieldType
  )

mkTypeName :: [FieldName] -> TypeName -> TypeName -> Name
mkTypeName :: [FieldName] -> TypeName -> TypeName -> Name
mkTypeName [FieldName]
namespace TypeName
typename = [FieldName] -> TypeName -> Name
mkConName [FieldName]
namespace (TypeName -> Name) -> (TypeName -> TypeName) -> TypeName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TypeName] -> TypeName -> TypeName
forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [TypeName
typename]

mkConName :: [FieldName] -> TypeName -> Name
mkConName :: [FieldName] -> TypeName -> Name
mkConName [FieldName]
namespace = TypeName -> Name
forall a. ToName a => a -> Name
toName (TypeName -> Name) -> (TypeName -> TypeName) -> TypeName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FieldName] -> TypeName -> TypeName
forall (t :: NAME). [Name t] -> TypeName -> TypeName
camelCaseTypeName [FieldName]
namespace