From a96d4e6ef3b1020d239f0061af5861aadeb278fc Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Tue, 27 Dec 2022 10:37:34 +0100
Subject: [PATCH] Add Semigroup and Monoid instances for Description

---
 CHANGELOG.md                               |  1 +
 src/Language/GraphQL/AST/Document.hs       |  8 ++++++++
 src/Language/GraphQL/AST/Encoder.hs        | 17 ++++++++++++++++-
 tests/Language/GraphQL/AST/DocumentSpec.hs |  6 ++++++
 tests/Language/GraphQL/AST/EncoderSpec.hs  |  9 ++++++++-
 5 files changed, 39 insertions(+), 2 deletions(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index b9edb8c..4f62859 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -9,6 +9,7 @@ and this project adheres to
 ## [Unreleased]
 ### Added
 - Partial schema printing: schema definition encoder.
+- `Semigroup` and `Monoid` instances for `AST.Document.Description`.
 
 ## [1.1.0.0] - 2022-12-24
 ### Changed
diff --git a/src/Language/GraphQL/AST/Document.hs b/src/Language/GraphQL/AST/Document.hs
index ea640df..131285d 100644
--- a/src/Language/GraphQL/AST/Document.hs
+++ b/src/Language/GraphQL/AST/Document.hs
@@ -464,6 +464,14 @@ data SchemaExtension
 newtype Description = Description (Maybe Text)
     deriving (Eq, Show)
 
+instance Semigroup Description
+  where
+    Description lhs <> Description rhs = Description $ lhs <> rhs
+
+instance Monoid Description
+  where
+    mempty = Description mempty
+
 -- ** Types
 
 -- | Type definitions describe various user-defined types.
diff --git a/src/Language/GraphQL/AST/Encoder.hs b/src/Language/GraphQL/AST/Encoder.hs
index a58a161..d19b9e6 100644
--- a/src/Language/GraphQL/AST/Encoder.hs
+++ b/src/Language/GraphQL/AST/Encoder.hs
@@ -72,7 +72,8 @@ typeSystemDefinition formatter = \case
             $ optempty (directives formatter) operationDirectives
             <> "schema "
             <> bracesList formatter operationTypeDefinition (NonEmpty.toList operationTypeDefinitions')
-    _ -> "" -- TODO: TypeDefinition and DerictiveDefinition missing.
+    Full.TypeDefinition typeDefinition' -> typeDefinition formatter typeDefinition'
+    _ -> "" -- TODO: DerictiveDefinition missing.
   where
     operationTypeDefinition (Full.OperationTypeDefinition operationType' namedType')
         = indentLine (incrementIndent formatter)
@@ -80,6 +81,20 @@ typeSystemDefinition formatter = \case
         <> colon formatter
         <> Lazy.Text.fromStrict namedType'
 
+typeDefinition :: Formatter -> Full.TypeDefinition -> Lazy.Text.Text
+typeDefinition formatter = \case
+    Full.ScalarTypeDefinition description' name' directives'
+        -> optempty (description formatter) description'
+        <> "scalar "
+        <> Lazy.Text.fromStrict name'
+        <> optempty (directives formatter) directives'
+    _typeDefinition' -> "" -- TODO: Types missing.
+
+description :: Formatter -> Full.Description -> Lazy.Text.Text
+description _formatter (Full.Description Nothing) = ""
+description formatter (Full.Description (Just description')) =
+    stringValue formatter description'
+
 -- | Converts a t'Full.ExecutableDefinition' into a string.
 definition :: Formatter -> Full.ExecutableDefinition -> Lazy.Text
 definition formatter x
diff --git a/tests/Language/GraphQL/AST/DocumentSpec.hs b/tests/Language/GraphQL/AST/DocumentSpec.hs
index ca13e17..d09d6b1 100644
--- a/tests/Language/GraphQL/AST/DocumentSpec.hs
+++ b/tests/Language/GraphQL/AST/DocumentSpec.hs
@@ -18,3 +18,9 @@ spec = do
                     ]
                 expected = "{ field1: 1.2, field2: null }"
              in show object `shouldBe` expected
+
+    describe "Description" $
+        it "keeps content when merging with no description" $
+            let expected = Description $ Just "Left description"
+                actual = expected <> Description Nothing
+             in actual `shouldBe` expected
diff --git a/tests/Language/GraphQL/AST/EncoderSpec.hs b/tests/Language/GraphQL/AST/EncoderSpec.hs
index c654c0b..6b424d5 100644
--- a/tests/Language/GraphQL/AST/EncoderSpec.hs
+++ b/tests/Language/GraphQL/AST/EncoderSpec.hs
@@ -180,7 +180,7 @@ spec = do
             let actual = operationType pretty Full.Mutation
              in actual `shouldBe` "mutation"
 
-    describe "typeSystemDefinition" $
+    describe "typeSystemDefinition" $ do
         it "produces a schema with an indented operation type definition" $
             let queryType = Full.OperationTypeDefinition Full.Query "QueryRootType"
                 mutationType = Full.OperationTypeDefinition Full.Mutation "MutationType"
@@ -194,3 +194,10 @@ spec = do
                 |] '\n'
                 actual = typeSystemDefinition pretty definition'
              in actual `shouldBe` expected
+
+        it "encodes a scalar type definition" $
+            let uuidType = Full.ScalarTypeDefinition mempty "UUID" mempty
+                definition' = Full.TypeDefinition uuidType
+                expected = "scalar UUID"
+                actual = typeSystemDefinition pretty definition'
+             in actual `shouldBe` expected