Even more general map serialising

Data/Aeson.hs

@@ -56,6 +56,8 @@ module Data.Aeson
     , Result(..)
     , fromJSON
     , FromJSONKey(..)
+    , SJSONKeyMonad(..)
+    , IJSONKeyMonad(..)
     , ToJSON(..)
     , KeyValue(..)
     , ToJSONKey(..)

Data/Aeson/Types.hs

@@ -30,6 +30,8 @@ module Data.Aeson.Types
     , FromJSON(..)
     , fromJSON
     , FromJSONKey(..)
+    , SJSONKeyMonad(..)
+    , IJSONKeyMonad(..)
     , parse
     , parseEither
     , parseMaybe

Data/Aeson/Types/Class.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, DefaultSignatures, FlexibleContexts #-}
+{-# LANGUAGE CPP, DefaultSignatures, FlexibleContexts, FunctionalDependencies, GADTs #-}
 
 -- |
 -- Module:      Data.Aeson.Types.Class
@@ -18,6 +18,8 @@ module Data.Aeson.Types.Class
     , ToJSON(..)
     -- * Map classes
     , FromJSONKey(..)
+    , SJSONKeyMonad(..)
+    , IJSONKeyMonad(..)
     , ToJSONKey(..)
     -- * Generic JSON classes
     , GFromJSON(..)
@@ -33,6 +35,7 @@ module Data.Aeson.Types.Class
     ) where
 
 import Data.Aeson.Types.Internal
+import Data.Functor.Identity (Identity(..))
 import Data.Text (Text)
 import GHC.Generics (Generic, Rep, from, to)
 import qualified Data.Aeson.Encode.Builder as E
@@ -249,8 +252,8 @@ class FromJSON a where
     parseJSON = genericParseJSON defaultOptions
 
 -- | Helper typeclass to implement 'FromJSON' for map-like structures.
-class FromJSONKey a where
-    fromJSONKey :: Text -> a
+class FromJSONKey a m | a -> m where
+    fromJSONKey :: Text -> m a
 
 -- | Helper typeclass to implement 'ToJSON' for map-like structures.
 class ToJSONKey a where
