{-# language DataKinds           #-}
{-# language FlexibleInstances   #-}
{-# language PolyKinds           #-}
{-# language ScopedTypeVariables #-}
{-# language TupleSections       #-}
{-# language TypeApplications    #-}
{-# language TypeOperators       #-}
{-# language ViewPatterns        #-}
{-|
Description : Annotations for GraphQL services

GraphQL schemas may contain some information which
cannot be directly represented in a Mu schema or
service definition. The types in this module
can be used with the annotation mechanism in Mu
to provide this additional information.
-}
module Mu.GraphQL.Annotations (
  ValueConst(..)
, DefaultValue(..)
, ReflectValueConst(..)
, fromGQLValueConst
, module Mu.Rpc.Annotations
) where

import           Control.Applicative           (Alternative (..))
import           Data.Coerce
import           Data.Proxy
import qualified Data.Text                     as T
import           GHC.TypeLits
import qualified Language.GraphQL.Draft.Syntax as GQL

import           Mu.Rpc.Annotations

-- | Specifies the default value of an argument.
--   To be used as an annotation.
newtype DefaultValue
  = DefaultValue (ValueConst Nat Symbol)

-- | Type-level GraphQL constant values.
--   Due to limitations in type-level literal values
--   floating point constants cannot be represented.
data ValueConst nat symbol
  = VCInt nat        -- ^ Integer.
  | VCString symbol  -- ^ String.
  | VCBoolean Bool   -- ^ Boolean.
  | VCNull           -- ^ Null.
  | VCEnum symbol    -- ^ Enumeration value.
  | VCList [ValueConst nat symbol]  -- ^ List of constant values.
  | VCObject [(symbol, ValueConst nat symbol)]
      -- ^ Object represented by (key, value) tuples.

-- | Turn a 'GQL.ValueConst' coming from parsing
--   in the annotation data type. Mostly used
--   internally to generate Mu schemas from GraphQL schemas.
fromGQLValueConst :: forall f. Alternative f
                  => GQL.ValueConst -> f (ValueConst Integer String)
fromGQLValueConst :: ValueConst -> f (ValueConst Integer String)
fromGQLValueConst (GQL.VCInt Integer
n)
  = ValueConst Integer String -> f (ValueConst Integer String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValueConst Integer String -> f (ValueConst Integer String))
-> ValueConst Integer String -> f (ValueConst Integer String)
forall a b. (a -> b) -> a -> b
$ Integer -> ValueConst Integer String
forall nat symbol. nat -> ValueConst nat symbol
VCInt (Integer -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
n)
fromGQLValueConst (GQL.VCString (StringValue -> Text
coerce -> Text
s))
  = ValueConst Integer String -> f (ValueConst Integer String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValueConst Integer String -> f (ValueConst Integer String))
-> ValueConst Integer String -> f (ValueConst Integer String)
forall a b. (a -> b) -> a -> b
$ String -> ValueConst Integer String
forall nat symbol. symbol -> ValueConst nat symbol
VCString (String -> ValueConst Integer String)
-> String -> ValueConst Integer String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s
fromGQLValueConst (GQL.VCBoolean Bool
b)
  = ValueConst Integer String -> f (ValueConst Integer String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValueConst Integer String -> f (ValueConst Integer String))
-> ValueConst Integer String -> f (ValueConst Integer String)
forall a b. (a -> b) -> a -> b
$ Bool -> ValueConst Integer String
forall nat symbol. Bool -> ValueConst nat symbol
VCBoolean Bool
b
fromGQLValueConst ValueConst
GQL.VCNull
  = ValueConst Integer String -> f (ValueConst Integer String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ValueConst Integer String
forall nat symbol. ValueConst nat symbol
VCNull
fromGQLValueConst (GQL.VCEnum (EnumValue -> Text
coerce -> Text
s))
  = ValueConst Integer String -> f (ValueConst Integer String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ValueConst Integer String -> f (ValueConst Integer String))
-> ValueConst Integer String -> f (ValueConst Integer String)
forall a b. (a -> b) -> a -> b
$ String -> ValueConst Integer String
forall nat symbol. symbol -> ValueConst nat symbol
VCEnum (String -> ValueConst Integer String)
-> String -> ValueConst Integer String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s
fromGQLValueConst (GQL.VCList (ListValueC -> [ValueConst]
coerce -> [ValueConst]
xs))
  = [ValueConst Integer String] -> ValueConst Integer String
forall nat symbol. [ValueConst nat symbol] -> ValueConst nat symbol
VCList ([ValueConst Integer String] -> ValueConst Integer String)
-> f [ValueConst Integer String] -> f (ValueConst Integer String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ValueConst -> f (ValueConst Integer String))
-> [ValueConst] -> f [ValueConst Integer String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ValueConst -> f (ValueConst Integer String)
forall (f :: * -> *).
Alternative f =>
ValueConst -> f (ValueConst Integer String)
fromGQLValueConst [ValueConst]
xs
fromGQLValueConst (GQL.VCObject (ObjectValueC -> [ObjectFieldG ValueConst]
coerce -> [ObjectFieldG ValueConst]
o))
  = [(String, ValueConst Integer String)] -> ValueConst Integer String
forall nat symbol.
[(symbol, ValueConst nat symbol)] -> ValueConst nat symbol
VCObject ([(String, ValueConst Integer String)]
 -> ValueConst Integer String)
-> f [(String, ValueConst Integer String)]
-> f (ValueConst Integer String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ObjectFieldG ValueConst -> f (String, ValueConst Integer String))
-> [ObjectFieldG ValueConst]
-> f [(String, ValueConst Integer String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ObjectFieldG ValueConst -> f (String, ValueConst Integer String)
fromGQLField [ObjectFieldG ValueConst]
o
  where fromGQLField :: GQL.ObjectFieldG GQL.ValueConst
                     -> f (String, ValueConst Integer String)
        fromGQLField :: ObjectFieldG ValueConst -> f (String, ValueConst Integer String)
fromGQLField (GQL.ObjectFieldG (Name -> Text
coerce -> Text
n) ValueConst
v)
          = (Text -> String
T.unpack Text
n,) (ValueConst Integer String -> (String, ValueConst Integer String))
-> f (ValueConst Integer String)
-> f (String, ValueConst Integer String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ValueConst -> f (ValueConst Integer String)
forall (f :: * -> *).
Alternative f =>
ValueConst -> f (ValueConst Integer String)
fromGQLValueConst ValueConst
v
fromGQLValueConst ValueConst
_ = f (ValueConst Integer String)
forall (f :: * -> *) a. Alternative f => f a
empty

-- | Obtain the GraphQL constant corresponding
--   to a type-level constant. Inhabited by any
--   'ValueConst', but still required to please
--   the type checker.
class ReflectValueConst (v :: ValueConst nat symbol) where
  -- | Obtain the GraphQL constant corresponding
  --   to a type-level constant.
  reflectValueConst :: proxy v -> GQL.ValueConst
instance KnownNat n => ReflectValueConst ('VCInt n) where
  reflectValueConst :: proxy ('VCInt n) -> ValueConst
reflectValueConst proxy ('VCInt n)
_ = Integer -> ValueConst
GQL.VCInt (Integer -> ValueConst) -> Integer -> ValueConst
forall a b. (a -> b) -> a -> b
$ Integer -> Integer
forall a. Num a => Integer -> a
fromInteger (Integer -> Integer) -> Integer -> Integer
forall a b. (a -> b) -> a -> b
$ Proxy n -> Integer
forall (n :: Nat) (proxy :: Nat -> *).
KnownNat n =>
proxy n -> Integer
natVal (Proxy n
forall k (t :: k). Proxy t
Proxy @n)
instance KnownSymbol s => ReflectValueConst ('VCString s) where
  reflectValueConst :: proxy ('VCString s) -> ValueConst
reflectValueConst proxy ('VCString s)
_ = StringValue -> ValueConst
GQL.VCString (StringValue -> ValueConst) -> StringValue -> ValueConst
forall a b. (a -> b) -> a -> b
$ Text -> StringValue
coerce (Text -> StringValue) -> Text -> StringValue
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy s -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy s
forall k (t :: k). Proxy t
Proxy @s)
instance ReflectValueConst ('VCBoolean 'True) where
  reflectValueConst :: proxy ('VCBoolean 'True) -> ValueConst
reflectValueConst proxy ('VCBoolean 'True)
_ = Bool -> ValueConst
GQL.VCBoolean Bool
True
instance ReflectValueConst ('VCBoolean 'False) where
  reflectValueConst :: proxy ('VCBoolean 'False) -> ValueConst
reflectValueConst proxy ('VCBoolean 'False)
_ = Bool -> ValueConst
GQL.VCBoolean Bool
False
instance ReflectValueConst 'VCNull where
  reflectValueConst :: proxy 'VCNull -> ValueConst
reflectValueConst proxy 'VCNull
_ = ValueConst
GQL.VCNull
instance KnownSymbol e => ReflectValueConst ('VCEnum e) where
  reflectValueConst :: proxy ('VCEnum e) -> ValueConst
reflectValueConst proxy ('VCEnum e)
_ = StringValue -> ValueConst
GQL.VCString (StringValue -> ValueConst) -> StringValue -> ValueConst
forall a b. (a -> b) -> a -> b
$ Text -> StringValue
coerce (Text -> StringValue) -> Text -> StringValue
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy e -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy e
forall k (t :: k). Proxy t
Proxy @e)
instance ReflectValueConstList xs => ReflectValueConst ('VCList xs) where
  reflectValueConst :: proxy ('VCList xs) -> ValueConst
reflectValueConst proxy ('VCList xs)
_ = ListValueC -> ValueConst
GQL.VCList (ListValueC -> ValueConst) -> ListValueC -> ValueConst
forall a b. (a -> b) -> a -> b
$ [ValueConst] -> ListValueC
coerce ([ValueConst] -> ListValueC) -> [ValueConst] -> ListValueC
forall a b. (a -> b) -> a -> b
$ Proxy xs -> [ValueConst]
forall k (xs :: k) (proxy :: k -> *).
ReflectValueConstList xs =>
proxy xs -> [ValueConst]
reflectValueConstList (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs)
instance ReflectValueConstObject xs => ReflectValueConst ('VCObject xs) where
  reflectValueConst :: proxy ('VCObject xs) -> ValueConst
reflectValueConst proxy ('VCObject xs)
_ = ObjectValueC -> ValueConst
GQL.VCObject (ObjectValueC -> ValueConst) -> ObjectValueC -> ValueConst
forall a b. (a -> b) -> a -> b
$ [ObjectFieldG ValueConst] -> ObjectValueC
coerce ([ObjectFieldG ValueConst] -> ObjectValueC)
-> [ObjectFieldG ValueConst] -> ObjectValueC
forall a b. (a -> b) -> a -> b
$ Proxy xs -> [ObjectFieldG ValueConst]
forall k (xs :: k) (proxy :: k -> *).
ReflectValueConstObject xs =>
proxy xs -> [ObjectFieldG ValueConst]
reflectValueConstObject (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs)

class ReflectValueConstList xs where
  reflectValueConstList :: proxy xs -> [GQL.ValueConst]
instance ReflectValueConstList '[] where
  reflectValueConstList :: proxy '[] -> [ValueConst]
reflectValueConstList proxy '[]
_ = []
instance (ReflectValueConst x, ReflectValueConstList xs)
         => ReflectValueConstList (x ': xs) where
  reflectValueConstList :: proxy (x : xs) -> [ValueConst]
reflectValueConstList proxy (x : xs)
_
    = Proxy x -> ValueConst
forall nat symbol (v :: ValueConst nat symbol)
       (proxy :: ValueConst nat symbol -> *).
ReflectValueConst v =>
proxy v -> ValueConst
reflectValueConst (Proxy x
forall k (t :: k). Proxy t
Proxy @x) ValueConst -> [ValueConst] -> [ValueConst]
forall a. a -> [a] -> [a]
: Proxy xs -> [ValueConst]
forall k (xs :: k) (proxy :: k -> *).
ReflectValueConstList xs =>
proxy xs -> [ValueConst]
reflectValueConstList (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs)

class ReflectValueConstObject xs where
  reflectValueConstObject :: proxy xs -> [GQL.ObjectFieldG GQL.ValueConst]
instance ReflectValueConstObject '[] where
  reflectValueConstObject :: proxy '[] -> [ObjectFieldG ValueConst]
reflectValueConstObject proxy '[]
_ = []
instance (KnownSymbol a, ReflectValueConst x, ReflectValueConstObject xs)
         => ReflectValueConstObject ( '(a, x) ': xs) where
  reflectValueConstObject :: proxy ('(a, x) : xs) -> [ObjectFieldG ValueConst]
reflectValueConstObject proxy ('(a, x) : xs)
_
    = Name -> ValueConst -> ObjectFieldG ValueConst
forall a. Name -> a -> ObjectFieldG a
GQL.ObjectFieldG (Text -> Name
coerce (Text -> Name) -> Text -> Name
forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy a -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy a
forall k (t :: k). Proxy t
Proxy @a)) (Proxy x -> ValueConst
forall nat symbol (v :: ValueConst nat symbol)
       (proxy :: ValueConst nat symbol -> *).
ReflectValueConst v =>
proxy v -> ValueConst
reflectValueConst (Proxy x
forall k (t :: k). Proxy t
Proxy @x))
      ObjectFieldG ValueConst
-> [ObjectFieldG ValueConst] -> [ObjectFieldG ValueConst]
forall a. a -> [a] -> [a]
: Proxy xs -> [ObjectFieldG ValueConst]
forall k (xs :: k) (proxy :: k -> *).
ReflectValueConstObject xs =>
proxy xs -> [ObjectFieldG ValueConst]
reflectValueConstObject (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs)