Auto-derive IsFrontendErrorData

gargantext.cabal

@@ -55,6 +55,7 @@ library
       Gargantext.API.Errors.Class
       Gargantext.API.Errors.TH
       Gargantext.API.Errors.Types
+      Gargantext.API.Errors.Types.Backend
       Gargantext.API.HashedResponse
       Gargantext.API.Ngrams
       Gargantext.API.Ngrams.Prelude

src/Gargantext/API/Errors/TH.hs

@@ -3,16 +3,17 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell   #-}
 module Gargantext.API.Errors.TH (
-  deriveHttpStatusCode
+    deriveHttpStatusCode
+  , deriveIsFrontendErrorData
   ) where
 
 import           Prelude
 
+import           Gargantext.API.Errors.Types.Backend
 import           Network.HTTP.Types
 import qualified Data.Map.Strict                as Map
 import qualified Data.Text                      as T
 import qualified Language.Haskell.TH            as TH
-import Gargantext.API.Errors.Types
 import qualified Network.HTTP.Types as HTTP
 
 -- | A static map of the HTTP status code we support.
@@ -72,3 +73,16 @@ parse_error_codes = mapM go
              Just st -> Right (n, st, msg)
       where
         (code, msg) = do_parse $ (T.pack $ TH.nameBase n)
+
+deriveIsFrontendErrorData :: TH.Name -> TH.Q [TH.Dec]
+deriveIsFrontendErrorData appliedType = do
+  info <- TH.reify appliedType
+  case info of
+    TH.TyConI (TH.DataD _ _ _ _ ctors _)
+      -> case extract_names ctors of
+           Left ctor   -> error $ "Only enum-like constructors supported: " ++ show ctor
+           Right names -> fmap mconcat . sequence $ flip map names $ \n ->
+               [d| instance IsFrontendErrorData $(TH.promotedT n) where
+                     isFrontendErrorData _ = Dict |]
+    err
+      -> error $ "Cannot call deriveHttpStatusCode on: " ++ show err

src/Gargantext/API/Errors/Types.hs