@@ -260,6 +263,19 @@ class ToJSONKey a where
     toKeyEncoding = Encoding . E.text . toJSONKey
     {-# INLINE toKeyEncoding #-}
 
+data SJSONKeyMonad a where
+    SJSONKeyMonadIdentity :: SJSONKeyMonad Identity
+    SJSONKeyMonadParser   :: SJSONKeyMonad Parser
+
+class IJSONKeyMonad m where
+    jsonKeyMonadSing :: proxy m -> SJSONKeyMonad m
+
+instance IJSONKeyMonad Identity where
+    jsonKeyMonadSing _ = SJSONKeyMonadIdentity
+
+instance IJSONKeyMonad Parser where
+    jsonKeyMonadSing _ = SJSONKeyMonadParser
+
 -- | A key-value pair for encoding a JSON object.
 class KeyValue kv where
     (.=) :: ToJSON v => Text -> v -> kv

Data/Aeson/Types/Instances.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE CPP, BangPatterns, DeriveDataTypeable, FlexibleContexts,
     FlexibleInstances, GeneralizedNewtypeDeriving,
-    OverloadedStrings, UndecidableInstances,
-    ViewPatterns #-}
+    OverloadedStrings, UndecidableInstances, MultiParamTypeClasses, GADTs,
+    ViewPatterns, ScopedTypeVariables #-}
 {-# LANGUAGE DefaultSignatures #-}
 
 #include "overlapping-compat.h"
@@ -31,6 +31,8 @@ module Data.Aeson.Types.Instances
     , KeyValue(..)
     -- ** Map classes
     , FromJSONKey(..)
+    , SJSONKeyMonad(..)
+    , IJSONKeyMonad(..)
     , ToJSONKey(..)
     -- ** Generic JSON classes
     , GFromJSON(..)
@@ -76,6 +78,7 @@ import Data.Int (Int8, Int16, Int32, Int64)
 import Data.Maybe (fromMaybe)
 import Data.Monoid ((<>))
 import Data.Monoid (Dual(..), First(..), Last(..))
+import Data.Proxy (Proxy(..))
 import Data.Ratio (Ratio, (%), numerator, denominator)
 import Data.Scientific (Scientific)
 import Data.Text (Text, pack, unpack)
@@ -658,27 +661,31 @@ encodeKV :: (ToJSONKey k, ToJSON v) => k -> v -> B.Builder
 encodeKV k v = keyBuilder k <> B.char7 ':' <> builder v
 {-# INLINE encodeKV #-}
 
-instance FromJSONKey Text where
-    fromJSONKey = id
+instance FromJSONKey Text Identity where
+    fromJSONKey = Identity
 
 instance ToJSONKey Text where
     toJSONKey = id
 
-instance FromJSONKey LT.Text where
-    fromJSONKey = LT.fromStrict
+instance FromJSONKey LT.Text Identity where
+    fromJSONKey = Identity . LT.fromStrict
 
 instance ToJSONKey LT.Text where
     toJSONKey = LT.toStrict
 
-instance FromJSONKey String where
-    fromJSONKey = unpack
+instance FromJSONKey String Identity where
+    fromJSONKey = Identity . unpack
 
 instance ToJSONKey String where
     toJSONKey = pack
 
-instance (FromJSON v, FromJSONKey k, Ord k) => FromJSON (M.Map k v) where
-    parseJSON = withObject "Map k v" $
-                  fmap (H.foldrWithKey (M.insert . fromJSONKey) M.empty) . H.traverseWithKey (\k v -> parseJSON v <?> Key k)
+instance (FromJSON v, FromJSONKey k m, IJSONKeyMonad m, Ord k) => FromJSON (M.Map k v) where
+    parseJSON = case jsonKeyMonadSing (Proxy :: Proxy m) of
+        SJSONKeyMonadIdentity -> withObject "Map k v" $
+            fmap (H.foldrWithKey (M.insert . runIdentity . fromJSONKey) M.empty) . H.traverseWithKey (\k v -> parseJSON v <?> Key k)
+        SJSONKeyMonadParser -> withObject "Map k v" $
+            H.foldrWithKey (\k v m -> M.insert <$> fromJSONKey k <*> (parseJSON v <?> Key k) <*> m) (pure M.empty)
+    {-# INLINE parseJSON #-}
 
 instance (ToJSON v, ToJSONKey k) => ToJSON (M.Map k v) where
     toJSON = Object . mapHashKeyVal toJSONKey toJSON
@@ -694,8 +701,12 @@ instance (ToJSON v, ToJSONKey k) => ToJSON (H.HashMap k v) where
     toEncoding = encodeWithKey H.foldrWithKey
     {-# INLINE toEncoding #-}
 
-instance (FromJSON v, FromJSONKey k, Eq k, Hashable k) => FromJSON (H.HashMap k v) where
-    parseJSON = withObject "HashMap k v" $ fmap (mapKey fromJSONKey) . H.traverseWithKey (\k v -> parseJSON v <?> Key k)
+instance (FromJSON v, FromJSONKey k m, IJSONKeyMonad m, Eq k, Hashable k) => FromJSON (H.HashMap k v) where
+    parseJSON = case jsonKeyMonadSing (Proxy :: Proxy m) of
+        SJSONKeyMonadIdentity -> withObject "HashMap k v" $
+            fmap (mapKey (runIdentity . fromJSONKey)) . H.traverseWithKey (\k v -> parseJSON v <?> Key k)
+        SJSONKeyMonadParser -> withObject "HashMap k v" $
+            H.foldrWithKey (\k v m -> H.insert <$> fromJSONKey k <*> (parseJSON v <?> Key k) <*> m) (pure H.empty)
     {-# INLINE parseJSON #-}
 
 instance (ToJSON v) => ToJSON (Tree.Tree v) where