|
| 1 | +{-# LANGUAGE CPP #-} |
| 2 | +{-# LANGUAGE DeriveDataTypeable #-} |
| 3 | +{-# LANGUAGE DeriveFunctor #-} |
| 4 | +{-# LANGUAGE TemplateHaskell #-} |
| 5 | + |
| 6 | +-- | |
| 7 | +-- An abstract interface for maps from Textual keys to values. |
| 8 | + |
| 9 | +module Data.Aeson.KeyMap ( |
| 10 | + -- * Map Type |
| 11 | + KeyMap, |
| 12 | + |
| 13 | + -- * Query |
| 14 | + lookup, |
| 15 | + size, |
| 16 | + member, |
| 17 | + |
| 18 | + -- * Construction |
| 19 | + empty, |
| 20 | + singleton, |
| 21 | + |
| 22 | + -- ** Insertion |
| 23 | + insert, |
| 24 | + |
| 25 | + -- * Combine |
| 26 | + difference, |
| 27 | + |
| 28 | + -- * Lists |
| 29 | + fromList, |
| 30 | + fromListWith, |
| 31 | + toList, |
| 32 | + toAscList, |
| 33 | + |
| 34 | + -- * HashMaps |
| 35 | + fromHashMap, |
| 36 | + toHashMap, |
| 37 | + |
| 38 | + -- * Traversal |
| 39 | + -- ** Map |
| 40 | + mapKeyVal, |
| 41 | + traverseWithKey, |
| 42 | + |
| 43 | + -- * Folds |
| 44 | + foldrWithKey, |
| 45 | + |
| 46 | + -- * Conversions |
| 47 | + keys, |
| 48 | +) where |
| 49 | + |
| 50 | +#if 1 |
| 51 | +import Control.DeepSeq (NFData(..)) |
| 52 | +import Data.Data (Data) |
| 53 | +import Data.Hashable (Hashable(..)) |
| 54 | +import Data.HashMap.Strict (HashMap) |
| 55 | +import Data.List (sortBy) |
| 56 | +import Data.Ord (comparing) |
| 57 | +import Data.Text (Text, unpack, pack) |
| 58 | +import Data.Typeable (Typeable) |
| 59 | +import Prelude hiding (lookup) |
| 60 | +import Control.Arrow (first) |
| 61 | +import Data.Foldable hiding (toList) |
| 62 | +import Text.Read |
| 63 | +#if __GLASGOW_HASKELL__ < 710 |
| 64 | +import Data.Monoid (Monoid(mempty, mappend)) |
| 65 | +import Data.Traversable (Traversable(..)) |
| 66 | +import Control.Applicative (Applicative) |
| 67 | +#endif |
| 68 | +#if __GLASGOW_HASKELL__ >= 711 |
| 69 | +import Data.Semigroup (Semigroup((<>))) |
| 70 | +#endif |
| 71 | + |
| 72 | +import qualified Data.HashMap.Strict as H |
| 73 | +import qualified Language.Haskell.TH.Syntax as TH |
| 74 | + |
| 75 | +newtype KeyMap v = KeyMap { unKeyMap :: HashMap Text v } |
| 76 | + deriving (Eq, Ord, Typeable, Data, Functor) |
| 77 | + |
| 78 | +instance Read v => Read (KeyMap v) where |
| 79 | + readPrec = parens $ prec 10 $ do |
| 80 | + Ident "fromList" <- lexP |
| 81 | + xs <- readPrec |
| 82 | + return (fromList xs) |
| 83 | + |
| 84 | + readListPrec = readListPrecDefault |
| 85 | + |
| 86 | +instance Show v => Show (KeyMap v) where |
| 87 | + showsPrec d m = showParen (d > 10) $ |
| 88 | + showString "fromList " . shows (toAscList m) |
| 89 | + |
| 90 | + |
| 91 | +#if __GLASGOW_HASKELL__ >= 711 |
| 92 | +instance Semigroup (KeyMap v) where |
| 93 | + (KeyMap m1) <> (KeyMap m2) = KeyMap (m1 `H.union` m2) |
| 94 | + {-# INLINE (<>) #-} |
| 95 | +#endif |
| 96 | +instance Monoid (KeyMap v) where |
| 97 | + mempty = empty |
| 98 | + {-# INLINE mempty #-} |
| 99 | +#if __GLASGOW_HASKELL__ >= 711 |
| 100 | + mappend = (<>) |
| 101 | +#else |
| 102 | + mappend (KeyMap m1) (KeyMap m2) = KeyMap (m1 `H.union` m2) |
| 103 | +#endif |
| 104 | + {-# INLINE mappend #-} |
| 105 | + |
| 106 | +instance Hashable v => Hashable (KeyMap v) where |
| 107 | + hashWithSalt salt (KeyMap hm) = hashWithSalt salt hm |
| 108 | + |
| 109 | +instance NFData v => NFData (KeyMap v) where |
| 110 | + rnf (KeyMap hm) = rnf hm |
| 111 | + |
| 112 | +instance Foldable KeyMap where |
| 113 | + foldMap f (KeyMap tm) = H.foldMapWithKey (\ _k v -> f v) tm |
| 114 | + {-# INLINE foldMap #-} |
| 115 | + foldr f z (KeyMap tm) = H.foldr f z tm |
| 116 | + {-# INLINE foldr #-} |
| 117 | + foldl f z (KeyMap tm) = H.foldl f z tm |
| 118 | + {-# INLINE foldl #-} |
| 119 | + foldr' f z (KeyMap tm) = H.foldr' f z tm |
| 120 | + {-# INLINE foldr' #-} |
| 121 | + foldl' f z (KeyMap tm) = H.foldl' f z tm |
| 122 | + {-# INLINE foldl' #-} |
| 123 | +#if MIN_VERSION_base(4,8,0) |
| 124 | + null = H.null . unKeyMap |
| 125 | + {-# INLINE null #-} |
| 126 | + length = size |
| 127 | + {-# INLINE length #-} |
| 128 | +#endif |
| 129 | + |
| 130 | +instance Traversable KeyMap where |
| 131 | + traverse f = traverseWithKey (const f) |
| 132 | + {-# INLINABLE traverse #-} |
| 133 | + |
| 134 | + |
| 135 | +instance TH.Lift v => TH.Lift (KeyMap v) where |
| 136 | + lift (KeyMap m) = [| KeyMap (H.fromList . map (first pack) $ m') |] |
| 137 | + where |
| 138 | + m' = map (first unpack) . H.toList $ m |
| 139 | + |
| 140 | +#if MIN_VERSION_template_haskell(2,17,0) |
| 141 | + liftTyped = TH.unsafeCodeCoerce . TH.lift |
| 142 | +#elif MIN_VERSION_template_haskell(2,16,0) |
| 143 | + liftTyped = TH.unsafeTExpCoerce . TH.lift |
| 144 | +#endif |
| 145 | + |
| 146 | +-- | |
| 147 | +-- Construct an empty map. |
| 148 | +empty :: KeyMap v |
| 149 | +empty = KeyMap H.empty |
| 150 | + |
| 151 | +-- | |
| 152 | +-- Return the number of key-value mappings in this map. |
| 153 | +size :: KeyMap v -> Int |
| 154 | +size = H.size . unKeyMap |
| 155 | + |
| 156 | +-- | |
| 157 | +-- Construct a map with a single element. |
| 158 | +singleton :: Text -> v -> KeyMap v |
| 159 | +singleton k v = KeyMap (H.singleton k v) |
| 160 | + |
| 161 | +member :: Text -> KeyMap a -> Bool |
| 162 | +member t (KeyMap m) = H.member t m |
| 163 | + |
| 164 | +-- | Return the value to which the specified key is mapped, |
| 165 | +-- or Nothing if this map contains no mapping for the key. |
| 166 | +lookup :: Text -> KeyMap v -> Maybe v |
| 167 | +lookup t tm = H.lookup t (unKeyMap tm) |
| 168 | + |
| 169 | +-- | Associate the specified value with the specified key |
| 170 | +-- in this map. If this map previously contained a mapping |
| 171 | +-- for the key, the old value is replaced. |
| 172 | +insert :: Text -> v -> KeyMap v -> KeyMap v |
| 173 | +insert k v tm = KeyMap (H.insert k v (unKeyMap tm)) |
| 174 | + |
| 175 | +-- | Reduce this map by applying a binary operator to all |
| 176 | +-- elements, using the given starting value (typically the |
| 177 | +-- right-identity of the operator). |
| 178 | +foldrWithKey :: (Text -> v -> a -> a) -> a -> KeyMap v -> a |
| 179 | +foldrWithKey f a = H.foldrWithKey f a . unKeyMap |
| 180 | + |
| 181 | +-- | Perform an Applicative action for each key-value pair |
| 182 | +-- in a 'KeyMap' and produce a 'KeyMap' of all the results. |
| 183 | +traverseWithKey :: Applicative f => (Text -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2) |
| 184 | +traverseWithKey f = fmap KeyMap . H.traverseWithKey f . unKeyMap |
| 185 | + |
| 186 | +-- | Construct a map from a list of elements. Uses the |
| 187 | +-- provided function, f, to merge duplicate entries with |
| 188 | +-- (f newVal oldVal). |
| 189 | +fromListWith :: (v -> v -> v) -> [(Text, v)] -> KeyMap v |
| 190 | +fromListWith op = KeyMap . H.fromListWith op |
| 191 | + |
| 192 | +-- | Construct a map with the supplied mappings. If the |
| 193 | +-- list contains duplicate mappings, the later mappings take |
| 194 | +-- precedence. |
| 195 | +fromList :: [(Text, v)] -> KeyMap v |
| 196 | +fromList = KeyMap . H.fromList |
| 197 | + |
| 198 | +-- | Return a list of this map's elements. |
| 199 | +toList :: KeyMap v -> [(Text, v)] |
| 200 | +toList = H.toList . unKeyMap |
| 201 | + |
| 202 | +-- | Return a list of this map's elements in ascending order |
| 203 | +-- based of the textual key. |
| 204 | +toAscList :: KeyMap v -> [(Text, v)] |
| 205 | +toAscList = sortBy (comparing fst) . toList |
| 206 | + |
| 207 | +-- | Difference of two maps. Return elements of the first |
| 208 | +-- map not existing in the second. |
| 209 | +difference :: KeyMap v -> KeyMap v' -> KeyMap v |
| 210 | +difference tm1 tm2 = KeyMap (H.difference (unKeyMap tm1) (unKeyMap tm2)) |
| 211 | + |
| 212 | +-- | Return a list of this map's keys. |
| 213 | +keys :: KeyMap v -> [Text] |
| 214 | +keys = H.keys . unKeyMap |
| 215 | + |
| 216 | +-- | Convert a 'KeyMap' to a 'HashMap'. |
| 217 | +toHashMap :: KeyMap v -> HashMap Text v |
| 218 | +toHashMap = unKeyMap |
| 219 | + |
| 220 | +-- | Convert a 'HashMap' to a 'KeyMap'. |
| 221 | +fromHashMap :: HashMap Text v -> KeyMap v |
| 222 | +fromHashMap = KeyMap |
| 223 | + |
| 224 | +-- | Transform the keys and values of a 'KeyMap'. |
| 225 | +mapKeyVal :: (Text -> Text) -> (v1 -> v2) |
| 226 | + -> KeyMap v1 -> KeyMap v2 |
| 227 | +mapKeyVal fk kv = foldrWithKey (\k v -> insert (fk k) (kv v)) empty |
| 228 | +{-# INLINE mapKeyVal #-} |
| 229 | + |
| 230 | +#endif |
0 commit comments