Schema.hs

{-# LANGUAGE DeriveGeneric     #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE TypeFamilies      #-}
{-# LANGUAGE TypeOperators     #-}

module Data.Morpheus.Schema.Schema
  ( initSchema
  , findType
  , Schema
  , Type
  ) where

import           Data.Morpheus.Kind                                (OBJECT)
import           Data.Morpheus.Schema.Directive                    (Directive)
import           Data.Morpheus.Schema.Internal.RenderIntrospection (Type, createObjectType, renderType)
import           Data.Morpheus.Types.GQLType                       (GQLType (KIND, __typeName, __typeVisibility))
import           Data.Morpheus.Types.Internal.Data                 (DataOutputObject, DataTypeLib (..), allDataTypes)
import           Data.Text                                         (Text)
import           GHC.Generics                                      (Generic)

instance GQLType Schema where
  type KIND Schema = OBJECT
  __typeName = const "__Schema"
  __typeVisibility = const False

data Schema = Schema
  { types            :: [Type]
  , queryType        :: Type
  , mutationType     :: Maybe Type
  , subscriptionType :: Maybe Type
  , directives       :: [Directive Type]
  } deriving (Generic)

convertTypes :: DataTypeLib -> [Type]
convertTypes lib =
  case traverse (`renderType` lib) (allDataTypes lib) of
    Left _  -> []
    Right x -> x

buildSchemaLinkType :: (Text, DataOutputObject) -> Type
buildSchemaLinkType (key', _) = createObjectType key' "" $ Just []

findType :: Text -> DataTypeLib -> Maybe Type
findType name lib = (name, ) <$> lookup name (allDataTypes lib) >>= renderT
  where
    renderT i =
      case renderType i lib of
        Left _  -> Nothing
        Right x -> Just x

initSchema :: DataTypeLib -> Schema
initSchema types' =
  Schema
    { types = convertTypes types'
    , queryType = buildSchemaLinkType $ query types'
    , mutationType = buildSchemaLinkType <$> mutation types'
    , subscriptionType = buildSchemaLinkType <$> subscription types'
    , directives = []
    }