Attach CallStack to fromDBid error

gargantext.cabal

@@ -75,6 +75,7 @@ library
       Gargantext.API.Prelude
       Gargantext.API.Routes
       Gargantext.Core
+      Gargantext.Core.Errors.Types
       Gargantext.Core.Mail.Types
       Gargantext.Core.Methods.Similarities
       Gargantext.Core.NLP
@@ -948,6 +949,7 @@ test-suite garg-test-tasty
       Test.Ngrams.NLP
       Test.Ngrams.Query
       Test.Ngrams.Query.PaginationCorpus
+      Test.Offline.Errors
       Test.Offline.JSON
       Test.Parsers.Date
       Test.Parsers.Types

src/Gargantext/Core.hs

@@ -25,6 +25,9 @@ import Data.Text (pack)
 import Gargantext.Prelude hiding (All)
 import Servant.API
 import Test.QuickCheck
+import Control.Exception (throw)
+import Prelude (userError)
+import Gargantext.Core.Errors.Types (WithStacktrace(..))
 
 ------------------------------------------------------------------------
 -- | Language of a Text
@@ -190,5 +193,7 @@ instance HasDBid PosTagAlgo where
 -- with an error if the conversion cannot be performed.
 fromDBid :: forall a. (HasCallStack, HasDBid a, Typeable a) => Int -> a
 fromDBid i = case lookupDBid i of
-  Nothing -> panic $ "HasDBid " <> show (typeRep (Proxy :: Proxy a)) <> " not found or not implemented."
+  Nothing ->
+    let err = userError $ "HasDBid " <> show (typeRep (Proxy :: Proxy a)) <> " not found or not implemented."
+    in throw $ WithStacktrace callStack err
   Just v  -> v

src/Gargantext/Core/Errors/Types.hs

+module Gargantext.Core.Errors.Types (
+  -- * Attaching callstacks to exceptions
+  WithStacktrace(..)
+  ) where
+
+import Control.Exception
+import GHC.Stack
+import Prelude
+
+-- | A 'WithStacktrace' carries an error alongside its
+-- 'CallStack', to be able to print the correct source location
+-- of where the error originated.
+data WithStacktrace e =
+  WithStacktrace {
+    ct_callStack :: !CallStack
+  , ct_error     :: !e
+  } deriving Show
+
+instance Exception e => Exception (WithStacktrace e) where
+  displayException WithStacktrace{..}
+    = displayException ct_error <> "\n" <> prettyCallStack ct_callStack

test/Test/Offline/Errors.hs

+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+module Test.Offline.Errors (tests) where
+
+import Control.Exception
+import Gargantext.Core (fromDBid)
+import Gargantext.Core.Errors.Types
+import Gargantext.Database.Admin.Config ()
+import Gargantext.Database.Admin.Types.Node
+import Prelude
+import Test.Tasty
+import Test.Tasty.HUnit
+
+tests :: TestTree
+tests = testGroup "Errors" [
+    testCase "fromDBid comes with a CallStack" fromDBid_cs
+  ]
+
+fromDBid_cs :: Assertion
+fromDBid_cs = do
+  res <- try $ evaluate $ fromDBid @NodeType 99
+  case res of
+    Right r -> fail $ "fromDBid should have failed, but returned: " <> show r
+    Left (_ :: WithStacktrace IOError)
+      -> pure ()

test/drivers/tasty/Main.hs

@@ -18,6 +18,7 @@ import qualified Test.Graph.Clustering        as Graph
 import qualified Test.Ngrams.NLP              as NLP
 import qualified Test.Ngrams.Query            as NgramsQuery
 import qualified Test.Offline.JSON            as JSON
+import qualified Test.Offline.Errors          as Errors
 import qualified Test.Parsers.Date            as PD
 import qualified Test.Utils.Crypto            as Crypto
 import qualified Test.Utils.Jobs              as Jobs
@@ -46,4 +47,5 @@ main = do
     , NgramsQuery.tests
     , CorpusQuery.tests
     , JSON.tests
+    , Errors.tests
     ]