Replace Map with OrderedMap

CHANGELOG.md

@@ -7,6 +7,9 @@ and this project adheres to
 [Haskell Package Versioning Policy](https://pvp.haskell.org/).
 
 ## [Unreleased]
+### Added
+- `Language.GraphQL.Execute.OrderedMap` is a map data structure, that preserves
+  insertion order.
 
 ## [0.11.1.0] - 2021-02-07
 ### Added

src/Language/GraphQL/Execute/Coerce.hs

@@ -19,7 +19,6 @@ import qualified Data.Aeson as Aeson
 import Data.Int (Int32)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import Data.Map.Strict (Map)
 import Data.String (IsString(..))
 import Data.Text (Text)
 import qualified Data.Text.Lazy as Text.Lazy
@@ -27,6 +26,8 @@ import qualified Data.Text.Lazy.Builder as Text.Builder
 import qualified Data.Text.Lazy.Builder.Int as Text.Builder
 import Data.Scientific (toBoundedInteger, toRealFloat)
 import Language.GraphQL.AST (Name)
+import Language.GraphQL.Execute.OrderedMap (OrderedMap)
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
 import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.In as In
 import qualified Language.GraphQL.Type.Out as Out
@@ -209,7 +210,7 @@ data Output a
     | Boolean Bool
     | Enum Name
     | List [a]
-    | Object (Map Name a)
+    | Object (OrderedMap a)
     deriving (Eq, Show)
 
 instance forall a. IsString (Output a) where
@@ -229,6 +230,9 @@ instance Serialize Aeson.Value where
         , Boolean boolean <- value = Just $ Aeson.Bool boolean
     serialize _ (Enum enum) = Just $ Aeson.String enum
     serialize _ (List list) = Just $ Aeson.toJSON list
-    serialize _ (Object object) = Just $ Aeson.toJSON object
+    serialize _ (Object object) = Just
+        $ Aeson.object
+        $ OrderedMap.toList
+        $ Aeson.toJSON <$> object
     serialize _ _ = Nothing
     null = Aeson.Null

src/Language/GraphQL/Execute/Execution.hs

@@ -13,16 +13,16 @@ import Control.Monad.Trans.Class (lift)
 import Control.Monad.Trans.Reader (runReaderT)
 import Control.Monad.Trans.State (gets)
 import Data.List.NonEmpty (NonEmpty(..))
-import Data.Map.Strict (Map)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
 import Data.Sequence (Seq(..))
 import qualified Data.Text as Text
 import Language.GraphQL.AST (Name)
 import Language.GraphQL.Error
 import Language.GraphQL.Execute.Coerce
+import Language.GraphQL.Execute.OrderedMap (OrderedMap)
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
 import qualified Language.GraphQL.Execute.Transform as Transform
 import qualified Language.GraphQL.Type as Type
 import qualified Language.GraphQL.Type.In as In
@@ -51,17 +51,17 @@ resolveFieldValue result args resolver =
 collectFields :: Monad m
     => Out.ObjectType m
     -> Seq (Transform.Selection m)
-    -> Map Name (NonEmpty (Transform.Field m))
-collectFields objectType = foldl forEach Map.empty
+    -> OrderedMap (NonEmpty (Transform.Field m))
+collectFields objectType = foldl forEach OrderedMap.empty
   where
     forEach groupedFields (Transform.SelectionField field) =
         let responseKey = aliasOrName field
-         in Map.insertWith (<>) responseKey (field :| []) groupedFields
+         in OrderedMap.insert responseKey (field :| []) groupedFields
     forEach groupedFields (Transform.SelectionFragment selectionFragment)
         | Transform.Fragment fragmentType fragmentSelectionSet <- selectionFragment
         , Internal.doesFragmentTypeApply fragmentType objectType =
             let fragmentGroupedFieldSet = collectFields objectType fragmentSelectionSet
-             in Map.unionWith (<>) groupedFields fragmentGroupedFieldSet
+             in groupedFields <> fragmentGroupedFieldSet
         | otherwise = groupedFields
 
 aliasOrName :: forall m. Transform.Field m -> Name
@@ -170,10 +170,10 @@ executeSelectionSet :: (MonadCatch m, Serialize a)
     -> CollectErrsT m a
 executeSelectionSet result objectType@(Out.ObjectType _ _ _ resolvers) selectionSet = do
     let fields = collectFields objectType selectionSet
-    resolvedValues <- Map.traverseMaybeWithKey forEach fields
+    resolvedValues <- OrderedMap.traverseMaybe forEach fields
     coerceResult (Out.NonNullObjectType objectType) $ Object resolvedValues
   where
-    forEach _ fields@(field :| _) =
+    forEach fields@(field :| _) =
         let Transform.Field _ name _ _ = field
          in traverse (tryResolver fields) $ lookupResolver name
     lookupResolver = flip HashMap.lookup resolvers

src/Language/GraphQL/Execute/OrderedMap.hs

@@ -15,8 +15,10 @@ module Language.GraphQL.Execute.OrderedMap
     , foldlWithKey'
     , keys
     , lookup
+    , replace
     , singleton
     , size
+    , toList
     , traverseMaybe
     ) where
 
