RenderGQL.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Rendering.RenderGQL
  ( RenderGQL (..),
    render,
    renderObject,
    renderMembers,
    newline,
    renderArguments,
    renderEntry,
    space,
    Rendering,
    fromText,
    intercalate,
    renderInputSeq,
    unwords,
    fromShow,
    nonNillSpace,
  )
where

-- MORPHEUS

import qualified Data.Aeson as A
import Data.ByteString.Lazy (ByteString)
import qualified Data.ByteString.Lazy.Char8 as LB
import Data.Foldable (foldr')
import qualified Data.Text as T
import Relude hiding
  ( ByteString,
    intercalate,
    unwords,
  )

render :: (RenderGQL a) => a -> ByteString
render x = runRendering (renderGQL x) 0

newtype Rendering = Rendering
  { runRendering :: Int -> ByteString
  }

instance Semigroup Rendering where
  Rendering f <> Rendering g = Rendering $ \x -> f x <> g x

instance IsString Rendering where
  fromString = Rendering . const . LB.pack

fromShow :: (Show a) => a -> Rendering
fromShow = fromString . show

fromText :: Text -> Rendering
fromText = fromString . T.unpack

nonNillSpace :: (Foldable t) => t a -> Rendering
nonNillSpace t
  | null t = ""
  | otherwise = space

class RenderGQL a where
  renderGQL :: a -> Rendering

instance
  (RenderGQL a) =>
  RenderGQL (Maybe a)
  where
  renderGQL = maybe "" renderGQL

instance (RenderGQL l, RenderGQL r) => RenderGQL (Either l r) where
  renderGQL (Left x) = renderGQL x
  renderGQL (Right x) = renderGQL x

instance RenderGQL ByteString where
  renderGQL = Rendering . const

instance RenderGQL Int where
  renderGQL = fromShow

instance RenderGQL Float where
  renderGQL = fromShow

instance RenderGQL Double where
  renderGQL = fromShow

instance RenderGQL Text where
  renderGQL = fromShow

instance RenderGQL Bool where
  renderGQL True = "true"
  renderGQL False = "false"

instance RenderGQL A.Value where
  renderGQL = renderGQL . A.encode

space :: Rendering
space = " "

newline :: Rendering
newline = "\n" <> Rendering indentionSize

indentionSize :: (Semigroup a, IsString a) => Int -> a
indentionSize 0 = ""
indentionSize n = stimes (n * 2) " "

indent :: Rendering -> Rendering
indent (Rendering f) = Rendering $ f . (+ 1)

unwords :: [Rendering] -> Rendering
unwords = intercalate space

intercalate :: Rendering -> [Rendering] -> Rendering
intercalate (Rendering f) fs = Rendering $ \x -> LB.intercalate (f x) (map ((x &) . runRendering) fs)

indentNewline :: Rendering -> Rendering
indentNewline rendering = indent (newline <> rendering)

renderAtNewLine :: (RenderGQL a) => [a] -> Rendering
renderAtNewLine elems = indentNewline $ intercalate newline (fmap renderGQL elems)

renderObject :: (RenderGQL a) => [a] -> Rendering
renderObject fields = space <> "{" <> renderAtNewLine fields <> newline <> "}"

renderMembers :: (RenderGQL a, Foldable t) => t a -> Rendering
renderMembers members = intercalate (space <> "|" <> space) (fmap renderGQL (toList members))

renderArguments :: (RenderGQL a) => [a] -> Rendering
renderArguments arguments
  | null arguments = ""
  | otherwise = "(" <> intercalate ", " (renderGQL <$> arguments) <> ")"

renderEntry ::
  (RenderGQL name, RenderGQL value) =>
  name ->
  value ->
  Rendering
renderEntry name value = renderGQL name <> ": " <> renderGQL value

renderInputSeq ::
  (Foldable t, RenderGQL a) =>
  t a ->
  Rendering
renderInputSeq = fromMaybe "" . foldr' renderValue Nothing
  where
    renderValue :: (RenderGQL a) => a -> Maybe Rendering -> Maybe Rendering
    renderValue value Nothing = Just (renderGQL value)
    renderValue value (Just txt) = Just (renderGQL value <> ", " <> txt)