From d74e27e90330400fa97296f09dae0777f340bfe1 Mon Sep 17 00:00:00 2001 From: Eugen Wissner Date: Mon, 15 Feb 2021 09:04:16 +0100 Subject: [PATCH] traverseMaybe OrderedMap --- src/Language/GraphQL/Execute/OrderedMap.hs | 65 +++++++++++++++---- stack.yaml | 2 +- .../GraphQL/Execute/OrderedMapSpec.hs | 42 ++++++++++++ 3 files changed, 97 insertions(+), 12 deletions(-) diff --git a/src/Language/GraphQL/Execute/OrderedMap.hs b/src/Language/GraphQL/Execute/OrderedMap.hs index 566a551..f8759c9 100644 --- a/src/Language/GraphQL/Execute/OrderedMap.hs +++ b/src/Language/GraphQL/Execute/OrderedMap.hs @@ -5,25 +5,38 @@ {-# LANGUAGE ExplicitForAll #-} -- | This module contains a map data structure, that preserves insertion order. +-- Some definitions conflict with functions from prelude, so this module should +-- probably be imported qualified. module Language.GraphQL.Execute.OrderedMap ( OrderedMap , elems + , empty , insert + , foldlWithKey' , keys , lookup , singleton , size + , traverseMaybe ) where import qualified Data.Foldable as Foldable -import Data.HashMap.Strict (HashMap) +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 -import Prelude hiding (lookup) +import Prelude hiding (filter, lookup) +-- | This map associates values with the given text keys. Insertion order is +-- preserved. When inserting a value with a key, that is already available in +-- the map, the existing value isn't overridden, but combined with the new value +-- using its 'Semigroup' instance. +-- +-- Internally this map uses an array with keys to preserve the order and an +-- unorded map with key-value pairs. data OrderedMap v = OrderedMap (Vector Text) (HashMap Text v) + deriving (Eq) instance Functor OrderedMap where fmap f (OrderedMap vector hashMap) = OrderedMap vector $ fmap f hashMap @@ -32,16 +45,21 @@ 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 v => Semigroup (OrderedMap v) where - (<>) = foldrWithKey insert + (<>) = foldlWithKey' + $ \accumulator key value -> insert key value accumulator instance Monoid v => Monoid (OrderedMap v) where mempty = OrderedMap mempty mempty +instance Traversable OrderedMap where + traverse f (OrderedMap vector hashMap) = OrderedMap vector + <$> traverse f hashMap + +instance Show v => Show (OrderedMap v) where + showsPrec precedence map' = showParen (precedence > 10) + $ showString "fromList " . shows (toList map') + -- * Construction -- | Constructs a map with a single element. @@ -49,14 +67,39 @@ singleton :: forall v. Text -> v -> OrderedMap v singleton key value = OrderedMap (Vector.singleton key) $ HashMap.singleton key value --- * Folds +-- | Constructs an empty map. +empty :: Monoid v => OrderedMap v +empty = mempty --- | Reduces this map by applying a binary operator to all elements, using the --- given starting value. +-- * Traversal + +-- | Reduces this map by applying a binary operator from right to left 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 = f key (hashMap HashMap.! key) + go key = f key (hashMap ! key) + +-- | Reduces this map by applying a binary operator from left to right to all +-- elements, using the given starting value. +foldlWithKey' :: forall v a. (a -> Text -> v -> a) -> a -> OrderedMap v -> a +foldlWithKey' f initial (OrderedMap vector hashMap) = + Vector.foldl' go initial vector + where + go accumulator key = f accumulator key (hashMap ! key) + +-- | Traverse over the elements and collect the 'Just' results. +traverseMaybe + :: (Applicative f, Monoid b) + => forall a + . (a -> f (Maybe b)) + -> OrderedMap a + -> f (OrderedMap b) +traverseMaybe f orderedMap = foldlWithKey' filter empty + <$> traverse f orderedMap + where + filter accumulator key (Just value) = insert key value accumulator + filter accumulator _ Nothing = accumulator -- * Lists diff --git a/stack.yaml b/stack.yaml index b7b9ac3..85def2a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-17.2 +resolver: lts-17.3 packages: - . diff --git a/tests/Language/GraphQL/Execute/OrderedMapSpec.hs b/tests/Language/GraphQL/Execute/OrderedMapSpec.hs index 8221b92..fd33316 100644 --- a/tests/Language/GraphQL/Execute/OrderedMapSpec.hs +++ b/tests/Language/GraphQL/Execute/OrderedMapSpec.hs @@ -22,3 +22,45 @@ spec = let value :: String value = "value" in OrderedMap.size (OrderedMap.singleton "key" value) `shouldBe` 1 + + it "combines inserted vales" $ + let key = "key" + map1 = OrderedMap.singleton key ("1" :: String) + map2 = OrderedMap.singleton key ("2" :: String) + in OrderedMap.lookup key (map1 <> map2) `shouldBe` Just "12" + + it "shows the map" $ + let actual = show + $ OrderedMap.insert "key1" "1" + $ OrderedMap.singleton "key2" ("2" :: String) + expected = "fromList [(\"key2\",\"2\"),(\"key1\",\"1\")]" + in actual `shouldBe` expected + + it "traverses a map of just values" $ + let actual = sequence + $ OrderedMap.insert "key1" (Just "2") + $ OrderedMap.singleton "key2" $ Just ("1" :: String) + expected = Just + $ OrderedMap.insert "key1" "2" + $ OrderedMap.singleton "key2" ("1" :: String) + in actual `shouldBe` expected + + it "traverses a map with a Nothing" $ + let actual = sequence + $ OrderedMap.insert "key1" Nothing + $ OrderedMap.singleton "key2" $ Just ("1" :: String) + expected = Nothing + in actual `shouldBe` expected + + it "combines two maps preserving the order of the second one" $ + let map1 :: OrderedMap String + map1 = OrderedMap.insert "key2" "2" + $ OrderedMap.singleton "key1" "1" + map2 :: OrderedMap String + map2 = OrderedMap.insert "key4" "4" + $ OrderedMap.singleton "key3" "3" + expected = OrderedMap.insert "key4" "4" + $ OrderedMap.insert "key3" "3" + $ OrderedMap.insert "key2" "2" + $ OrderedMap.singleton "key1" "1" + in (map1 <> map2) `shouldBe` expected