Use Generics to check Aeson roundtrips recursively

test/unit/Cardano/Wallet/Api/TypesSpec.hs

@@ -1,10 +1,13 @@
 {-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell #-}
@@ -13,7 +16,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
-module Cardano.Wallet.Api.TypesSpec (spec) where
+module Cardano.Wallet.Api.TypesSpec where
 
 import Prelude
 
@@ -65,6 +68,8 @@ import Data.Typeable
     ( Typeable, typeOf )
 import Data.Word
     ( Word32, Word8 )
+import GHC.Generics
+    ( (:*:), (:+:), C, D, K1, M1, R, S, Selector, U1 )
 import GHC.TypeLits
     ( KnownSymbol, symbolVal )
 import Numeric.Natural
@@ -347,7 +352,6 @@ instance (JsonTestable a, JsonTestable b) => JsonTestable (a :<|> b) where
         roundtripAndGoldenPerType (Proxy @b)
 
 
-
 -- A way to demote 'StdMethod' back to the world of values. Servant provides a
 -- 'reflectMethod' that does just that, but demote types to raw 'ByteString' for
 -- an unknown reason :/
@@ -367,3 +371,50 @@ atMethod = \case
     DELETE -> delete
     PATCH -> patch
     m -> error $ "atMethod: unsupported method: " <> show m
+
+
+--------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
+--------------------------------------------------------------------------------
+
+-- | Return a @roundtripAndGolden@ spec for all
+-- components of an ADT.
+--
+-- We are relying heavily on generically derived Aeson instances. This is used
+-- to trace the failure of @roundtripAndGolden@.
+--
+-- Example:
+-- @
+--    data Record { a :: A, b :: B, c :: C, ds :: [D] }
+--        deriving (Generic, ToJSON, FromJSON)
+-- @
+--
+-- If we hand-write faulty Aeson instances for 'D', we'd like to discover that
+-- easily when checking roundtrips and goldens on 'Record'.
+--
+-- FIXME: Doesn't actually manage to search the entire depth. Just one layer.
+class GRecursiveCheckJSON rep where
+    gRecursiveCheckJSON :: Proxy rep -> [(String, Spec)]
+
+instance GRecursiveCheckJSON f => GRecursiveCheckJSON (M1 D x f) where
+  gRecursiveCheckJSON _ = gRecursiveCheckJSON (Proxy :: Proxy f)
+
+instance GRecursiveCheckJSON f => GRecursiveCheckJSON (M1 C x f) where
+  gRecursiveCheckJSON _ = gRecursiveCheckJSON (Proxy :: Proxy f)
+
+instance (Selector s, Checkable t) => GRecursiveCheckJSON (M1 S s (K1 R t)) where
+  gRecursiveCheckJSON _ =
+    [ (show $ typeOf (undefined :: t), roundtripAndGolden $ Proxy @t)]
+
+instance (Selector t, Checkable t) => GRecursiveCheckJSON (M1 C c (K1 R t)) where
+  gRecursiveCheckJSON _ =
+    [ (show $ typeOf (undefined :: t), roundtripAndGolden $ Proxy @t)]
+
+instance (GRecursiveCheckJSON a, GRecursiveCheckJSON b) => GRecursiveCheckJSON (a :*: b) where
+  gRecursiveCheckJSON _ = gRecursiveCheckJSON (Proxy :: Proxy a) ++ gRecursiveCheckJSON (Proxy :: Proxy b)
+
+instance (GRecursiveCheckJSON a, GRecursiveCheckJSON b) => GRecursiveCheckJSON (a :+: b) where
+  gRecursiveCheckJSON _ = gRecursiveCheckJSON (Proxy :: Proxy a) ++ gRecursiveCheckJSON (Proxy :: Proxy b)
+
+instance GRecursiveCheckJSON U1 where
+  gRecursiveCheckJSON _ = []