{-# language DataKinds         #-}
{-# language OverloadedStrings #-}
{-# language TemplateHaskell   #-}
{-# language ViewPatterns      #-}
{-|
Description : Quasi-quoters for GraphQL schemas

Read @.graphql@ files as a 'Mu.Schema.Definition.Schema'
and 'Package' with one 'Service' per object in the schema.
-}
module Mu.GraphQL.Quasi (
  graphql
, graphql'
) where

import           Control.Monad.IO.Class        (liftIO)
import           Data.Coerce                   (coerce)
import qualified Data.HashMap.Strict           as HM
import           Data.List                     (foldl')
import qualified Data.Text                     as T
import qualified Data.Text.IO                  as TIO
import           Data.UUID                     (UUID)
import qualified Language.GraphQL.Draft.Syntax as GQL
import           Language.Haskell.TH

import           Mu.GraphQL.Annotations
import           Mu.GraphQL.Quasi.LostParser   (parseTypeSysDefinition)
import           Mu.Rpc
import           Mu.Schema.Definition

-- | Imports an GraphQL schema definition from a file.
graphql :: String   -- ^ Name for the 'Package' type, the 'Schema' is derived from it
        -> FilePath -- ^ Route to the file
        -> Q [Dec]
graphql :: String -> String -> Q [Dec]
graphql name :: String
name = String -> String -> String -> Q [Dec]
graphql' (String
name String -> String -> String
forall a. Semigroup a => a -> a -> a
<> "Schema") String
name

-- | Imports an GraphQL schema definition from a file.
graphql' :: String   -- ^ Name for the 'Schema' type
         -> String   -- ^ Name for the 'Package' type
         -> FilePath -- ^ Route to the file
         -> Q [Dec]
graphql' :: String -> String -> String -> Q [Dec]
graphql' scName :: String
scName svName :: String
svName file :: String
file = do
  Text
schema <- IO Text -> Q Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
TIO.readFile String
file
  case Text -> Either Text [TypeSystemDefinition]
parseTypeSysDefinition Text
schema of
    Left e :: Text
e  -> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("could not parse graphql spec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
e)
    Right p :: [TypeSystemDefinition]
p -> String -> String -> [TypeSystemDefinition] -> Q [Dec]
graphqlToDecls String
scName String
svName [TypeSystemDefinition]
p

type TypeMap   = HM.HashMap T.Text GQLType
type SchemaMap = HM.HashMap T.Text GQL.OperationType

data Result =
    GQLScalar
  | GQLSchema Type
  | GQLService Type

data GQLType =
    Enum
  | Object
  | Scalar
  | InputObject
  | Other

classifySchema :: [GQL.SchemaDefinition] -> SchemaMap
classifySchema :: [SchemaDefinition] -> SchemaMap
classifySchema = (SchemaMap -> SchemaDefinition -> SchemaMap)
-> SchemaMap -> [SchemaDefinition] -> SchemaMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SchemaMap -> SchemaDefinition -> SchemaMap
schemaToMap SchemaMap
forall k v. HashMap k v
HM.empty
  where
    schemaToMap :: SchemaMap -> GQL.SchemaDefinition -> SchemaMap
    schemaToMap :: SchemaMap -> SchemaDefinition -> SchemaMap
schemaToMap mp :: SchemaMap
mp (GQL.SchemaDefinition _ ops :: [RootOperationTypeDefinition]
ops) = (SchemaMap -> RootOperationTypeDefinition -> SchemaMap)
-> SchemaMap -> [RootOperationTypeDefinition] -> SchemaMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' SchemaMap -> RootOperationTypeDefinition -> SchemaMap
operationToKeyValue SchemaMap
mp [RootOperationTypeDefinition]
ops
    operationToKeyValue :: SchemaMap -> GQL.RootOperationTypeDefinition -> SchemaMap
    operationToKeyValue :: SchemaMap -> RootOperationTypeDefinition -> SchemaMap
operationToKeyValue mp :: SchemaMap
mp (GQL.RootOperationTypeDefinition opType :: OperationType
opType (NamedType -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name)) = Text -> OperationType -> SchemaMap -> SchemaMap
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
HM.insert Text
name OperationType
opType SchemaMap
mp

classify :: [GQL.TypeDefinition] -> TypeMap
classify :: [TypeDefinition] -> TypeMap
classify = [(Text, GQLType)] -> TypeMap
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HM.fromList ([(Text, GQLType)] -> TypeMap)
-> ([TypeDefinition] -> [(Text, GQLType)])
-> [TypeDefinition]
-> TypeMap
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TypeDefinition -> (Text, GQLType)
typeToKeyValue (TypeDefinition -> (Text, GQLType))
-> [TypeDefinition] -> [(Text, GQLType)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>)
  where
    typeToKeyValue :: GQL.TypeDefinition -> (T.Text, GQLType)
    typeToKeyValue :: TypeDefinition -> (Text, GQLType)
typeToKeyValue (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) _))             = (Text
name, GQLType
Scalar)
    typeToKeyValue (GQL.TypeDefinitionObject (GQL.ObjectTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) _ _ _))         = (Text
name, GQLType
Object)
    typeToKeyValue (GQL.TypeDefinitionInterface (GQL.InterfaceTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) _ _))     = (Text
name, GQLType
Other)
    typeToKeyValue (GQL.TypeDefinitionUnion (GQL.UnionTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) _ _))             = (Text
name, GQLType
Other)
    typeToKeyValue (GQL.TypeDefinitionEnum (GQL.EnumTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) _ _))               = (Text
name, GQLType
Enum)
    typeToKeyValue (GQL.TypeDefinitionInputObject (GQL.InputObjectTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) _ _)) = (Text
name, GQLType
InputObject)

