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

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

import Data.Morpheus.Client.Internal.Types
  ( ClientTypeDefinition (..),
    TypeNameTH (..),
  )
import Data.Morpheus.Internal.TH
  ( declareTypeRef,
    isEnum,
    nameSpaceType,
    toName,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    ConsD (..),
    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},
      [ConsD ANY VALID]
clientCons :: ClientTypeDefinition -> [ConsD ANY VALID]
clientCons :: [ConsD ANY VALID]
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 -> [ConsD ANY VALID] -> [Con]
declareCons TypeNameTH
thName [ConsD ANY VALID]
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 -> [ConsD ANY VALID] -> [Con]
declareCons :: TypeNameTH -> [ConsD ANY VALID] -> [Con]
declareCons TypeNameTH {[FieldName]
namespace :: [FieldName]
namespace :: TypeNameTH -> [FieldName]
namespace, TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename} [ConsD ANY VALID]
clientCons
  | [ConsD ANY VALID] -> Bool
forall (cat :: TypeCategory) (s :: Stage). [ConsD cat s] -> Bool
isEnum [ConsD ANY VALID]
clientCons = (ConsD ANY VALID -> Con) -> [ConsD ANY VALID] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map ConsD ANY VALID -> Con
forall (cat :: TypeCategory) (s :: Stage). ConsD cat s -> Con
consE [ConsD ANY VALID]
clientCons
  | Bool
otherwise = (ConsD ANY VALID -> Con) -> [ConsD ANY VALID] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map ConsD ANY VALID -> Con
consR [ConsD ANY VALID]
clientCons
  where
    consE :: ConsD cat s -> Con
consE ConsD {TypeName
cName :: forall (cat :: TypeCategory) (s :: Stage). ConsD cat s -> TypeName
cName :: TypeName
cName} = Name -> [BangType] -> Con
NormalC ([FieldName] -> TypeName -> Name
mkConName [FieldName]
namespace (TypeName
typename TypeName -> TypeName -> TypeName
forall a. Semigroup a => a -> a -> a
<> TypeName
cName)) []
    consR :: ConsD ANY VALID -> Con
consR ConsD {TypeName
cName :: TypeName
cName :: forall (cat :: TypeCategory) (s :: Stage). ConsD cat s -> TypeName
cName, [FieldDefinition ANY VALID]
cFields :: forall (cat :: TypeCategory) (s :: Stage).
ConsD cat s -> [FieldDefinition cat s]
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,
    TypeRef -> Kind
declareTypeRef TypeRef
fieldType
  )

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
nameSpaceType [FieldName]
namespace