{-# language DataKinds           #-}
{-# language FlexibleInstances   #-}
{-# language PolyKinds           #-}
{-# language ScopedTypeVariables #-}
{-# language TupleSections       #-}
{-# language TypeApplications    #-}
{-# language TypeOperators       #-}
{-|
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.Proxy
import qualified Data.Text            as T
import           GHC.TypeLits
import qualified Language.GraphQL.AST 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.ConstValue -> f (ValueConst Integer String)
fromGQLValueConst :: ConstValue -> f (ValueConst Integer String)
fromGQLValueConst (GQL.ConstInt Int32
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 (Int32 -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
n)
fromGQLValueConst (GQL.ConstString 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.ConstBoolean 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 ConstValue
GQL.ConstNull
  = 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.ConstEnum 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.ConstList [Node ConstValue]
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
<$> (Node ConstValue -> f (ValueConst Integer String))
-> [Node ConstValue] -> f [ValueConst Integer String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (ConstValue -> f (ValueConst Integer String)
forall (f :: * -> *).
Alternative f =>
ConstValue -> f (ValueConst Integer String)
fromGQLValueConst (ConstValue -> f (ValueConst Integer String))
-> (Node ConstValue -> ConstValue)
-> Node ConstValue
-> f (ValueConst Integer String)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Node ConstValue -> ConstValue
forall a. Node a -> a
GQL.node) [Node ConstValue]
xs
fromGQLValueConst (GQL.ConstObject [ObjectField ConstValue]
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
<$> (ObjectField ConstValue -> f (String, ValueConst Integer String))
-> [ObjectField ConstValue]
-> f [(String, ValueConst Integer String)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ObjectField ConstValue -> f (String, ValueConst Integer String)
fromGQLField [ObjectField ConstValue]
o
  where fromGQLField :: GQL.ObjectField GQL.ConstValue
                     -> f (String, ValueConst Integer String)
        fromGQLField :: ObjectField ConstValue -> f (String, ValueConst Integer String)
fromGQLField (GQL.ObjectField Text
n (GQL.Node ConstValue
v Location
_) Location
_)
          = (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
<$> ConstValue -> f (ValueConst Integer String)
forall (f :: * -> *).
Alternative f =>
ConstValue -> f (ValueConst Integer String)
fromGQLValueConst ConstValue
v
fromGQLValueConst ConstValue
_ = 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.ConstValue
instance KnownNat n => ReflectValueConst ('VCInt n) where
  reflectValueConst :: proxy ('VCInt n) -> ConstValue
reflectValueConst proxy ('VCInt n)
_ = Int32 -> ConstValue
GQL.ConstInt (Int32 -> ConstValue) -> Int32 -> ConstValue
forall a b. (a -> b) -> a -> b
$ Integer -> Int32
forall a. Num a => Integer -> a
fromInteger (Integer -> Int32) -> Integer -> Int32
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) -> ConstValue
reflectValueConst proxy ('VCString s)
_ = Text -> ConstValue
GQL.ConstString (Text -> ConstValue) -> Text -> ConstValue
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) -> ConstValue
reflectValueConst proxy ('VCBoolean 'True)
_ = Bool -> ConstValue
GQL.ConstBoolean Bool
True
instance ReflectValueConst ('VCBoolean 'False) where
  reflectValueConst :: proxy ('VCBoolean 'False) -> ConstValue
reflectValueConst proxy ('VCBoolean 'False)
_ = Bool -> ConstValue
GQL.ConstBoolean Bool
False
instance ReflectValueConst 'VCNull where
  reflectValueConst :: proxy 'VCNull -> ConstValue
reflectValueConst proxy 'VCNull
_ = ConstValue
GQL.ConstNull
instance KnownSymbol e => ReflectValueConst ('VCEnum e) where
  reflectValueConst :: proxy ('VCEnum e) -> ConstValue
reflectValueConst proxy ('VCEnum e)
_ = Text -> ConstValue
GQL.ConstString (Text -> ConstValue) -> Text -> ConstValue
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) -> ConstValue
reflectValueConst proxy ('VCList xs)
_ = [Node ConstValue] -> ConstValue
GQL.ConstList ([Node ConstValue] -> ConstValue)
-> [Node ConstValue] -> ConstValue
forall a b. (a -> b) -> a -> b
$
    (ConstValue -> Node ConstValue)
-> [ConstValue] -> [Node ConstValue]
forall a b. (a -> b) -> [a] -> [b]
map (ConstValue -> Location -> Node ConstValue
forall a. a -> Location -> Node a
`GQL.Node` Word -> Word -> Location
GQL.Location Word
0 Word
0) ([ConstValue] -> [Node ConstValue])
-> [ConstValue] -> [Node ConstValue]
forall a b. (a -> b) -> a -> b
$ Proxy xs -> [ConstValue]
forall k (xs :: k) (proxy :: k -> *).
ReflectValueConstList xs =>
proxy xs -> [ConstValue]
reflectValueConstList (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs)
instance ReflectValueConstObject xs => ReflectValueConst ('VCObject xs) where
  reflectValueConst :: proxy ('VCObject xs) -> ConstValue
reflectValueConst proxy ('VCObject xs)
_ = [ObjectField ConstValue] -> ConstValue
GQL.ConstObject ([ObjectField ConstValue] -> ConstValue)
-> [ObjectField ConstValue] -> ConstValue
forall a b. (a -> b) -> a -> b
$ Proxy xs -> [ObjectField ConstValue]
forall k (xs :: k) (proxy :: k -> *).
ReflectValueConstObject xs =>
proxy xs -> [ObjectField ConstValue]
reflectValueConstObject (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs)

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

class ReflectValueConstObject xs where
  reflectValueConstObject :: proxy xs -> [GQL.ObjectField GQL.ConstValue]
instance ReflectValueConstObject '[] where
  reflectValueConstObject :: proxy '[] -> [ObjectField ConstValue]
reflectValueConstObject proxy '[]
_ = []
instance (KnownSymbol a, ReflectValueConst x, ReflectValueConstObject xs)
         => ReflectValueConstObject ( '(a, x) ': xs) where
  reflectValueConstObject :: proxy ('(a, x) : xs) -> [ObjectField ConstValue]
reflectValueConstObject proxy ('(a, x) : xs)
_
    = Text -> Node ConstValue -> Location -> ObjectField ConstValue
forall a. Text -> Node a -> Location -> ObjectField a
GQL.ObjectField (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))
                      (ConstValue -> Location -> Node ConstValue
forall a. a -> Location -> Node a
GQL.Node (Proxy x -> ConstValue
forall nat symbol (v :: ValueConst nat symbol)
       (proxy :: ValueConst nat symbol -> *).
ReflectValueConst v =>
proxy v -> ConstValue
reflectValueConst (Proxy x
forall k (t :: k). Proxy t
Proxy @x)) Location
zl)
                      Location
zl
      ObjectField ConstValue
-> [ObjectField ConstValue] -> [ObjectField ConstValue]
forall a. a -> [a] -> [a]
: Proxy xs -> [ObjectField ConstValue]
forall k (xs :: k) (proxy :: k -> *).
ReflectValueConstObject xs =>
proxy xs -> [ObjectField ConstValue]
reflectValueConstObject (Proxy xs
forall k (t :: k). Proxy t
Proxy @xs)
    where zl :: Location
zl = Word -> Word -> Location
GQL.Location Word
0 Word
0