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: Add gql quasi quoter

---
 src/Language/GraphQL/Class.hs | 39 +++++++++++++++++++++++++++++++++++++++
 1 file changed, 39 insertions(+)

(limited to 'src/Language')

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)"
+    }
-- 
cgit v1.2.3