{-# LANGUAGE NoImplicitPrelude #-}

module Polysemy.Time.Debug where

import Data.String.Interpolate (i)
import qualified Data.Text as Text
import GHC.Stack (SrcLoc(..))
import Relude
import System.IO.Unsafe (unsafePerformIO)

srcLoc :: CallStack -> SrcLoc
srcLoc :: CallStack -> SrcLoc
srcLoc = \case
  (CallStack -> [([Char], SrcLoc)]
getCallStack -> ([Char]
_, SrcLoc
loc) : [([Char], SrcLoc)]
_) -> SrcLoc
loc
  CallStack
_ -> Text -> SrcLoc
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"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
[Char]
srcLocPackage :: SrcLoc -> [Char]
srcLocFile :: SrcLoc -> [Char]
srcLocStartLine :: SrcLoc -> Int
srcLocStartCol :: SrcLoc -> Int
srcLocEndLine :: SrcLoc -> Int
srcLocEndCol :: SrcLoc -> Int
srcLocEndCol :: Int
srcLocEndLine :: Int
srcLocStartCol :: Int
srcLocStartLine :: Int
srcLocFile :: [Char]
srcLocPackage :: [Char]
..} Text
msg =
  [Char] -> IO ()
forall (m :: * -> *). MonadIO m => [Char] -> m ()
putStrLn [i|#{moduleName}:#{srcLocStartLine} #{msg}|]
  where
    moduleName :: Text
moduleName =
      Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
slm (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> Maybe Text
forall a. [a] -> Maybe a
listToMaybe ([Text] -> Maybe Text) -> [Text] -> Maybe Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
reverse ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
Text.splitOn Text
"." Text
slm

debugPrintWithLoc ::
  Monad m =>
  SrcLoc ->
  Text ->
  m ()
debugPrintWithLoc :: SrcLoc -> Text -> m ()
debugPrintWithLoc SrcLoc
loc Text
msg = do
  () <- () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return (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 ()

dbg ::
  HasCallStack =>
  Monad m =>
  Text ->
  m ()
dbg :: Text -> m ()
dbg =
  SrcLoc -> Text -> m ()
forall (m :: * -> *). Monad m => SrcLoc -> Text -> m ()
debugPrintWithLoc (CallStack -> SrcLoc
srcLoc CallStack
HasCallStack => CallStack
callStack)
{-# inline dbg #-}

dbgsWith ::
  HasCallStack =>
  Monad m =>
  Show a =>
  Text ->
  a ->
  m ()
dbgsWith :: Text -> a -> m ()
dbgsWith Text
prefix a
a =
  SrcLoc -> Text -> m ()
forall (m :: * -> *). Monad m => SrcLoc -> Text -> m ()
debugPrintWithLoc (CallStack -> SrcLoc
srcLoc CallStack
HasCallStack => CallStack
callStack) [i|#{prefix}: #{show @Text a}|]
{-# inline dbgsWith #-}

dbgs ::
  HasCallStack =>
  Monad m =>
  Show a =>
  a ->
  m ()
dbgs :: 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)
{-# inline dbgs_ #-}

dbgs_ ::
  HasCallStack =>
  Monad m =>
  Show a =>
  a ->
  m a
dbgs_ :: 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)
{-# inline dbgs #-}

tr ::
  HasCallStack =>
  Text ->
  a ->
  a
tr :: 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)
{-# inline tr #-}

trs ::
  Show a =>
  HasCallStack =>
  a ->
  a
trs :: 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))
{-# inline trs #-}

trs' ::
  Show b =>
  HasCallStack =>
  b ->
  a ->
  a
trs' :: 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))
{-# inline trs' #-}