{-# options_haddock prune #-}

-- |Utility functions for trace-printing values prefixed with the current source location.
module Incipit.Debug where

import qualified Data.Text as Text
import Data.Text (Text)
import GHC.Stack (CallStack, SrcLoc (..), callStack, getCallStack)
import System.IO.Unsafe (unsafePerformIO)

import Incipit.Base (
  Applicative (pure),
  Functor ((<$)),
  HasCallStack,
  IO,
  Monad,
  Semigroup ((<>)),
  Show,
  error,
  fromMaybe,
  putStrLn,
  )
import Incipit.List (last)
import Incipit.String.Conversion (ToString (toString), ToText (toText), show)

srcLoc :: CallStack -> SrcLoc
srcLoc :: CallStack -> SrcLoc
srcLoc = \case
  (CallStack -> [([Char], SrcLoc)]
getCallStack -> ([Char]
_, SrcLoc
loc) : [([Char], SrcLoc)]
_) -> SrcLoc
loc
  CallStack
_ -> [Char] -> SrcLoc
forall a. HasCallStack => [Char] -> a
error [Char]
"Debug.srcLoc: empty CallStack"

debugPrint ::
  SrcLoc ->
  Text ->
  IO ()
debugPrint :: SrcLoc -> Text -> IO ()
debugPrint SrcLoc {srcLocModule :: SrcLoc -> [Char]
srcLocModule = ([Char] -> Text
forall a. ToText a => a -> Text
toText -> Text
slm), Int
srcLocStartLine :: Int
srcLocStartLine :: SrcLoc -> Int
srcLocStartLine} !Text
msg =
  [Char] -> IO ()
putStrLn (Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
moduleName [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
":" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Int -> [Char]
forall b a. (Show a, IsString b) => a -> b
show Int
srcLocStartLine [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
msg)
  where
    moduleName :: Text
moduleName =
      Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
slm ([Text] -> Maybe Text
forall a. [a] -> Maybe a
last (HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"." Text
slm))

debugPrintWithLoc ::
  Monad m =>
  SrcLoc ->
  Text ->
  m ()
debugPrintWithLoc :: forall (m :: * -> *). Monad m => SrcLoc -> Text -> m ()
debugPrintWithLoc SrcLoc
loc Text
msg = do
  () <- () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  () <- () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (IO () -> ()
forall a. IO a -> a
unsafePerformIO (SrcLoc -> Text -> IO ()
debugPrint SrcLoc
loc Text
msg))
  () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- |Print a 'Text' in an arbitrary 'Monad'.
dbg ::
  HasCallStack =>
  Monad m =>
  Text ->
  m ()
dbg :: forall (m :: * -> *). (HasCallStack, Monad m) => Text -> m ()
dbg =
  SrcLoc -> Text -> m ()
forall (m :: * -> *). Monad m => SrcLoc -> Text -> m ()
debugPrintWithLoc (CallStack -> SrcLoc
srcLoc CallStack
HasCallStack => CallStack
callStack)
{-# noinline dbg #-}

-- |Print a value with a 'Show' instance in an arbitrary 'Monad'.
dbgs ::
  ∀ a m .
  HasCallStack =>
  Monad m =>
  Show a =>
  a ->
  m ()
dbgs :: forall a (m :: * -> *).
(HasCallStack, Monad m, Show a) =>
a -> m ()
dbgs a
a =
  SrcLoc -> Text -> m ()
forall (m :: * -> *). Monad m => SrcLoc -> Text -> m ()
debugPrintWithLoc (CallStack -> SrcLoc
srcLoc CallStack
HasCallStack => CallStack
callStack) (a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
a)
{-# noinline dbgs_ #-}

-- |Print a value with a 'Show' instance in an arbitrary 'Monad', returning the value.
dbgs_ ::
  ∀ a m .
  HasCallStack =>
  Monad m =>
  Show a =>
  a ->
  m a
dbgs_ :: forall a (m :: * -> *). (HasCallStack, Monad m, Show a) => a -> m a
dbgs_ a
a =
  a
a a -> m () -> m a
forall a b. a -> m b -> m a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SrcLoc -> Text -> m ()
forall (m :: * -> *). Monad m => SrcLoc -> Text -> m ()
debugPrintWithLoc (CallStack -> SrcLoc
srcLoc CallStack
HasCallStack => CallStack
callStack) (a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
a)
{-# noinline dbgs #-}

-- |Like 'Debug.Trace.trace', but with 'Text' and with source location prefix.
tr ::
  HasCallStack =>
  Text ->
  a ->
  a
tr :: forall a. HasCallStack => Text -> a -> a
tr Text
msg a
a =
  IO a -> a
forall a. IO a -> a
unsafePerformIO (a
a a -> IO () -> IO a
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SrcLoc -> Text -> IO ()
debugPrint (CallStack -> SrcLoc
srcLoc CallStack
HasCallStack => CallStack
callStack) Text
msg)
{-# noinline tr #-}

-- |Like 'Debug.Trace.traceShow', but with source location prefix.
trs ::
  ∀ b a .
  Show b =>
  HasCallStack =>
  b ->
  a ->
  a
trs :: forall b a. (Show b, HasCallStack) => b -> a -> a
trs b
b a
a =
  IO a -> a
forall a. IO a -> a
unsafePerformIO (a
a a -> IO () -> IO a
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SrcLoc -> Text -> IO ()
debugPrint (CallStack -> SrcLoc
srcLoc CallStack
HasCallStack => CallStack
callStack) (b -> Text
forall b a. (Show a, IsString b) => a -> b
show b
b))
{-# noinline trs #-}

-- |Like 'Debug.Trace.traceShowId', but with source location prefix.
trsi ::
  Show a =>
  HasCallStack =>
  a ->
  a
trsi :: forall a. (Show a, HasCallStack) => a -> a
trsi a
a =
  IO a -> a
forall a. IO a -> a
unsafePerformIO (a
a a -> IO () -> IO a
forall a b. a -> IO b -> IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ SrcLoc -> Text -> IO ()
debugPrint (CallStack -> SrcLoc
srcLoc CallStack
HasCallStack => CallStack
callStack) (a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
a))
{-# noinline trsi #-}