{-# 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 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)
import Data.Text (Text)

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 :: SrcLoc -> Int
srcLocStartLine :: 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 (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 (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 (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 ::
  HasCallStack =>
  Monad m =>
  Show a =>
  a ->
  m ()
dbgs :: forall (m :: * -> *) a.
(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_ ::
  HasCallStack =>
  Monad m =>
  Show a =>
  a ->
  m a
dbgs_ :: forall (m :: * -> *) a. (HasCallStack, Monad m, Show a) => a -> m a
dbgs_ a
a =
  a
a a -> m () -> 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 (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.traceShowId', but with 'Text' and with source location prefix.
trs ::
  Show a =>
  HasCallStack =>
  a ->
  a
trs :: forall a. (Show a, HasCallStack) => a -> a
trs a
a =
  IO a -> a
forall a. IO a -> a
unsafePerformIO (a
a a -> IO () -> 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 trs #-}

-- |Like 'Debug.Trace.traceShow', but with 'Text' and with source location prefix.
trs' ::
  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 (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' #-}