{-# language NoImplicitPrelude #-}

module Exon.Debug where

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
srcLocStartLine :: SrcLoc -> Int
srcLocStartLine :: Int
srcLocStartLine} Text
msg =
  [Char] -> IO ()
forall (m :: * -> *). MonadIO m => [Char] -> m ()
putStrLn ([Char]
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 :: [Char]
moduleName =
      Text -> [Char]
forall a. ToString a => a -> [Char]
toString (Text -> [Char]) -> Text -> [Char]
forall a b. (a -> b) -> a -> b
$ 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) (Text
prefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> a -> Text
forall b a. (Show a, IsString b) => a -> b
show a
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' #-}