Utils.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.App.Internal.Resolving.Utils
  ( ResolverValue (..),
    requireObject,
    NamedResolverRef (..),
    ObjectTypeResolver,
    lookupResJSON,
    mkValue,
    ResolverMonad,
    withField,
    withObject,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Aeson (Value (..))
import Data.Morpheus.App.Internal.Resolving.ResolverState
  ( ResolverContext (..),
    updateCurrentType,
  )
import Data.Morpheus.App.Internal.Resolving.Types
  ( NamedResolverRef (..),
    ObjectTypeResolver (..),
    ResolverValue (..),
    mkBoolean,
    mkList,
    mkNull,
    mkObjectMaybe,
    mkString,
  )
import Data.Morpheus.Error (subfieldsNotSelected)
import Data.Morpheus.Internal.Utils (IsMap (..), selectOr, toAssoc, (<:>))
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    GQLError,
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TypeDefinition (..),
    TypeName,
    UnionTag (..),
    VALID,
    decodeScientific,
    internal,
    packName,
    unpackName,
  )
import Data.Morpheus.Types.SelectionTree (SelectionTree (..))
import Data.Text (breakOnEnd, splitOn)
import Relude hiding (break)

type ResolverMonad m = (MonadError GQLError m, MonadReader ResolverContext m)

lookupResJSON ::
  (ResolverMonad f, MonadReader ResolverContext m) =>
  FieldName ->
  Value ->
  f (ObjectTypeResolver m)
lookupResJSON name (Object fields) =
  selectOr
    mkEmptyObject
    (requireObject <=< mkValue)
    (unpackName name)
    fields
lookupResJSON _ _ = mkEmptyObject

mkEmptyObject :: (Monad m) => m (ObjectTypeResolver a)
mkEmptyObject = pure $ ObjectTypeResolver mempty

mkValue ::
  ( MonadReader ResolverContext f,
    MonadReader ResolverContext m
  ) =>
  Value ->
  f (ResolverValue m)
mkValue (Object v) = pure $ mkObjectMaybe typename fields
  where
    typename = lookup "__typename" v >>= unpackJSONName
    fields = map (bimap packName mkValue) (toAssoc v)
mkValue (Array ls) = mkList <$> traverse mkValue (toList ls)
mkValue Null = pure mkNull
mkValue (Number x) = pure $ ResScalar (decodeScientific x)
mkValue (String txt) = case withSelf txt of
  ARG name -> do
    sel <- asks currentSelection
    mkValue (fromMaybe Null (getArgument name sel))
  NoAPI v -> pure $ mkString v
mkValue (Bool x) = pure $ mkBoolean x

data SelfAPI
  = ARG Text
  | NoAPI Text

withSelf :: Text -> SelfAPI
withSelf txt = case breakOnEnd "::" txt of
  ("@SELF::", field) -> case splitOn "." field of
    ["ARG", name] -> ARG name
    _ -> NoAPI txt
  _ -> NoAPI txt

requireObject :: (MonadError GQLError f) => ResolverValue m -> f (ObjectTypeResolver m)
requireObject (ResObject _ x) = pure x
requireObject _ = throwError (internal "resolver must be an object")

unpackJSONName :: Value -> Maybe TypeName
unpackJSONName (String x) = Just (packName x)
unpackJSONName _ = Nothing

withField :: (Monad m') => a -> (m (ResolverValue m) -> m' a) -> FieldName -> ObjectTypeResolver m -> m' a
withField fb suc selectionName ObjectTypeResolver {..} = maybe (pure fb) suc (lookup selectionName objectFields)

withObject ::
  (ResolverMonad m) =>
  Maybe TypeName ->
  (Maybe (SelectionSet VALID) -> m value) ->
  SelectionContent VALID ->
  m value
withObject __typename f = updateCurrentType __typename . checkContent
  where
    checkContent (SelectionSet selection) = f (Just selection)
    checkContent (UnionSelection interface unionSel) = do
      typename <- asks (typeName . currentType)
      selection <- selectOr (pure interface) (fx interface) typename unionSel
      f selection
      where
        fx (Just x) y = Just <$> (x <:> unionTagSelection y)
        fx Nothing y = pure $ Just $ unionTagSelection y
    checkContent SelectionField = do
      sel <- asks currentSelection
      throwError $ subfieldsNotSelected (selectionName sel) "" (selectionPosition sel)