-- Copyright 2013 Evan Laforge
-- This program is distributed under the terms of the GNU General Public
-- License 3.0, see COPYING or http://www.gnu.org/licenses/gpl-3.0.txt

{-# LANGUAGE OverloadedStrings #-}
module Util.Debug (
    full, fullM
    -- * forced by evaluation
    , trace, tracep, traces, tracesp
    , tracef, tracefp, trace_ret, trace_retp
    , trace_str
    -- * forced by monad
    , traceM, tracepM, tracesM
    -- in IO
    , puts, put, putp
) where
import qualified Control.DeepSeq as DeepSeq
import qualified Control.Exception as Exception
import qualified Control.Monad.Trans as Trans

import qualified Data.Text as Text
import           Data.Text (Text)
import qualified Data.Text.IO as Text.IO

import           GHC.Stack (HasCallStack)
import qualified System.IO as IO
import qualified System.IO.Unsafe as Unsafe
import qualified System.Timeout as Timeout

import qualified Util.CallStack as CallStack
import qualified Util.Log as Log
import qualified Util.PPrint as PPrint
import qualified Util.Pretty as Pretty
import           Util.Pretty (Pretty)


-- | Only apply the function if the val is non-mempty.  Useful for the trace
-- family.
full :: (Eq a, Monoid a) => (a -> a) -> a -> a
full :: forall a. (Eq a, Monoid a) => (a -> a) -> a -> a
full a -> a
f a
val
    | a
val forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = a
val
    | Bool
otherwise = a -> a
f a
val

-- | Like 'full' but useful for the traceM and put family.
fullM :: (Monad m, Eq a, Monoid a) => (a -> m ()) -> a -> m ()
fullM :: forall (m :: * -> *) a.
(Monad m, Eq a, Monoid a) =>
(a -> m ()) -> a -> m ()
fullM a -> m ()
f a
val
    | a
val forall a. Eq a => a -> a -> Bool
== forall a. Monoid a => a
mempty = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    | Bool
otherwise = a -> m ()
f a
val

-- * forced by evaluation

-- | Print a showable value en passant.
trace :: (HasCallStack, Show a) => Text -> a -> a
trace :: forall a. (HasCallStack, Show a) => Text -> a -> a
trace Text
msg a
val = forall b a. (HasCallStack, Show b) => Text -> b -> a -> a
traces Text
msg a
val a
val

-- | Pretty print a value en passant.
tracep :: (HasCallStack, Pretty a) => Text -> a -> a
tracep :: forall a. (HasCallStack, Pretty a) => Text -> a -> a
tracep Text
msg a
val = forall a. HasCallStack => Text -> a -> a
write (HasCallStack => Text -> Text -> Text
with_msg Text
msg (forall a. Pretty a => a -> Text
Pretty.formatted a
val)) a
val

-- | Print a showable value.
traces :: (HasCallStack, Show b) => Text -> b -> a -> a
traces :: forall b a. (HasCallStack, Show b) => Text -> b -> a -> a
traces Text
msg b
val = forall a. HasCallStack => Text -> a -> a
write (HasCallStack => Text -> Text -> Text
with_msg Text
msg (forall a. Show a => a -> Text
pshow b
val))

-- | Pretty print a value.
tracesp :: (HasCallStack, Pretty b) => Text -> b -> a -> a
tracesp :: forall b a. (HasCallStack, Pretty b) => Text -> b -> a -> a
tracesp Text
msg b
traced = forall a. HasCallStack => Text -> a -> a
write (HasCallStack => Text -> Text -> Text
with_msg Text
msg (forall a. Pretty a => a -> Text
Pretty.formatted b
traced))

-- | Print a value after applying a function to it.
tracef :: (HasCallStack, Show b) => Text -> (a -> b) -> a -> a
tracef :: forall b a. (HasCallStack, Show b) => Text -> (a -> b) -> a -> a
tracef Text
msg a -> b
f a
val = forall a. HasCallStack => Text -> a -> a
write (HasCallStack => Text -> Text -> Text
with_msg Text
msg (forall a. Show a => a -> Text
pshow (a -> b
f a
val))) a
val

tracefp :: (HasCallStack, Pretty b) => Text -> (a -> b) -> a -> a
tracefp :: forall b a. (HasCallStack, Pretty b) => Text -> (a -> b) -> a -> a
tracefp Text
msg a -> b
f a
val = forall a. HasCallStack => Text -> a -> a
write (HasCallStack => Text -> Text -> Text
with_msg Text
msg (forall a. Pretty a => a -> Text
Pretty.formatted (a -> b
f a
val))) a
val

-- | Trace input and output of a function.
trace_ret :: (HasCallStack, Show a, Show b) => Text -> a -> b -> b
trace_ret :: forall a b. (HasCallStack, Show a, Show b) => Text -> a -> b -> b
trace_ret Text
function a
a b
ret = forall a. HasCallStack => Text -> a -> a
trace_str Text
text b
ret
    where
    text :: Text
text = forall a. Monoid a => [a] -> a
mconcat
        [ Text
function
        , if Bool
multiline then Text
"\n" else Text
" "
        , Text
pa
        , if Bool
multiline then Text
"\n\t\t=>\n" else Text
" => "
        , Text
pret
        ]
    multiline :: Bool
multiline = Text
"\n" Text -> Text -> Bool
`Text.isInfixOf` Text
pa Bool -> Bool -> Bool
|| Text
"\n" Text -> Text -> Bool
`Text.isInfixOf` Text
pret
    pa :: Text
pa = forall a. Show a => a -> Text
pshow a
a
    pret :: Text
pret = forall a. Show a => a -> Text
pshow b
ret

trace_retp :: (HasCallStack, Pretty a, Pretty b) =>
    Text -> a -> b -> b
trace_retp :: forall a b.
(HasCallStack, Pretty a, Pretty b) =>
Text -> a -> b -> b
trace_retp Text
function a
a b
ret = forall a. HasCallStack => Text -> a -> a
trace_str Text
text b
ret
    where
    text :: Text
text = forall a. Monoid a => [a] -> a
mconcat
        [ Text
function
        , if Bool
multiline then Text
"\n" else Text
" "
        , Text
pa
        , if Bool
multiline then Text
"\n\t\t=>\n" else Text
" => "
        , Text
pret
        ]
    multiline :: Bool
multiline = Text
"\n" Text -> Text -> Bool
`Text.isInfixOf` Text
pa Bool -> Bool -> Bool
|| Text
"\n" Text -> Text -> Bool
`Text.isInfixOf` Text
pret
    pa :: Text
pa = Text -> Text
Text.strip forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
Pretty.formatted a
a
    pret :: Text
pret = Text -> Text
Text.strip forall a b. (a -> b) -> a -> b
$ forall a. Pretty a => a -> Text
Pretty.formatted b
ret

-- | Show a raw string, equivalent to 'Debug.Trace.trace'.
trace_str :: HasCallStack => Text -> a -> a
trace_str :: forall a. HasCallStack => Text -> a -> a
trace_str = forall a. HasCallStack => Text -> a -> a
write forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HasCallStack => Text
prefix<>)