-- | Constructs the GraphQL tree splitting between Schemas and Services.
graphqlToDecls :: String -> String -> [GQL.TypeSystemDefinition] -> Q [Dec]
graphqlToDecls :: String -> String -> [TypeSystemDefinition] -> Q [Dec]
graphqlToDecls schemaName :: String
schemaName serviceName :: String
serviceName allTypes :: [TypeSystemDefinition]
allTypes = do
  let schemaName' :: Name
schemaName'  = String -> Name
mkName String
schemaName
      serviceName' :: Name
serviceName' = String -> Name
mkName String
serviceName
      types :: [TypeDefinition]
types        = [TypeDefinition
t | GQL.TypeSystemDefinitionType t :: TypeDefinition
t <- [TypeSystemDefinition]
allTypes]
      schTypes :: [SchemaDefinition]
schTypes     = [SchemaDefinition
t | GQL.TypeSystemDefinitionSchema t :: SchemaDefinition
t <- [TypeSystemDefinition]
allTypes]
      typeMap :: TypeMap
typeMap      = [TypeDefinition] -> TypeMap
classify [TypeDefinition]
types
      schMap :: SchemaMap
schMap       = [SchemaDefinition] -> SchemaMap
classifySchema [SchemaDefinition]
schTypes
  [Result]
rs <- (TypeDefinition -> Q Result) -> [TypeDefinition] -> Q [Result]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (Name -> TypeMap -> SchemaMap -> TypeDefinition -> Q Result
typeToDec Name
schemaName' TypeMap
typeMap SchemaMap
schMap) [TypeDefinition]
types
  let schemaTypes :: [Type]
schemaTypes  = [Type
x | GQLSchema  x :: Type
x <- [Result]
rs]
      serviceTypes :: [Type]
serviceTypes = [Type
x | GQLService x :: Type
x <- [Result]
rs]
  Dec
schemaDec <- Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD Name
schemaName' [] (Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ [Type] -> Type
typesToList [Type]
schemaTypes)
  Dec
serviceDec <- Name -> [TyVarBndr] -> TypeQ -> DecQ
tySynD Name
serviceName' []
    [t| 'Package ('Just $(textToStrLit $ T.pack serviceName))
                  $(pure $ typesToList serviceTypes) |]
  [Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Dec
schemaDec, Dec
serviceDec]

