Add support for JSON serialisation. (#236)

Author: jonathanknowles

components/monoidmap-aeson/Data/MonoidMap/JSON.hs

@@ -0,0 +1,43 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+-- |
+-- Copyright: © 2022–2025 Jonathan Knowles
+-- License: Apache-2.0
+--
+module Data.MonoidMap.JSON where
+
+import Prelude
+
+import Data.Aeson
+    ( FromJSON (parseJSON)
+    , FromJSONKey
+    , ToJSON (toEncoding, toJSON)
+    , ToJSONKey
+    )
+import Data.Monoid.Null
+    ( MonoidNull
+    )
+import Data.MonoidMap
+    ( MonoidMap
+    )
+
+import qualified Data.MonoidMap as MonoidMap
+
+instance
+    ( ToJSONKey k
+    , ToJSON v
+    )
+    => ToJSON (MonoidMap k v)
+  where
+    toEncoding = toEncoding . MonoidMap.toMap
+    toJSON = toJSON . MonoidMap.toMap
+
+instance
+    ( FromJSONKey k
+    , Ord k
+    , FromJSON v
+    , MonoidNull v
+    )
+    => FromJSON (MonoidMap k v)
+  where
+    parseJSON = fmap (fmap MonoidMap.fromMap) parseJSON

components/monoidmap-test/Data/MonoidMap/JSONSpec.hs

@@ -0,0 +1,99 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+-- |
+-- Copyright: © 2022–2025 Jonathan Knowles
+-- License: Apache-2.0
+--
+module Data.MonoidMap.JSONSpec
+    ( spec
+    )
+where
+
+import Prelude
+
+import Control.Monad
+    ( forM_
+    )
+import Data.MonoidMap
+    ( MonoidMap
+    )
+import Data.MonoidMap.JSON
+    (
+    )
+import Data.Proxy
+    ( Proxy (Proxy)
+    )
+import Data.Text
+    ( Text
+    )
+import Test.Aeson.Internal.GoldenSpecs
+    ( goldenSpecs
+    )
+import Test.Common
+    ( Test
+    , TestKey
+    , TestValueType (TestValueType)
+    , makeSpec
+    , testValueTypesAll
+    )
+import Test.Hspec
+    ( Spec
+    , describe
+    )
+import Test.QuickCheck.Classes
+    ( jsonLaws
+    )
+import Test.QuickCheck.Classes.Hspec
+    ( testLaws
+    )
+
+import qualified Test.Aeson.Internal.Utils as Golden
+
+spec :: Spec
+spec = do
+    describe "JSON"
+        $ forM_ testKeyValueTypes
+        $ \(TestKeyType k, TestValueType v) -> specForTypes k v
+  where
+    testKeyValueTypes =
+        [(kt, vt) | kt <- testKeyTypes, vt <- testValueTypesAll]
+
+specForTypes :: forall k v. (Test k v) => Proxy k -> Proxy v -> Spec
+specForTypes = makeSpec $ do
+    testLaws @(MonoidMap k v) jsonLaws
+    goldenSpecs goldenSettings (Proxy @(MonoidMap k v))
+
+goldenSettings :: Golden.Settings
+goldenSettings =
+    Golden.defaultSettings
+        { Golden.goldenDirectoryOption =
+            Golden.CustomDirectoryName "golden"
+        , Golden.comparisonFile =
+            Golden.OverwriteGoldenFile
+        , Golden.randomMismatchOption =
+            Golden.RandomMismatchError
+        , Golden.useModuleNameAsSubDirectory =
+            False
+        , Golden.sampleSize =
+            10
+        }
+
+data TestKeyType = forall k. (TestKey k) => TestKeyType (Proxy k)
+
+testKeyTypes :: [TestKeyType]
+testKeyTypes =
+    mconcat [testKeyTypes_textual, testKeyTypes_nonTextual]
+  where
+    -- A selection of key types for which keys are encoded as JSON strings.
+    -- For these types, 'MonoidMap' objects are encoded as JSON objects.
+    testKeyTypes_textual =
+        [ TestKeyType (Proxy @Int)
+        , TestKeyType (Proxy @Text)
+        ]
+    -- A selection of key types for which keys are NOT encoded as JSON strings.
+    -- For these types, 'MonoidMap' objects are encoded as JSON arrays.
+    testKeyTypes_nonTextual =
+        [ TestKeyType (Proxy @[Int])
+        , TestKeyType (Proxy @(Int, Int))
+        ]

components/monoidmap-test/Test/Common.hs

@@ -11,6 +11,7 @@
 module Test.Common
     ( Key
     , Test
+    , TestKey
     , TestValueType (..)
     , testValueTypesAll
     , testValueTypesGroup
@@ -30,6 +31,12 @@ module Test.Common
 
 import Prelude
 
+import Data.Aeson
+    ( FromJSON
+    , FromJSONKey
+    , ToJSON
+    , ToJSONKey
+    )
 import Data.Group
     ( Group )
 import Data.Kind
@@ -46,6 +53,8 @@ import Data.Monoid.Null
     ( MonoidNull )
 import Data.MonoidMap
     ( MonoidMap )
+import Data.MonoidMap.JSON
+    ()
 import Data.Proxy
     ( Proxy (Proxy) )
 import Data.Semigroup.Cancellative
@@ -156,6 +165,8 @@ type TestKey k =
     , Ord k
     , Show k
     , Typeable k
+    , ToJSONKey k
+    , FromJSONKey k
     )
 
 type TestValue v =
@@ -166,6 +177,8 @@ type TestValue v =
     , MonoidNull v
     , Show v
     , Typeable v
+    , ToJSON v
+    , FromJSON v
     )
 
 --------------------------------------------------------------------------------

