JSON enum roundtrips for BackendErrorType

gargantext.cabal

@@ -144,6 +144,7 @@ library
       Gargantext.Database.Schema.User
       Gargantext.Defaults
       Gargantext.System.Logging
+      Gargantext.Utils.Dict
       Gargantext.Utils.Jobs
       Gargantext.Utils.Jobs.Internal
       Gargantext.Utils.Jobs.Map

src/Gargantext/API/Errors.hs

@@ -21,7 +21,6 @@ import Gargantext.Database.Query.Table.Node.Error hiding (nodeError)
 import Servant.Server
 import qualified Data.Aeson as JSON
 import qualified Network.HTTP.Types.Status as HTTP
-import Data.Data
 import qualified Data.Text as T
 
 backendErrorTypeToErrStatus :: BackendErrorType -> HTTP.Status
@@ -53,9 +52,9 @@ nodeErrorToFrontendError ne = case ne of
   NoListFound _lid
     -> undefined
   NoRootFound
-    -> mkFrontendErr' renderedError Proxy FE_node_error_root_not_found
+    -> mkFrontendErr' renderedError FE_node_error_root_not_found
   NoCorpusFound
-    -> mkFrontendErr' renderedError Proxy FE_node_error_corpus_not_found
+    -> mkFrontendErr' renderedError FE_node_error_corpus_not_found
   NoUserFound _ur
     -> undefined
   MkNode

src/Gargantext/API/Errors/Types.hs

@@ -48,6 +48,7 @@ import Gargantext.Core.Types (HasValidationError(..))
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.Node.Error
 import Gargantext.Database.Query.Tree.Error
+import Gargantext.Utils.Dict
 import Prelude
 import Servant (ServerError)
 import Servant.Job.Core
@@ -146,11 +147,6 @@ instance Eq FrontendError where
             Nothing   -> False
             Just Refl -> fe_data_1 == fe_data_2
 
-data Dict (c :: k -> Constraint) (a :: k) where
-  Dict :: c a => Dict c a
-
-deriving instance Show (Dict c a)
-
 class ( SingI payload
       , ToJSON (ToFrontendErrorData payload)
       , FromJSON (ToFrontendErrorData payload)
@@ -212,17 +208,15 @@ instance FromJSON (ToFrontendErrorData 'BE_tree_error_root_not_found) where
     pure RootNotFound{..}
 
 mkFrontendErr :: IsFrontendErrorData payload
-              => Proxy (payload :: BackendErrorType)
-              -> ToFrontendErrorData payload
+              => ToFrontendErrorData payload
               -> FrontendError
 mkFrontendErr et = mkFrontendErr' mempty et
 
-mkFrontendErr' :: IsFrontendErrorData payload
+mkFrontendErr' :: forall payload. IsFrontendErrorData payload
                => T.Text
-               -> Proxy (payload :: BackendErrorType)
-               -> ToFrontendErrorData payload
+               -> ToFrontendErrorData (payload :: BackendErrorType)
                -> FrontendError
-mkFrontendErr' diag (Proxy :: Proxy payload) pl = FrontendError diag (fromSing $ sing @payload) pl
+mkFrontendErr' diag pl = FrontendError diag (fromSing $ sing @payload) pl
 
 instance Arbitrary BackendErrorType where
   arbitrary = arbitraryBoundedEnum
@@ -236,25 +230,20 @@ instance Arbitrary FrontendError where
 genFrontendErr :: T.Text -> BackendErrorType -> Gen FrontendError
 genFrontendErr txt be = case be of
   BE_node_error_root_not_found
-    -> pure $ mkFrontendErr' txt (Proxy @'BE_node_error_root_not_found) FE_node_error_root_not_found
+    -> pure $ mkFrontendErr' txt FE_node_error_root_not_found
   BE_node_error_corpus_not_found
-    -> pure $ mkFrontendErr' txt (Proxy @'BE_node_error_corpus_not_found) FE_node_error_corpus_not_found
+    -> pure $ mkFrontendErr' txt FE_node_error_corpus_not_found
   BE_tree_error_root_not_found
     -> do rootId <- arbitrary
-          pure $ mkFrontendErr' txt (Proxy @'BE_tree_error_root_not_found) (RootNotFound rootId)
-
--- | This compiles if we use the correct payload type, or otherwise it won't:
--- >>> mkFrontendErr (Proxy @'BE_phylo_corpus_not_ready) NodeNotFound
-_myTest :: FrontendError
-_myTest = mkFrontendErr (Proxy @'BE_node_error_root_not_found) FE_node_error_root_not_found
+          pure $ mkFrontendErr' txt (RootNotFound rootId)
 
 instance ToJSON BackendErrorType where
   toJSON = JSON.String . T.pack . drop 3 . show
 
 instance FromJSON BackendErrorType where
   parseJSON (String s) = case readMaybe (T.unpack $ "BE_" <> s) of
-    Just v                      -> pure v
-    Nothing                     -> fail $ "FromJSON BackendErrorType unexpected value: " <> T.unpack s
+    Just v     -> pure v
+    Nothing    -> fail $ "FromJSON BackendErrorType unexpected value: " <> T.unpack s
   parseJSON ty = typeMismatch "BackendErrorType" ty
 
 instance ToJSON FrontendError where

src/Gargantext/Utils/Dict.hs

+{-# LANGUAGE ConstraintKinds    #-}
+{-# LANGUAGE KindSignatures     #-}
+{-# LANGUAGE PolyKinds          #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Gargantext.Utils.Dict where
+
+import Prelude
+import Data.Kind
+
+-- A dictionary allowing us to treat constraints as first class values.
+data Dict (c :: k -> Constraint) (a :: k) where
+  Dict :: c a => Dict c a
+
+deriving instance Show (Dict c a)

test/Test/Offline/JSON.hs

 
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE QuasiQuotes #-}
 
 module Test.Offline.JSON (tests) where
@@ -27,6 +28,16 @@ jsonRoundtrip :: (Show a, FromJSON a, ToJSON a, Eq a) => a -> Property
 jsonRoundtrip a =
   counterexample ("Parsed JSON: " <> C8.unpack (encode a)) $ eitherDecode (encode a) === Right a
 
+class (Show a, FromJSON a, ToJSON a, Eq a, Enum a, Bounded a) => EnumBoundedJSON a
+instance EnumBoundedJSON BackendErrorType
+
+jsonEnumRoundtrip :: forall a. Dict EnumBoundedJSON a -> Property
+jsonEnumRoundtrip d = case d of
+  Dict -> conjoin $ map (prop Dict) [minBound .. maxBound]
+  where
+    prop :: Dict EnumBoundedJSON a -> a -> Property
+    prop Dict a = counterexample ("Parsed JSON: " <> C8.unpack (encode a)) $ eitherDecode (encode a) === Right a
+
 tests :: TestTree
 tests = testGroup "JSON" [
     testProperty "NodeId roundtrips"        (jsonRoundtrip @NodeId)
@@ -34,6 +45,7 @@ tests = testGroup "JSON" [
   , testProperty "Datafield roundtrips"     (jsonRoundtrip @Datafield)
   , testProperty "WithQuery roundtrips"     (jsonRoundtrip @WithQuery)
   , testProperty "FrontendError roundtrips" (jsonRoundtrip @FrontendError)
+  , testProperty "BackendErrorType roundtrips" (jsonEnumRoundtrip (Dict @_ @BackendErrorType))
   , testCase "WithQuery frontend compliance" testWithQueryFrontend
   , testGroup "Phylo" [
     testProperty "PeriodToNode"  (jsonRoundtrip @PeriodToNodeData)