-- * forced by monad

-- | Print a value in a monad.  The monad will force it to be printed.
traceM :: (HasCallStack, Show a, Monad m) => Text -> a -> m ()
traceM :: forall a (m :: * -> *).
(HasCallStack, Show a, Monad m) =>
Text -> a -> m ()
traceM Text
msg a
val = forall a. HasCallStack => Text -> a -> a
write (HasCallStack => Text -> Text -> Text
with_msg Text
msg (forall a. Show a => a -> Text
pshow a
val)) (forall (m :: * -> *) a. Monad m => a -> m a
return ())

tracepM :: (HasCallStack, Pretty a, Monad m) => Text -> a -> m ()
tracepM :: forall a (m :: * -> *).
(HasCallStack, Pretty a, Monad m) =>
Text -> a -> m ()
tracepM Text
msg a
val = forall a. HasCallStack => Text -> a -> a
write (HasCallStack => Text -> Text -> Text
with_msg Text
msg (forall a. Pretty a => a -> Text
Pretty.formatted a
val)) (forall (m :: * -> *) a. Monad m => a -> m a
return ())

tracesM :: (HasCallStack, Monad m) => Text -> m ()
tracesM :: forall (m :: * -> *). (HasCallStack, Monad m) => Text -> m ()
tracesM Text
msg = forall a. HasCallStack => Text -> a -> a
write Text
msg (forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- * in IO
-- These are like putStrLn, but more easily greppable.

puts :: (HasCallStack, Trans.MonadIO m) => Text -> m ()
puts :: forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
puts = forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
writeIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HasCallStack => Text
prefix<>)

