{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE TypeFamilies         #-}
{-# LANGUAGE TypeApplications     #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

module Gargantext.System.Logging (
    module Gargantext.System.Logging.Types
  , logM
  , logLocM
  , logLoc
  , withLogger
  , withLoggerIO
  ) where

import Gargantext.System.Logging.Types
import Gargantext.System.Logging.Loggers
import Control.Exception.Safe (MonadMask, bracket)
import Gargantext.Core.Config (LogConfig(..))
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Data.Text qualified as T
import Language.Haskell.TH hiding (Type)
import Language.Haskell.TH.Syntax qualified as TH
import Prelude


-- | A variant of 'logTxt' that doesn't require passing an explicit 'Logger'.
logM :: (Monad m, MonadLogger m) => LogLevel -> T.Text -> m ()
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)
  |]

logLoc :: ExpQ
logLoc = [| \logger level msg ->
  let loc = $(getLocTH)
  in logTxt logger 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, MonadMask m)
           => LogInitParams m
           -> (Logger m -> m a)
           -> m a
withLogger params = bracket (initLogger params) destroyLogger

-- | Like 'withLogger', but it allows creating a 'Logger' that can run in
-- a different monad from within an 'IO' action.
withLoggerIO :: (MonadBaseControl IO m, HasLogger m)
             => LogInitParams m
             -> (Logger m -> IO a)
             -> IO a
withLoggerIO params act = bracket (initLogger params) destroyLogger act

-- | A plain logger in the IO monad, waiting for more serious logging solutions like
-- the one described in https://gitlab.iscpif.fr/gargantext/haskell-gargantext/issues/229
instance HasLogger IO where
  data instance Logger IO        = IOLogger { _IOLogger :: IOStdLogger }
  type instance LogInitParams IO = LogConfig
  type instance LogPayload IO    = String
  initLogger cfg = fmap IOLogger $ (liftIO $ ioStdLogger cfg)
  destroyLogger = liftIO . _iosl_destroy . _IOLogger
  logMsg (IOLogger ioLogger) = _iosl_log_msg ioLogger
  logTxt (IOLogger ioLogger) lvl msg = liftIO $ _iosl_log_txt ioLogger lvl msg