traverseMaybe OrderedMap

This commit is contained in:
Eugen Wissner 2021-02-15 09:04:16 +01:00
parent 90d36f66b9
commit d74e27e903
3 changed files with 97 additions and 12 deletions

View File

@ -5,25 +5,38 @@
{-# LANGUAGE ExplicitForAll #-} {-# LANGUAGE ExplicitForAll #-}
-- | This module contains a map data structure, that preserves insertion order. -- | 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 module Language.GraphQL.Execute.OrderedMap
( OrderedMap ( OrderedMap
, elems , elems
, empty
, insert , insert
, foldlWithKey'
, keys , keys
, lookup , lookup
, singleton , singleton
, size , size
, traverseMaybe
) where ) where
import qualified Data.Foldable as Foldable import qualified Data.Foldable as Foldable
import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict (HashMap, (!))
import qualified Data.HashMap.Strict as HashMap import qualified Data.HashMap.Strict as HashMap
import Data.Text (Text) import Data.Text (Text)
import Data.Vector (Vector) import Data.Vector (Vector)
import qualified Data.Vector as 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) data OrderedMap v = OrderedMap (Vector Text) (HashMap Text v)
deriving (Eq)
instance Functor OrderedMap where instance Functor OrderedMap where
fmap f (OrderedMap vector hashMap) = OrderedMap vector $ fmap f hashMap fmap f (OrderedMap vector hashMap) = OrderedMap vector $ fmap f hashMap
@ -32,16 +45,21 @@ instance Foldable OrderedMap where
foldr f = foldrWithKey $ const f foldr f = foldrWithKey $ const f
null (OrderedMap vector _) = Vector.null vector 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 instance Semigroup v => Semigroup (OrderedMap v) where
(<>) = foldrWithKey insert (<>) = foldlWithKey'
$ \accumulator key value -> insert key value accumulator
instance Monoid v => Monoid (OrderedMap v) where instance Monoid v => Monoid (OrderedMap v) where
mempty = OrderedMap mempty mempty 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 -- * Construction
-- | Constructs a map with a single element. -- | 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) singleton key value = OrderedMap (Vector.singleton key)
$ HashMap.singleton key value $ 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 -- * Traversal
-- given starting value.
-- | 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 :: forall v a. (Text -> v -> a -> a) -> a -> OrderedMap v -> a
foldrWithKey f initial (OrderedMap vector hashMap) = foldr go initial vector foldrWithKey f initial (OrderedMap vector hashMap) = foldr go initial vector
where 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 -- * Lists

View File

@ -1,4 +1,4 @@
resolver: lts-17.2 resolver: lts-17.3
packages: packages:
- . - .

View File

@ -22,3 +22,45 @@ spec =
let value :: String let value :: String
value = "value" value = "value"
in OrderedMap.size (OrderedMap.singleton "key" value) `shouldBe` 1 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