From a3f18932bd00661f7ecd2da724461d99a2d540ae Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Tue, 21 Sep 2021 09:37:57 +0200
Subject: [PATCH] Add TH module with gql quasi quoter

---
 CHANGELOG.md               |  1 +
 graphql.cabal              |  2 ++
 src/Language/GraphQL/TH.hs | 35 +++++++++++++++++++++++++++++++++++
 3 files changed, 38 insertions(+)
 create mode 100644 src/Language/GraphQL/TH.hs

diff --git a/CHANGELOG.md b/CHANGELOG.md
index 58fda81..16fa701 100644
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -14,6 +14,7 @@ and this project adheres to
 - Deprecation notes in the `Error` module for `Resolution`, `CollectErrsT` and
   `runCollectErrs`. These symbols are part of the old executor and aren't used
   anymore, it will be deprecated in the future and removed.
+- `TH` module with the `gql` quasi quoter.
 
 ### Fixed
 - Error messages are more concrete, they also contain type information and
diff --git a/graphql.cabal b/graphql.cabal
index f72a913..2219fed 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -39,6 +39,7 @@ library
       Language.GraphQL.Execute
       Language.GraphQL.Execute.Coerce
       Language.GraphQL.Execute.OrderedMap
+      Language.GraphQL.TH
       Language.GraphQL.Type
       Language.GraphQL.Type.In
       Language.GraphQL.Type.Out
@@ -64,6 +65,7 @@ library
     , megaparsec >= 9.0.1 && < 9.1
     , parser-combinators >= 1.3.0 && < 1.4
     , scientific >= 0.3.7 && < 0.4
+    , template-haskell >= 2.16 && < 2.18
     , text >= 1.2.4 && < 1.3
     , transformers >= 0.5.6 && < 0.6
     , unordered-containers >= 0.2.14 && < 0.3
diff --git a/src/Language/GraphQL/TH.hs b/src/Language/GraphQL/TH.hs
new file mode 100644
index 0000000..02dd7d6
--- /dev/null
+++ b/src/Language/GraphQL/TH.hs
@@ -0,0 +1,35 @@
+{- This Source Code Form is subject to the terms of the Mozilla Public License,
+   v. 2.0. If a copy of the MPL was not distributed with this file, You can
+   obtain one at https://mozilla.org/MPL/2.0/. -}
+
+-- | Template Haskell helpers.
+module Language.GraphQL.TH
+    ( gql
+    ) where
+
+import Language.Haskell.TH.Quote (QuasiQuoter(..))
+import Language.Haskell.TH (Exp(..), Lit(..))
+
+stripIndentation :: String -> String
+stripIndentation code = unlines
+    $ reverse
+    $ dropWhile null
+    $ reverse
+    $ indent spaces <$> lines withoutLeadingNewlines
+  where
+    indent 0 xs = xs
+    indent count (' ' : xs) = indent (count - 1) xs
+    indent _ xs = xs
+    withoutLeadingNewlines = dropWhile (== '\n') code
+    spaces = length $ takeWhile (== ' ') withoutLeadingNewlines
+
+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)"
+    }