-- | Reads a GraphQL 'TypeDefinition' and returns a 'Result'.
typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result
typeToDec :: Name -> TypeMap -> SchemaMap -> TypeDefinition -> Q Result
typeToDec schemaName :: Name
schemaName tm :: TypeMap
tm _ (GQL.TypeDefinitionScalar (GQL.ScalarTypeDefinition _ s :: Name
s _)) =
  Result
GQLScalar Result -> TypeQ -> Q Result
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Name -> TypeMap -> Name -> TypeQ
gqlTypeToType Name
s TypeMap
tm Name
schemaName
typeToDec schemaName :: Name
schemaName tm :: TypeMap
tm sm :: SchemaMap
sm (GQL.TypeDefinitionObject objs :: ObjectTypeDefinition
objs) = ObjectTypeDefinition -> Q Result
objToDec ObjectTypeDefinition
objs
  where
    objToDec :: GQL.ObjectTypeDefinition -> Q Result
    objToDec :: ObjectTypeDefinition -> Q Result
objToDec (GQL.ObjectTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
nm) _ _ flds :: [FieldDefinition]
flds) =
      Type -> Result
GQLService (Type -> Result) -> TypeQ -> Q Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t| 'Service $(textToStrLit nm) '[]
          $(typesToList <$> traverse (gqlFieldToType nm) flds) |]
    gqlFieldToType :: T.Text -> GQL.FieldDefinition -> Q Type
    gqlFieldToType :: Text -> FieldDefinition -> TypeQ
gqlFieldToType sn :: Text
sn (GQL.FieldDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
fnm) args :: ArgumentsDefinition
args ftyp :: GType
ftyp _) =
      [t| 'Method $(textToStrLit fnm) '[]
            $(typesToList <$> traverse argToType args)
            $(returnType sn ftyp)|]
    returnType :: T.Text -> GQL.GType -> Q Type
    returnType :: Text -> GType -> TypeQ
returnType serviceName :: Text
serviceName typ :: GType
typ =
      case Text -> SchemaMap -> Maybe OperationType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
serviceName SchemaMap
sm of
        Just GQL.OperationTypeSubscription -> [t|'RetStream $(retToType typ)|]
        _                                  -> [t|'RetSingle $(retToType typ)|]
    argToType :: GQL.InputValueDefinition -> Q Type
    argToType :: InputValueDefinition -> TypeQ
argToType (GQL.InputValueDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
aname) atype :: GType
atype Nothing) =
      [t| 'ArgSingle ('Just $(textToStrLit aname)) '[] $(retToType atype) |]
    argToType (GQL.InputValueDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
aname) atype :: GType
atype (Just defs :: DefaultValue
defs)) =
      [t| 'ArgSingle ('Just $(textToStrLit aname))
                      '[DefaultValue $( defToVConst defs )] $(retToType atype) |]
    defToVConst :: GQL.DefaultValue -> Q Type
    defToVConst :: DefaultValue -> TypeQ
