content: {-
    Copyright (c) Meta Platforms, Inc. and affiliates.
    All rights reserved.
  
    This source code is licensed under the BSD-style license found in the
    LICENSE file in the root directory of this source tree.
  -}
  
  {-# LANGUAGE ViewPatterns, CPP #-}
  module Control.Trace.VLog (
    vlogTracer,
    TraceWithPriority (..),
    vlogTracerWithPriority,
    vlogShowTracer,
    vlogTextTracer,
  ) where
  
  import Control.Monad (when)
  import Control.Monad.Catch (
    ExitCase (
      ExitCaseAbort,
      ExitCaseException,
      ExitCaseSuccess
    ),
   )
  import Control.Monad.IO.Class
  import Control.Trace.Core
  import Data.Some
  import Data.Text (Text)
  import GHC.Stack
  import TextShow (
    TextShow,
    showt,
   )
  import qualified Util.Log.String as String
  import Util.Log.Text
  
  vlogShowTracer :: TextShow a => (a -> Int) -> Tracer a
  vlogShowTracer =
    vlogTracer
      (\(showt -> x) -> ("BEGIN " <> x, \e -> "END" <> renderExitCase e <> x))
      showt
  
  renderExitCase :: Some ExitCase -> Text
  renderExitCase (Some ExitCaseAbort {}) = "(aborted) "
  renderExitCase (Some (ExitCaseException e)) = "(" <> showt e <> ") "
  renderExitCase (Some ExitCaseSuccess {}) = " "
  
  vlogTextTracer :: Int -> Tracer Text
  vlogTextTracer p =
    vlogTracer
      (\x -> ("BEGIN " <> x, \e -> "END" <> renderExitCase e <> x))
      id
      (const p)
  
  data TraceWithPriority
    = Skip
    | T !Int !Text
    | S !Int !String
  
  vlogTracerWithPriority :: Tracer TraceWithPriority
  vlogTracerWithPriority = Tracer {..}
    where
      logMsg_ :: (HasCallStack, MonadIO m) => TraceWithPriority -> m ()
      logMsg_ Skip = pure ()
      logMsg_ x = withFrozenCallStack $ case x of
        T p t -> vlog p t
        S p s -> String.vlog p s
  #if __GLASGOW_HASKELL__ < 902
        Skip -> error "unreachable"
  #endif
  
      traceMsg_ msg =
        case msg of
          T p t -> do
              vlog p ("BEGIN " <> t)
              return ( \res -> case res of
                  ExitCaseSuccess {} -> vlog p ("END " <> t)
                  ExitCaseAbort {} -> vlog p ("ABORTED " <> t)
                  ExitCaseException e -> vlog p ("FAILED " <> t <> ": " <> showt e)
                )
          S p t -> do
              String.vlog p ("BEGIN " <> t)
              return ( \res -> case res of
                  ExitCaseSuccess {} -> String.vlog p ("END " <> t)
                  ExitCaseAbort {} -> String.vlog p ("ABORTED " <> t)
                  ExitCaseException e ->
                    String.vlog p ("FAILED " <> t <> ": " <> show e)
                )
          Skip -> return $ const $ return ()
  
  vlogTracer ::
    forall a.
    -- | render BEGIN and END messages
    (a -> (Text, Some ExitCase -> Text)) ->
    -- | render LOG message
    (a -> Text) ->
    -- | Priority (use -1 to skip)
    (a -> Int) ->
    Tracer a
  vlogTracer beginend log_ prio = Tracer {..}
    where
      logMsg_ :: a -> IO ()
      logMsg_ msg =
          let p = prio msg
           in when (p >= 0) $ vlog p $ log_ msg
  
      traceMsg_ :: a -> IO (ExitCase b -> IO ())
      traceMsg_ msg = do
        let p = prio msg
            (b, e) = beginend msg
        if p >= 0
          then vlog p b >> return (\res -> vlog p (e $ mkSome res))
          else return $ const $ return ()
  