put :: (HasCallStack, Trans.MonadIO m, Show a) => Text -> a -> m ()
put :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Show a) =>
Text -> a -> m ()
put Text
msg = forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
writeIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text
with_msg Text
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> Text
pshow

putp :: (HasCallStack, Trans.MonadIO m, Pretty a) => Text -> a -> m ()
putp :: forall (m :: * -> *) a.
(HasCallStack, MonadIO m, Pretty a) =>
Text -> a -> m ()
putp Text
msg = forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
writeIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> Text
with_msg Text
msg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> Text
Pretty.formatted


-- * implementation

{-# NOINLINE write #-}
write :: HasCallStack => Text -> a -> a
write :: forall a. HasCallStack => Text -> a -> a
write Text
msg a
val = forall a. IO a -> a
Unsafe.unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
writeIO Text
msg forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return a
val

writeIO :: (HasCallStack, Trans.MonadIO m) => Text -> m ()
writeIO :: forall (m :: * -> *). (HasCallStack, MonadIO m) => Text -> m ()
writeIO Text
msg = forall (m :: * -> *) a. MonadIO m => IO a -> m a
Trans.liftIO forall a b. (a -> b) -> a -> b
$ do
    -- deepseq to prevent debug msgs from being interleaved.
    Maybe Text
ok <- forall a. Double -> IO a -> IO (Maybe a)
timeout Double
1 forall a b. (a -> b) -> a -> b
$ forall a. a -> IO a
Exception.evaluate (forall a b. NFData a => a -> b -> b
DeepSeq.deepseq Text
msg Text
msg)
    -- I could catch exceptions, but I don't want to catch async exceptions.
    -- `Exception.catch` \(exc :: Exception.SomeException) ->
    --     return $ prefix <> "<exception: " <> Text.pack (show exc) <> ">"
    IO () -> IO ()
Log.with_stdio_lock forall a b. (a -> b) -> a -> b
$ case Maybe Text
ok of
        Maybe Text
Nothing ->
            Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
IO.stdout forall a b. (a -> b) -> a -> b
$ HasCallStack => Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
"<evalutaion timed out>"
        Just Text
msg -> Handle -> Text -> IO ()
Text.IO.hPutStrLn Handle
IO.stdout Text
msg

timeout :: Double -> IO a -> IO (Maybe a)
timeout :: forall a. Double -> IO a -> IO (Maybe a)
timeout = forall a. Int -> IO a -> IO (Maybe a)
Timeout.timeout forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Int
to_usec
    where to_usec :: Double -> Int
to_usec = forall a b. (RealFrac a, Integral b) => a -> b
round forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Num a => a -> a -> a
*Double
1000000)

with_msg :: HasCallStack => Text -> Text -> Text
with_msg :: HasCallStack => Text -> Text -> Text
with_msg Text
msg Text
text_ =
    HasCallStack => Text
prefix forall a. Semigroup a => a -> a -> a
<> Text
msg forall a. Semigroup a => a -> a -> a
<> (if Bool
multiline then Text
":\n" else Text
": ") forall a. Semigroup a => a -> a -> a
<> Text
text
    where
    text :: Text
text = Text -> Text
Text.strip Text
text_
    multiline :: Bool
multiline = HasCallStack => Text -> Text -> Int
Text.count Text
"\n" Text
text forall a. Ord a => a -> a -> Bool
> Int
2

prefix :: HasCallStack => Text
prefix :: HasCallStack => Text
prefix = Text
"** " forall a. Semigroup a => a -> a -> a
<> HasCallStack => Text
CallStack.getStack1 forall a. Semigroup a => a -> a -> a
<> Text
": "

pshow :: Show a => a -> Text
pshow :: forall a. Show a => a -> Text
pshow = Text -> Text
Text.strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
PPrint.pshow