defToVConst (GQL.VCInt _)                         = [t| 'VCInt |]
    defToVConst (GQL.VCFloat _)                       = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "floats as default arguments are not supported"
    defToVConst (GQL.VCString (StringValue -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
s))          = [t| 'VCString $(textToStrLit s) |]
    defToVConst (GQL.VCBoolean _)                     = [t| 'VCBoolean|]
    defToVConst GQL.VCNull                            = [t| 'VCNull |]
    defToVConst (GQL.VCEnum (EnumValue -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
e))            = [t| 'VCEnum $(textToStrLit e) |]
    defToVConst (GQL.VCList (GQL.ListValueG xs :: [DefaultValue]
xs))      = [t| 'VCList $(typesToList <$> traverse defToVConst xs) |]
    defToVConst (GQL.VCObject (GQL.ObjectValueG obj :: [ObjectFieldG DefaultValue]
obj)) = [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |]
    fromGQLField :: GQL.ObjectFieldG GQL.ValueConst -> Q Type
    fromGQLField :: ObjectFieldG DefaultValue -> TypeQ
fromGQLField (GQL.ObjectFieldG (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
n) v :: DefaultValue
v)   = [t| ($(textToStrLit n), $(defToVConst v)) |]
    retToType :: GQL.GType -> Q Type
    retToType :: GType -> TypeQ
retToType (GQL.TypeNamed (Nullability -> Bool
forall a b. Coercible a b => a -> b
coerce -> Bool
False) (NamedType -> Name
forall a b. Coercible a b => a -> b
coerce -> Name
a)) =
      [t| $(gqlTypeToType a tm schemaName) |]
    retToType (GQL.TypeNamed (Nullability -> Bool
forall a b. Coercible a b => a -> b
coerce -> Bool
True) (NamedType -> Name
forall a b. Coercible a b => a -> b
coerce -> Name
a)) =
      [t| 'OptionalRef $(gqlTypeToType a tm schemaName) |]
    retToType (GQL.TypeList (Nullability -> Bool
forall a b. Coercible a b => a -> b
coerce -> Bool
False) (ListType -> GType
forall a b. Coercible a b => a -> b
coerce -> GType
a)) =
      [t| 'ListRef $(retToType a) |]
    retToType (GQL.TypeList (Nullability -> Bool
forall a b. Coercible a b => a -> b
coerce -> Bool
True) (ListType -> GType
forall a b. Coercible a b => a -> b
coerce -> GType
a)) =
      [t| 'OptionalRef ('ListRef $(retToType a)) |]
    retToType _ = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "this should not happen, please, file an issue"
typeToDec _ _ _ (GQL.TypeDefinitionInterface _)       = String -> Q Result
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "interface types are not supported"
typeToDec _ _ _ (GQL.TypeDefinitionUnion _)           = String -> Q Result
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "union types are not supported"
typeToDec _ _ _ (GQL.TypeDefinitionEnum enums :: EnumTypeDefinition
enums)        = EnumTypeDefinition -> Q Result
enumToDecl EnumTypeDefinition
enums
  where
    enumToDecl :: GQL.EnumTypeDefinition -> Q Result
    enumToDecl :: EnumTypeDefinition -> Q Result
enumToDecl (GQL.EnumTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) _ symbols :: [EnumValueDefinition]
symbols) =
      Type -> Result
GQLSchema (Type -> Result) -> TypeQ -> Q Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|'DEnum $(textToStrLit name)
                              $(typesToList <$> traverse gqlChoiceToType symbols)|]
    gqlChoiceToType :: GQL.EnumValueDefinition -> Q Type
    gqlChoiceToType :: EnumValueDefinition -> TypeQ
gqlChoiceToType (GQL.EnumValueDefinition _ (EnumValue -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
c) _) =
      [t|'ChoiceDef $(textToStrLit c)|]
typeToDec _ _ _ (GQL.TypeDefinitionInputObject inpts :: InputObjectTypeDefinition
inpts) = InputObjectTypeDefinition -> Q Result
inputObjToDec InputObjectTypeDefinition
inpts
  where
    inputObjToDec :: GQL.InputObjectTypeDefinition -> Q Result
    inputObjToDec :: InputObjectTypeDefinition -> Q Result
inputObjToDec (GQL.InputObjectTypeDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) _ fields :: ArgumentsDefinition
fields) =
        Type -> Result
GQLSchema (Type -> Result) -> TypeQ -> Q Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [t|'DRecord $(textToStrLit name)
                                  $(typesToList <$> traverse gqlFieldToType fields)|]
    gqlFieldToType :: GQL.InputValueDefinition -> Q Type
    gqlFieldToType :: InputValueDefinition -> TypeQ
gqlFieldToType (GQL.InputValueDefinition _ (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
fname) ftype :: GType
ftype _) =
      [t|'FieldDef $(textToStrLit fname) $(ginputTypeToType ftype)|]
    ginputTypeToType :: GQL.GType -> Q Type
    ginputTypeToType :: GType -> TypeQ
ginputTypeToType (GQL.TypeNamed (Nullability -> Bool
forall a b. Coercible a b => a -> b
coerce -> Bool
False) (NamedType -> Name
forall a b. Coercible a b => a -> b
coerce -> Name
a)) =
      [t| $(typeToPrimType a) |]
    ginputTypeToType (GQL.TypeNamed (Nullability -> Bool
forall a b. Coercible a b => a -> b
coerce -> Bool
True) (NamedType -> Name
forall a b. Coercible a b => a -> b
coerce -> Name
a)) =
      [t| 'OptionalRef $(typeToPrimType a) |]
    ginputTypeToType (GQL.TypeList (Nullability -> Bool
forall a b. Coercible a b => a -> b
coerce -> Bool
False) (ListType -> GType
forall a b. Coercible a b => a -> b
coerce -> GType
a)) =
      [t| 'ListRef $(ginputTypeToType a) |]
    ginputTypeToType (GQL.TypeList (Nullability -> Bool
forall a b. Coercible a b => a -> b
coerce -> Bool
True) (ListType -> GType
forall a b. Coercible a b => a -> b
coerce -> GType
a)) =
      [t| 'OptionalRef ('ListRef $(ginputTypeToType a)) |]
    ginputTypeToType _ = String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "this should not happen, please, file an issue"
    typeToPrimType :: GQL.Name -> Q Type
    typeToPrimType :: Name -> TypeQ
typeToPrimType (Name -> Text
GQL.unName -> Text
"Int")     = [t|'TPrimitive Integer|]
    typeToPrimType (Name -> Text
GQL.unName -> Text
"Float")   = [t|'TPrimitive Double|]
    typeToPrimType (Name -> Text
GQL.unName -> Text
"String")  = [t|'TPrimitive T.Text|]
    typeToPrimType (Name -> Text
GQL.unName -> Text
"Boolean") = [t|'TPrimitive Bool|]
    typeToPrimType (Name -> Text
GQL.unName -> Text
"ID")      = [t|'TPrimitive UUID|]
    typeToPrimType (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name)          = [t|'TSchematic $(textToStrLit name)|]

gqlTypeToType :: GQL.Name -> TypeMap -> Name -> Q Type
gqlTypeToType :: Name -> TypeMap -> Name -> TypeQ
gqlTypeToType (Name -> Text
GQL.unName -> Text
"Int") _  _     = [t|'PrimitiveRef Integer|]
gqlTypeToType (Name -> Text
GQL.unName -> Text
"Float") _ _    = [t|'PrimitiveRef Double|]
gqlTypeToType (Name -> Text
GQL.unName -> Text
"String") _ _   = [t|'PrimitiveRef T.Text|]
gqlTypeToType (Name -> Text
GQL.unName -> Text
"Boolean") _ _  = [t|'PrimitiveRef Bool|]
gqlTypeToType (Name -> Text
GQL.unName -> Text
"ID") _ _       = [t|'PrimitiveRef UUID|]
gqlTypeToType (Name -> Text
forall a b. Coercible a b => a -> b
coerce -> Text
name) tm :: TypeMap
tm schemaName :: Name
schemaName =
  let schemaRef :: TypeQ
schemaRef = [t|'SchemaRef $(conT schemaName) $(textToStrLit name)|]
   in case Text -> TypeMap -> Maybe GQLType
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HM.lookup Text
name TypeMap
tm of
        Just Enum        -> TypeQ
schemaRef
        Just InputObject -> TypeQ
schemaRef
        _                -> [t|'ObjectRef $(textToStrLit name)|]

typesToList :: [Type] -> Type
typesToList :: [Type] -> Type
typesToList = (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT) Type
PromotedNilT

textToStrLit :: T.Text -> Q Type
textToStrLit :: Text -> TypeQ
textToStrLit = TyLitQ -> TypeQ
litT (TyLitQ -> TypeQ) -> (Text -> TyLitQ) -> Text -> TypeQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLitQ
strTyLit (String -> TyLitQ) -> (Text -> String) -> Text -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack