Support line number and module in logging via TH

src/Gargantext/API/Node/Corpus/New.hs

@@ -21,7 +21,6 @@ module Gargantext.API.Node.Corpus.New
 
 import Conduit
 import Control.Lens hiding (elements, Empty)
-import Control.Monad
 import Data.Aeson
 import Data.Aeson.TH (deriveJSON)
 import qualified Data.ByteString.Base64 as BSB64
@@ -204,15 +203,15 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
                                          , _wq_flowListWith = flw }) maybeLimit jobHandle = do
 
   -- TODO ...
-  logM DEBUG $ T.pack $ "[addToCorpusWithQuery] (cid, dbs) " <> show (cid, dbs)
-  logM DEBUG $ T.pack $ "[addToCorpusWithQuery] datafield  " <> show datafield
-  logM DEBUG $ T.pack $ "[addToCorpusWithQuery] flowListWith " <> show flw
+  $(logLocM) DEBUG $ T.pack $ "(cid, dbs) " <> show (cid, dbs)
+  $(logLocM) DEBUG $ T.pack $ "datafield  " <> show datafield
+  $(logLocM) DEBUG $ T.pack $ "flowListWith " <> show flw
 
   addLanguageToCorpus cid l
 
   case datafield of
     Just Web -> do
-      logM DEBUG $ T.pack $ "[addToCorpusWithQuery] processing web request " <> show datafield
+      $(logLocM) DEBUG $ T.pack $ "processing web request " <> show datafield
 
       markStarted 1 jobHandle
 
@@ -227,7 +226,7 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
       -- TODO if cid is folder -> create Corpus
       --      if cid is corpus -> add to corpus
       --      if cid is root   -> create corpus in Private
-      logM DEBUG $ T.pack $ "[G.A.N.C.New] getDataText with query: " <> show q
+      $(logLocM) DEBUG $ T.pack $ "getDataText with query: " <> show q
       let db = database2origin dbs
       mPubmedAPIKey <- getUserPubmedAPIKey user
       -- printDebug "[addToCorpusWithQuery] mPubmedAPIKey" mPubmedAPIKey
@@ -240,8 +239,8 @@ addToCorpusWithQuery user cid (WithQuery { _wq_query = q
 
           markProgress 1 jobHandle
 
-          void $ flowDataText user txt (Multi l) cid (Just flw) jobHandle
-          -- printDebug "corpus id" cids
+          corpusId <- flowDataText user txt (Multi l) cid (Just flw) jobHandle
+          $(logLocM) DEBUG $ T.pack $ "corpus id " <> show corpusId
           -- printDebug "sending email" ("xxxxxxxxxxxxxxxxxxxxx" :: Text)
           sendMail user
           -- TODO ...

src/Gargantext/System/Logging.hs

-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies    #-}
 
 module Gargantext.System.Logging (
     LogLevel(..)
   , HasLogger(..)
   , MonadLogger(..)
   , logM
+  , logLocM
   , withLogger
   , withLoggerHoisted
   ) where
 
+import Language.Haskell.TH hiding (Type)
 import Control.Exception.Lifted (bracket)
 import Control.Monad.IO.Class
 import Control.Monad.Trans.Control
 import Data.Kind (Type)
 import Prelude
 import qualified Data.Text as T
+import qualified Language.Haskell.TH.Syntax        as TH
 
 data LogLevel =
   -- | Debug messages
@@ -61,6 +65,35 @@ logM level msg = do
   logger <- getLogger
   logTxt logger level msg
 
+-- | Like 'logM', but it automatically adds the file and line number to
+-- the output log.
+logLocM :: ExpQ
+logLocM = [| \level msg ->
+  let loc = $(getLocTH)
+  in logM level (formatWithLoc loc msg)
+  |]
+
+formatWithLoc :: Loc -> T.Text -> T.Text
+formatWithLoc loc msg = "[" <> locationToText <> "] " <> msg
+  where
+    locationToText :: T.Text
+    locationToText = T.pack $ (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)
+      where
+        line = show . fst . loc_start
+        char = show . snd . loc_start
+
+getLocTH :: ExpQ
+getLocTH = [| $(location >>= liftLoc) |]
+
+liftLoc :: Loc -> Q Exp
+liftLoc (Loc a b c (d1, d2) (e1, e2)) = [|Loc
+    $(TH.lift a)
+    $(TH.lift b)
+    $(TH.lift c)
+    ($(TH.lift d1), $(TH.lift d2))
+    ($(TH.lift e1), $(TH.lift e2))
+    |]
+
 -- | exception-safe combinator that creates and destroys a logger.
 -- Think about it like a 'bracket' function from 'Control.Exception'.
 withLogger :: (MonadBaseControl IO m, MonadIO m, HasLogger m)