components/monoidmap-test/Test/Key.hs

@@ -18,6 +18,19 @@ where
 
 import Prelude
 
+import Data.Aeson.Types
+    ( FromJSON (parseJSON)
+    , FromJSONKey (fromJSONKey)
+    , FromJSONKeyFunction (FromJSONKeyTextParser)
+    , Parser
+    , ToJSON (toEncoding, toJSON)
+    , ToJSONKey (toJSONKey)
+    , toJSONKeyText
+    , withText
+    )
+import Data.Text
+    ( Text
+    )
 import GHC.Generics
     ( Generic
     )
@@ -34,10 +47,15 @@ import Test.QuickCheck.Quid
     , Quid
     , Size (Size)
     )
+import Text.Read
+    ( readMaybe
+    )
 
-newtype Key (size :: Nat) = Key (Latin Quid)
+import qualified Data.Text as Text
+
+newtype Key (size :: Nat) = Key Quid
     deriving stock (Eq, Generic, Ord)
-    deriving newtype (Read, Show)
+    deriving (Read, Show) via Latin Quid
     deriving (Arbitrary) via Size size Quid
     deriving (CoArbitrary) via Quid
     deriving anyclass (Function)
@@ -46,3 +64,28 @@ type Key1 = Key 1
 type Key2 = Key 2
 type Key4 = Key 4
 type Key8 = Key 8
+
+instance ToJSON (Key size) where
+    toEncoding = toEncoding . toText
+    toJSON = toJSON . toText
+
+instance ToJSONKey (Key size) where
+    toJSONKey = toJSONKeyText toText
+
+instance FromJSON (Key size) where
+    parseJSON = withText "Key" parseFromText
+
+instance FromJSONKey (Key size) where
+    fromJSONKey = FromJSONKeyTextParser parseFromText
+
+toText :: Key size -> Text
+toText = Text.dropAround (== '\"') . Text.pack . show
+
+maybeFromText :: Text -> Maybe (Key size)
+maybeFromText = readMaybe . show . Text.unpack
+
+parseFromText :: Text -> Parser (Key size)
+parseFromText =
+    maybe (fail failureMessage) pure . maybeFromText
+  where
+    failureMessage = "Failed to parse key from JSON"