@@ -11,10 +11,11 @@
 {-# LANGUAGE TypeFamilies             #-}
 {-# LANGUAGE TypeFamilyDependencies   #-}
 {-# OPTIONS_GHC -Wno-unused-top-binds #-}
+{-# OPTIONS_GHC -Wno-orphans          #-} -- instance IsFrontendErrorData and stage restriction
 
 module Gargantext.API.Errors.Types (
   -- * The main frontend error type
-  FrontendError(..)
+    FrontendError(..)
 
   -- * The internal backend type and an enumeration of all possible backend error types
   , BackendErrorCode(..)
@@ -41,13 +42,14 @@ import Control.Exception
 import Control.Lens (makePrisms)
 import Data.Aeson as JSON
 import Data.Aeson.Types (typeMismatch, emptyArray)
-import Data.Kind
 import Data.Singletons.TH
 import Data.Typeable
 import Data.Validity (Validation)
 import GHC.Generics
 import GHC.Stack
 import Gargantext.API.Errors.Class
+import Gargantext.API.Errors.TH
+import Gargantext.API.Errors.Types.Backend
 import Gargantext.Core.Types (HasValidationError(..))
 import Gargantext.Database.Admin.Types.Node
 import Gargantext.Database.Query.Table.Node.Error
@@ -120,19 +122,6 @@ instance HasServerError BackendInternalError where
 instance HasJoseError BackendInternalError where
   _JoseError = _InternalJoseError
 
--- | A (hopefully and eventually) exhaustive list of backend errors.
-data BackendErrorCode
-  =
-  -- node errors
-    EC_404__node_error_list_not_found
-  | EC_404__node_error_root_not_found
-  | EC_404__node_error_corpus_not_found
-  -- tree errors
-  | EC_404__tree_error_root_not_found
-  deriving (Show, Read, Eq, Enum, Bounded)
-
-$(genSingletons [''BackendErrorCode])
-
 -- | An error that can be returned to the frontend. It carries a human-friendly
 -- diagnostic, the 'type' of the error as well as some context-specific data.
 data FrontendError where
@@ -142,6 +131,25 @@ data FrontendError where
     , fe_data       :: ToFrontendErrorData b
     } -> FrontendError
 
+-- | Creates an error without attaching a diagnostic to it.
+mkFrontendErrNoDiagnostic :: IsFrontendErrorData payload
+                          => ToFrontendErrorData payload
+                          -> FrontendError
+mkFrontendErrNoDiagnostic et = mkFrontendErr' mempty et
+
+-- | Renders the error by using as a diagnostic the string
+-- resulting from 'Show'ing the underlying type.
+mkFrontendErrShow :: IsFrontendErrorData payload
+                  => ToFrontendErrorData payload
+                  -> FrontendError
+mkFrontendErrShow et = mkFrontendErr' (T.pack $ show et) et
+
+mkFrontendErr' :: forall payload. IsFrontendErrorData payload
+               => T.Text
+               -> ToFrontendErrorData (payload :: BackendErrorCode)
+               -> FrontendError
+mkFrontendErr' diag pl = FrontendError diag (fromSing $ sing @payload) pl
+
 deriving instance Show FrontendError
 instance Eq FrontendError where
   f1 == f2 = case (f1, f2) of
@@ -152,32 +160,14 @@ instance Eq FrontendError where
             Nothing   -> False
             Just Refl -> fe_data_1 == fe_data_2
 
-class ( SingI payload
-      , ToJSON (ToFrontendErrorData payload)
-      , FromJSON (ToFrontendErrorData payload)
-      , Show (ToFrontendErrorData payload)
-      , Eq (ToFrontendErrorData payload)
-      , Typeable payload
-      ) => IsFrontendErrorData payload where
-  isFrontendErrorData :: Proxy payload -> Dict IsFrontendErrorData payload
-
-instance IsFrontendErrorData 'EC_404__node_error_list_not_found where
-  isFrontendErrorData _ = Dict
-instance IsFrontendErrorData 'EC_404__node_error_root_not_found where
-  isFrontendErrorData _ = Dict
-instance IsFrontendErrorData 'EC_404__node_error_corpus_not_found where
-  isFrontendErrorData _ = Dict
-instance IsFrontendErrorData 'EC_404__tree_error_root_not_found where
-  isFrontendErrorData _ = Dict
+$(deriveIsFrontendErrorData ''BackendErrorCode)
 
 ----------------------------------------------------------------------------
--- This data family maps a 'BackendErrorCode' into a concrete payload.
+-- ToFrontendErrorData data family instances
 ----------------------------------------------------------------------------
 
 data NoFrontendErrorData = NoFrontendErrorData
 
-data family ToFrontendErrorData (payload :: BackendErrorCode) :: Type
-
 newtype instance ToFrontendErrorData 'EC_404__node_error_list_not_found =
   FE_node_error_list_not_found { lnf_list_id :: ListId }
   deriving (Show, Eq, Generic)
@@ -227,25 +217,6 @@ instance FromJSON (ToFrontendErrorData 'EC_404__tree_error_root_not_found) where
     _rnf_rootId <- o .: "root_id"
     pure RootNotFound{..}
 
--- | Creates an error without attaching a diagnostic to it.
-mkFrontendErrNoDiagnostic :: IsFrontendErrorData payload
-                          => ToFrontendErrorData payload
-                          -> FrontendError
-mkFrontendErrNoDiagnostic et = mkFrontendErr' mempty et
-
--- | Renders the error by using as a diagnostic the string
--- resulting from 'Show'ing the underlying type.
-mkFrontendErrShow :: IsFrontendErrorData payload
-                  => ToFrontendErrorData payload
-                  -> FrontendError
-mkFrontendErrShow et = mkFrontendErr' (T.pack $ show et) et
-
-mkFrontendErr' :: forall payload. IsFrontendErrorData payload
-               => T.Text
-               -> ToFrontendErrorData (payload :: BackendErrorCode)
-               -> FrontendError
-mkFrontendErr' diag pl = FrontendError diag (fromSing $ sing @payload) pl
-
 ----------------------------------------------------------------------------
 -- Arbitrary instances and test data generation
 ----------------------------------------------------------------------------

src/Gargantext/API/Errors/Types/Backend.hs

+{-# LANGUAGE KindSignatures           #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TemplateHaskell          #-}
+{-# LANGUAGE TypeFamilies             #-}
+
+module Gargantext.API.Errors.Types.Backend where
+
+import Data.Aeson
+import Data.Kind
+import Data.Singletons.TH
+import Data.Typeable
+import Gargantext.Utils.Dict
+import Prelude
+
+-- | A (hopefully and eventually) exhaustive list of backend errors.
+data BackendErrorCode
+  =
+  -- node errors
+    EC_404__node_error_list_not_found
+  | EC_404__node_error_root_not_found
+  | EC_404__node_error_corpus_not_found
+  -- tree errors
+  | EC_404__tree_error_root_not_found
+  deriving (Show, Read, Eq, Enum, Bounded)
+
+$(genSingletons [''BackendErrorCode])
+
+----------------------------------------------------------------------------
+-- This data family maps a 'BackendErrorCode' into a concrete payload.
+----------------------------------------------------------------------------
+data family ToFrontendErrorData (payload :: BackendErrorCode) :: Type
+
+class ( SingI payload
+      , ToJSON (ToFrontendErrorData payload)
+      , FromJSON (ToFrontendErrorData payload)
+      , Show (ToFrontendErrorData payload)
+      , Eq (ToFrontendErrorData payload)
+      , Typeable payload
+      ) => IsFrontendErrorData payload where
+  isFrontendErrorData :: Proxy payload -> Dict IsFrontendErrorData payload