From d280cd835fb8eb17faa39183b4e75127eba5c7c0 Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Sun, 20 Oct 2024 17:13:39 +0200
Subject: [PATCH] Add gql quasi quoter

---
 CHANGELOG.md                        |  4 +++
 graphql-spice.cabal                 |  2 +-
 src/Language/GraphQL/Class.hs       | 39 +++++++++++++++++++++++++++++
 tests/Language/GraphQL/ClassSpec.hs | 13 ++++++++++
 4 files changed, 57 insertions(+), 1 deletion(-)

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 5eae607..bc44c57 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -7,6 +7,10 @@ and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
 ## [Unreleased]
+### Added
+- `gql` quasi quoter which generates a string literal with the first line
+  starting at the first column and all following lines indented relative to the
+  first line.
 
 ## [1.0.3.0] - 2024-07-20
 ### Added
diff --git a/graphql-spice.cabal b/graphql-spice.cabal
index d69e11d..21e6a00 100644
--- a/graphql-spice.cabal
+++ b/graphql-spice.cabal
@@ -16,7 +16,7 @@ license-files:      LICENSE
 build-type:         Simple
 extra-source-files: CHANGELOG.md
 tested-with:
-  GHC == 9.4.8
+  GHC == 9.8.2
 
 source-repository head
   type: git
diff --git a/src/Language/GraphQL/Class.hs b/src/Language/GraphQL/Class.hs
index df52d2b..938fcf0 100644
--- a/src/Language/GraphQL/Class.hs
+++ b/src/Language/GraphQL/Class.hs
@@ -13,6 +13,7 @@ module Language.GraphQL.Class
     , ToGraphQL(..)
     , deriveFromGraphQL
     , deriveToGraphQL
+    , gql
     ) where
 
 import Data.Int (Int8, Int16, Int32, Int64)
@@ -45,6 +46,7 @@ import Language.Haskell.TH
     , Dec(..)
     , Exp(..)
     , Info(..)
+    , Lit(..)
     , Quote(..)
     , Name
     , Q
@@ -72,6 +74,7 @@ import Language.Haskell.TH
     , litP
     , wildP
     )
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
 import Data.Foldable (Foldable(..))
 import qualified Data.HashMap.Strict as HashMap
 import qualified Language.GraphQL.Type as Type
@@ -438,3 +441,39 @@ deriveToGraphQL typeName = do
         [ litE (stringL $ nameBase name')
         , [|toGraphQL $(varE alias)|]
         ]
+
+stripIndentation :: String -> String
+stripIndentation code = reverse
+    $ dropWhile isLineBreak
+    $ reverse
+    $ unlines
+    $ indent spaces <$> lines' withoutLeadingNewlines
+  where
+    indent 0 xs = xs
+    indent count (' ' : xs) = indent (count - 1) xs
+    indent _ xs = xs
+    withoutLeadingNewlines = dropWhile isLineBreak code
+    spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
+    lines' "" = []
+    lines' string =
+        let (line, rest) = break isLineBreak string
+            reminder =
+                case rest of
+                    [] -> []
+                    '\r' : '\n' : strippedString -> lines' strippedString
+                    _ : strippedString -> lines' strippedString
+         in line : reminder
+    isLineBreak = flip any ['\n', '\r'] . (==)
+
+-- | Removes leading and trailing newlines. Indentation of the first line is
+-- removed from each line of the string.
+gql :: QuasiQuoter
+gql = QuasiQuoter
+    { quoteExp = pure . LitE . StringL . stripIndentation
+    , quotePat = const
+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a pattern)"
+    , quoteType = const
+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a type)"
+    , quoteDec = const
+        $ fail "Illegal gql QuasiQuote (allowed as expression only, used as a declaration)"
+    }
diff --git a/tests/Language/GraphQL/ClassSpec.hs b/tests/Language/GraphQL/ClassSpec.hs
index 7e6c4cf..758b913 100644
--- a/tests/Language/GraphQL/ClassSpec.hs
+++ b/tests/Language/GraphQL/ClassSpec.hs
@@ -3,6 +3,7 @@
    obtain one at https://mozilla.org/MPL/2.0/. -}
 
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE TemplateHaskell #-}
 module Language.GraphQL.ClassSpec
     ( spec
@@ -17,6 +18,7 @@ import Language.GraphQL.Class
     , ToGraphQL(..)
     , deriveFromGraphQL
     , deriveToGraphQL
+    , gql
     )
 import Test.Hspec (Spec, describe, it, shouldBe)
 import qualified Data.HashMap.Strict as HashMap
@@ -159,3 +161,14 @@ spec = do
             let given = Type.Enum "TWO_FIELD_ENUM_2"
                 expected = TWO_FIELD_ENUM_2
              in fromGraphQL given `shouldBe` Just expected
+
+    describe "gql" $
+        it "replaces CRNL with NL" $
+            let expected :: Text
+                expected = "line1\nline2\nline3"
+                actual = [gql|
+                  line1
+                  line2
+                  line3
+                |]
+             in actual `shouldBe` expected