{-# 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
  ( ClientConsD,
    ClientTypeDefinition (..),
    TypeNameTH (..),
  )
import Data.Morpheus.Client.Internal.Utils
  ( isEnum,
  )
import Data.Morpheus.Internal.TH
  ( declareTypeRef,
    nameSpaceType,
    toCon,
    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},
      [ClientConsD ANY]
clientCons :: ClientTypeDefinition -> [ClientConsD ANY]
clientCons :: [ClientConsD ANY]
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 -> [ClientConsD ANY] -> [Con]
declareCons TypeNameTH
thName [ClientConsD ANY]
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 -> [ClientConsD ANY] -> [Con]
declareCons :: TypeNameTH -> [ClientConsD ANY] -> [Con]
declareCons TypeNameTH {[FieldName]
namespace :: [FieldName]
namespace :: TypeNameTH -> [FieldName]
namespace, TypeName
typename :: TypeName
typename :: TypeNameTH -> TypeName
typename} [ClientConsD ANY]
clientCons
  | [ClientConsD ANY] -> Bool
forall f. [ConsD f] -> Bool
isEnum [ClientConsD ANY]
clientCons = (ClientConsD ANY -> Con) -> [ClientConsD ANY] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map ClientConsD ANY -> Con
forall f. ConsD f -> Con
consE [ClientConsD ANY]
clientCons
  | Bool
otherwise = (ClientConsD ANY -> Con) -> [ClientConsD ANY] -> [Con]
forall a b. (a -> b) -> [a] -> [b]
map ClientConsD ANY -> Con
consR [ClientConsD ANY]
clientCons
  where
    consE :: ConsD f -> Con
consE ConsD {TypeName
cName :: forall f. ConsD f -> 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 :: ClientConsD ANY -> Con
consR ConsD {TypeName
cName :: TypeName
cName :: forall f. ConsD f -> TypeName
cName, [FieldDefinition ANY VALID]
cFields :: forall f. ConsD f -> [f]
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
  )

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