From c1a1b47aeae5846661a83a43c05e4b4a1e24266a Mon Sep 17 00:00:00 2001
From: Eugen Wissner <belka@caraus.de>
Date: Sat, 13 Feb 2021 06:56:10 +0100
Subject: [PATCH] Add OrderedMap prototype

---
 graphql.cabal                                 |  6 +-
 package.yaml                                  |  1 +
 src/Language/GraphQL/Execute/OrderedMap.hs    | 64 +++++++++++++++++++
 .../GraphQL/Execute/OrderedMapSpec.hs         | 17 +++++
 4 files changed, 87 insertions(+), 1 deletion(-)
 create mode 100644 src/Language/GraphQL/Execute/OrderedMap.hs
 create mode 100644 tests/Language/GraphQL/Execute/OrderedMapSpec.hs

diff --git a/graphql.cabal b/graphql.cabal
index c06dba4..152af00 100644
--- a/graphql.cabal
+++ b/graphql.cabal
@@ -4,7 +4,7 @@ cabal-version: 2.2
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 15a0880180192f918ba0bd3b3e955c57232f1efe8993745d505fcb6e1aab1451
+-- hash: dcf3c9aaaaef892c7f75781a0c181c77477fc5bb2757704494c398b99f7fb1c7
 
 name:           graphql
 version:        0.11.1.0
@@ -43,6 +43,7 @@ library
       Language.GraphQL.Error
       Language.GraphQL.Execute
       Language.GraphQL.Execute.Coerce
+      Language.GraphQL.Execute.OrderedMap
       Language.GraphQL.Type
       Language.GraphQL.Type.In
       Language.GraphQL.Type.Out
@@ -72,6 +73,7 @@ library
     , text
     , transformers
     , unordered-containers
+    , vector
   default-language: Haskell2010
 
 test-suite graphql-test
@@ -84,6 +86,7 @@ test-suite graphql-test
       Language.GraphQL.AST.ParserSpec
       Language.GraphQL.ErrorSpec
       Language.GraphQL.Execute.CoerceSpec
+      Language.GraphQL.Execute.OrderedMapSpec
       Language.GraphQL.ExecuteSpec
       Language.GraphQL.Type.OutSpec
       Language.GraphQL.Validate.RulesSpec
@@ -114,4 +117,5 @@ test-suite graphql-test
     , text
     , transformers
     , unordered-containers
+    , vector
   default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
index da9eefd..448353e 100644
--- a/package.yaml
+++ b/package.yaml
@@ -38,6 +38,7 @@ dependencies:
 - text
 - transformers
 - unordered-containers
+- vector
 
 library:
   source-dirs: src
diff --git a/src/Language/GraphQL/Execute/OrderedMap.hs b/src/Language/GraphQL/Execute/OrderedMap.hs
new file mode 100644
index 0000000..ae50dd3
--- /dev/null
+++ b/src/Language/GraphQL/Execute/OrderedMap.hs
@@ -0,0 +1,64 @@
+{- 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/. -}
+
+{-# LANGUAGE ExplicitForAll #-}
+module Language.GraphQL.Execute.OrderedMap
+    ( OrderedMap
+    , singleton
+    ) where
+
+import Data.HashMap.Strict (HashMap)
+import qualified Data.HashMap.Strict as HashMap
+import Data.Text (Text)
+import Data.Vector (Vector)
+import qualified Data.Vector as Vector
+
+data OrderedMap v = OrderedMap (Vector Text) (HashMap Text v)
+
+instance Functor OrderedMap where
+    fmap f (OrderedMap vector hashMap) = OrderedMap vector $ fmap f hashMap
+
+instance Foldable OrderedMap where
+    foldr f = foldrWithKey $ const f
+    null (OrderedMap vector _) = Vector.null vector
+
+instance Show v => Show (OrderedMap v) where
+    showsPrec precedence map' = showParen (precedence > 10)
+        $ showString "fromList " . shows (toList map')
+
+instance Semigroup (OrderedMap v) where
+    (<>) = foldrWithKey go
+      where
+        go key value accumulator@(OrderedMap vector hashMap)
+            | Nothing <- HashMap.lookup key hashMap
+                = OrderedMap (Vector.snoc vector key)
+                $ HashMap.insert key value hashMap
+            | otherwise = accumulator
+
+instance Monoid (OrderedMap v) where
+    mempty = OrderedMap mempty mempty
+
+-- * Construction
+
+-- | Constructs a map with a single element.
+singleton :: forall v. Text -> v -> OrderedMap v
+singleton key value = OrderedMap (Vector.singleton key)
+    $ HashMap.singleton key value
+
+-- * Folds
+
+-- | Reduces this map by applying a binary operator to all elements, using the
+-- given starting value.
+foldrWithKey :: forall v a. (Text -> v -> a -> a) -> a -> OrderedMap v -> a
+foldrWithKey f initial (OrderedMap vector hashMap) = foldr go initial vector
+  where
+    go key accumulator = f key (hashMap HashMap.! key) accumulator
+
+-- * Lists
+
+-- | Converts this map to the list of key-value pairs.
+toList :: forall v. OrderedMap v -> [(Text, v)]
+toList = foldrWithKey f []
+  where
+    f key value accumulator = (key, value) : accumulator
diff --git a/tests/Language/GraphQL/Execute/OrderedMapSpec.hs b/tests/Language/GraphQL/Execute/OrderedMapSpec.hs
new file mode 100644
index 0000000..35d311c
--- /dev/null
+++ b/tests/Language/GraphQL/Execute/OrderedMapSpec.hs
@@ -0,0 +1,17 @@
+{- 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/. -}
+
+{-# LANGUAGE OverloadedStrings #-}
+module Language.GraphQL.Execute.OrderedMapSpec
+    ( spec
+    ) where
+
+import Language.GraphQL.Execute.OrderedMap (OrderedMap)
+import Test.Hspec (Spec, describe, it, shouldSatisfy)
+
+spec :: Spec
+spec =
+    describe "OrderedMap" $
+        it "creates an empty map" $
+            (mempty :: OrderedMap Int) `shouldSatisfy` null