Even more general map serialising

Data/Aeson.hs

@@ -57,6 +57,14 @@ module Data.Aeson
     , fromJSON
     , ToJSON(..)
     , KeyValue(..)
+    -- * Key conversion
+    , FromJSONKey(..)
+    , FromJSONKeyType
+    , ToJSONKey(..)
+    , ToJSONKeyType
+    , JSONKeyMethod(..)
+    , SJSONKeyMethod(..)
+    , IJSONKeyMethod(..)
     -- ** Generic JSON classes and options
     , GFromJSON(..)
     , GToJSON(..)

Data/Aeson/Encode/Functions.hs

@@ -8,6 +8,7 @@ module Data.Aeson.Encode.Functions
     , encode
     , foldable
     , list
+    , list'
     , pairs
     ) where
 
@@ -48,6 +49,13 @@ list (x:xs) = Encoding $
       where commas = foldr (\v vs -> char7 ',' <> builder v <> vs) mempty
 {-# INLINE list #-}
 
+list' :: (a -> Encoding) -> [a] -> Encoding
+list' _ []     = emptyArray_
+list' e (x:xs) = Encoding $
+              char7 '[' <> fromEncoding (e x) <> commas xs <> char7 ']'
+      where commas = foldr (\v vs -> char7 ',' <> fromEncoding (e v) <> vs) mempty
+{-# INLINE list' #-}
+
 brackets :: Char -> Char -> Series -> Encoding
 brackets begin end (Value v) = Encoding $
                                char7 begin <> fromEncoding v <> char7 end

Data/Aeson/Types.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 -- |
 -- Module:      Data.Aeson.Types
 -- Copyright:   (c) 2011-2016 Bryan O'Sullivan
@@ -36,6 +37,16 @@ module Data.Aeson.Types
     , KeyValue(..)
     , modifyFailure
 
+    -- ** Key conversion
+    , FromJSONKey(..)
+    , FromJSONKeyType
+    , ToJSONKey(..)
+    , ToJSONKeyType
+    , JSONKeyCoercible
+    , JSONKeyMethod(..)
+    , SJSONKeyMethod(..)
+    , IJSONKeyMethod(..)
+
     -- ** Generic JSON classes
     , GFromJSON(..)
     , GToJSON(..)

Data/Aeson/Types/Class.hs

@@ -1,5 +1,9 @@
-{-# LANGUAGE CPP, DefaultSignatures, FlexibleContexts #-}
-
+{-# LANGUAGE CPP, DefaultSignatures, FlexibleContexts, FunctionalDependencies, GADTs #-}
+{-# LANGUAGE ConstraintKinds, TypeFamilies, DataKinds, KindSignatures, UndecidableInstances #-}
+{-# LANGUAGE FlexibleInstances #-}
+#if __GLASGOW_HASKELL__ >= 800
+{-# LANGUAGE UndecidableSuperClasses #-}
+#endif
 -- |
 -- Module:      Data.Aeson.Types.Class
 -- Copyright:   (c) 2011-2016 Bryan O'Sullivan
@@ -16,6 +20,15 @@ module Data.Aeson.Types.Class
     -- * Core JSON classes
       FromJSON(..)
     , ToJSON(..)
+    -- * Map classes
+    , FromJSONKey(..)
+    , FromJSONKeyType
+    , ToJSONKey(..)
+    , ToJSONKeyType
+    , JSONKeyCoercible
+    , JSONKeyMethod(..)
+    , SJSONKeyMethod(..)
+    , IJSONKeyMethod(..)
     -- * Generic JSON classes
     , GFromJSON(..)
     , GToJSON(..)
@@ -34,6 +47,13 @@ import Data.Text (Text)
 import GHC.Generics (Generic, Rep, from, to)
 import qualified Data.Aeson.Encode.Builder as E
 
+import GHC.Exts (Constraint)
+#ifdef HAS_COERCIBLE
+import Data.Coerce (Coercible, coerce)
+#else
+import Unsafe.Coerce (unsafeCoerce)
+#endif
+
 -- | Class of generic representation types ('Rep') that can be converted to
 -- JSON.
 class GToJSON f where
@@ -245,6 +265,118 @@ class FromJSON a where
     default parseJSON :: (Generic a, GFromJSON (Rep a)) => Value -> Parser a
     parseJSON = genericParseJSON defaultOptions
 
+-- | Type family to reduce errors with 'JSONKeyCoerce'. Useful only with GHC >= 7.8
+#ifdef HAS_COERCIBLE
+type family JSONKeyCoercible (m :: JSONKeyMethod) a :: Constraint where
+    JSONKeyCoercible 'JSONKeyCoerce a = (Coercible Text a, Coercible a Text) -- Symmetry for GHC 7.8
+    JSONKeyCoercible m              a = ()
+#else
+type family JSONKeyCoercible (m :: JSONKeyMethod) a :: Constraint
+type instance JSONKeyCoercible m a = ()
+#endif
+
+-- | Helper typeclass to implement 'FromJSON' for map-like structures.
+--
+-- 'JSONKeyMethod' provides different method to parse the key. There are three methods to parse textual keys:
+--
+-- * 'JSONKeyCoerce' for newtypes over 'Text' (with agreeing 'Hashable').
+--
+-- * 'JSONKeyIdentity' for values which can be always parsed from 'Text', e.g. 'CI' 'Text'.
+--
+-- * 'JSONKeyTextParser' for other textual values.
+--
+-- For types without textual representation use 'JSONKeyValueParser':
+--
+-- @
+-- instance FromJSONKey Coord 'JSONKeyValueParser where
+--    fromJSONKey _ = parseJSON
+-- @
+class JSONKeyCoercible m a => FromJSONKey a (m :: JSONKeyMethod) | a -> m where
+    fromJSONKey :: proxy m -> FromJSONKeyType m a
+
+-- | Helper typeclass to implement 'ToJSON' for map-like structures. See 'FromJSONKey'.
+--
+-- For types without textual representation use 'JSONKeyValueParser':
+--
+-- @
+-- instance ToJSONKey Coord 'JSONKeyValueParser where
+--    toJSONKey     _ = toJSON
+--    toKeyEncoding _ = toEncoding
+-- @
+class JSONKeyCoercible m a => ToJSONKey a (m :: JSONKeyMethod) | a -> m  where
+    toJSONKey :: proxy m -> ToJSONKeyType m a
+
+    -- | For 'JSONKeyValueParser' should produce valid 'Value' encoding.
+    --
+    -- For other methods 'toKeyEncoding' should produce valid 'Text' encoding.
+    toKeyEncoding :: proxy m -> a -> Encoding
+    default toKeyEncoding :: DefaultToKeyEncoding m a => proxy m -> a -> Encoding
+    toKeyEncoding = defaultToKeyEncoding
+    -- {-# INLINE toKeyEncoding #-}
+
+class DefaultToKeyEncoding (m :: JSONKeyMethod) a where
+    defaultToKeyEncoding :: proxy m -> a -> Encoding
+
+instance JSONKeyCoercible 'JSONKeyCoerce a => DefaultToKeyEncoding 'JSONKeyCoerce a where
+#ifdef HAS_COERCIBLE
+    defaultToKeyEncoding _ = Encoding . E.text . coerce
+#else
+    defaultToKeyEncoding _ = Encoding . E.text . unsafeCoerce
+#endif
+
+instance ToJSONKey a 'JSONKeyIdentity => DefaultToKeyEncoding 'JSONKeyIdentity a where
+    defaultToKeyEncoding p = Encoding . E.text . toJSONKey p
+
+instance ToJSONKey a 'JSONKeyTextParser => DefaultToKeyEncoding 'JSONKeyTextParser a where
+    defaultToKeyEncoding p = Encoding . E.text . toJSONKey p
+
+instance ToJSONKey a 'JSONKeyValueParser => DefaultToKeyEncoding 'JSONKeyValueParser a where
+    defaultToKeyEncoding p = Encoding . E.encodeToBuilder . toJSONKey p
+
+-- | Different methods to handle map structure keys
+data JSONKeyMethod = JSONKeyCoerce      -- ^ /Unsafe:/ For keys which are newtypes and 'Hashable' instances agree with base type.
+                   | JSONKeyIdentity    -- ^ Key parsers which cannot fail.
+                   | JSONKeyTextParser  -- ^ Arbitrary key parsers.
+                   | JSONKeyValueParser -- ^ Maps serialised as list of key-value pairs.
+    deriving (Eq, Ord, Enum, Bounded)
+
+-- | Type of 'fromJSONKey'.
+type family FromJSONKeyType (m :: JSONKeyMethod) a
+type instance FromJSONKeyType 'JSONKeyCoerce      a = ()
+type instance FromJSONKeyType 'JSONKeyIdentity    a = Text -> a
+type instance FromJSONKeyType 'JSONKeyTextParser  a = Text -> Parser a
+type instance FromJSONKeyType 'JSONKeyValueParser a = Value -> Parser a
+
+-- | Type of 'toJSONKey'.
+type family ToJSONKeyType (m :: JSONKeyMethod) a
+type instance ToJSONKeyType 'JSONKeyCoerce      a = ()
+type instance ToJSONKeyType 'JSONKeyIdentity    a = a -> Text
+type instance ToJSONKeyType 'JSONKeyTextParser  a = a -> Text
+type instance ToJSONKeyType 'JSONKeyValueParser a = a -> Value
+
+-- | Singleton of 'JSONKeyMethod'.
+data SJSONKeyMethod (m :: JSONKeyMethod) where
+    SJSONKeyCoerce       :: SJSONKeyMethod 'JSONKeyCoerce
+    SJSONKeyIdentity     :: SJSONKeyMethod 'JSONKeyIdentity
+    SJSONKeyTextParser   :: SJSONKeyMethod 'JSONKeyTextParser
+    SJSONKeyValueParser  :: SJSONKeyMethod 'JSONKeyValueParser
+
+-- | A class for providing 'SJSONKeyMethod' values.
+class IJSONKeyMethod (m :: JSONKeyMethod) where
+    jsonKeyMethodSing :: proxy m -> SJSONKeyMethod m
+
+instance IJSONKeyMethod 'JSONKeyCoerce where
+    jsonKeyMethodSing _ = SJSONKeyCoerce
+
+instance IJSONKeyMethod 'JSONKeyIdentity where
+    jsonKeyMethodSing _ = SJSONKeyIdentity
+
+instance IJSONKeyMethod 'JSONKeyTextParser where
+    jsonKeyMethodSing _ = SJSONKeyTextParser
+
+instance IJSONKeyMethod 'JSONKeyValueParser where
+    jsonKeyMethodSing _ = SJSONKeyValueParser
+
 -- | A key-value pair for encoding a JSON object.
 class KeyValue kv where
     (.=) :: ToJSON v => Text -> v -> kv