@@ -49,8 +51,8 @@ instance Semigroup v => Semigroup (OrderedMap v) where
     (<>) = foldlWithKey'
         $ \accumulator key value -> insert key value accumulator
 
-instance Monoid v => Monoid (OrderedMap v) where
-    mempty = OrderedMap mempty mempty
+instance Semigroup v => Monoid (OrderedMap v) where
+    mempty = empty
 
 instance Traversable OrderedMap where
     traverse f (OrderedMap vector hashMap) = OrderedMap vector
@@ -68,8 +70,8 @@ singleton key value = OrderedMap (Vector.singleton key)
     $ HashMap.singleton key value
 
 -- | Constructs an empty map.
-empty :: Monoid v => OrderedMap v
-empty = mempty
+empty :: forall v. OrderedMap v
+empty = OrderedMap mempty mempty
 
 -- * Traversal
 
@@ -90,7 +92,7 @@ foldlWithKey' f initial (OrderedMap vector hashMap) =
 
 -- | Traverse over the elements and collect the 'Just' results.
 traverseMaybe
-    :: (Applicative f, Monoid b)
+    :: Applicative f
     => forall a
     . (a -> f (Maybe b))
     -> OrderedMap a
@@ -98,7 +100,7 @@ traverseMaybe
 traverseMaybe f orderedMap = foldlWithKey' filter empty
     <$> traverse f orderedMap
   where
-    filter accumulator key (Just value) = insert key value accumulator
+    filter accumulator key (Just value) = replace key value accumulator
     filter accumulator _ Nothing = accumulator
 
 -- * Lists
@@ -127,6 +129,16 @@ insert key value (OrderedMap vector hashMap)
     | otherwise = OrderedMap (Vector.snoc vector key)
         $ HashMap.insert key value hashMap
 
+-- | Associates the specified value with the specified key in this map. If this
+-- map previously contained a mapping for the key, the existing value is
+-- replaced by the new one.
+replace :: Text -> v -> OrderedMap v -> OrderedMap v
+replace key value (OrderedMap vector hashMap)
+    | HashMap.member key hashMap = OrderedMap vector
+        $ HashMap.insert key value hashMap
+    | otherwise = OrderedMap (Vector.snoc vector key)
+        $ HashMap.insert key value hashMap
+
 -- | Gives the size of this map, i.e. number of elements in it.
 size :: forall v. OrderedMap v -> Int
 size (OrderedMap vector _) = Vector.length vector

src/Language/GraphQL/Execute/Subscribe.hs

@@ -13,7 +13,6 @@ import Control.Monad.Catch (Exception(..), MonadCatch(..))
 import Control.Monad.Trans.Reader (ReaderT(..), runReaderT)
 import Data.HashMap.Strict (HashMap)
 import qualified Data.HashMap.Strict as HashMap
-import qualified Data.Map.Strict as Map
 import qualified Data.List.NonEmpty as NonEmpty
 import Data.Sequence (Seq(..))
 import Data.Text (Text)
@@ -21,6 +20,7 @@ import qualified Data.Text as Text
 import Language.GraphQL.AST (Name)
 import Language.GraphQL.Execute.Coerce
 import Language.GraphQL.Execute.Execution
+import qualified Language.GraphQL.Execute.OrderedMap as OrderedMap
 import qualified Language.GraphQL.Execute.Transform as Transform
 import Language.GraphQL.Error
 import qualified Language.GraphQL.Type.Definition as Definition
@@ -55,7 +55,7 @@ createSourceEventStream :: MonadCatch m
     -> Seq (Transform.Selection m)
     -> m (Either Text (Out.SourceEventStream m))
 createSourceEventStream _types subscriptionType@(Out.ObjectType _ _ _ fieldTypes) fields
-    | [fieldGroup] <- Map.elems groupedFieldSet
+    | [fieldGroup] <- OrderedMap.elems groupedFieldSet
     , Transform.Field _ fieldName arguments' _ <- NonEmpty.head fieldGroup
     , resolverT <- fieldTypes HashMap.! fieldName
     , Out.EventStreamResolver fieldDefinition _ resolver <- resolverT

tests/Language/GraphQL/Execute/OrderedMapSpec.hs

@@ -64,3 +64,9 @@ spec =
                     $ OrderedMap.insert "key2" "2"
                     $ OrderedMap.singleton "key1" "1"
              in (map1 <> map2) `shouldBe` expected
+
+        it "replaces existing values" $
+            let key = "key"
+                actual = OrderedMap.replace key ("2" :: String)
+                        $ OrderedMap.singleton key ("1" :: String)
+             in OrderedMap.lookup key actual `shouldBe` Just "2"