-- | Add tracing to the IO monad (see examples).
--
-- [Usage]
--
-- > {-# LANGUAGE RebindableSyntax #-}
-- > import Prelude hiding (catch, (>>=), (>>), return, fail)
-- > import Traced
--
-- [Example]
--
-- > test1 :: IO Int
-- > test1 = do
-- >   Left x  <- return (Left 1 :: Either Int Int)
-- >   putStrLn "Hello world"
-- >   Right y <- return (Left 2 :: Either Int Int)
-- >   return (x + y)
--
-- outputs
--
-- > Hello world
-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:187:3-9)
-- > Trace:
-- > 0  Left 2
-- > 1  Left 1
--
-- [Guards]
--
-- Use the following idiom instead of using 'Control.Monad.guard':
--
-- > test2 :: IO Int
-- > test2 = do
-- >   Left x <- return (Left 1 :: Either Int Int)
-- >   True   <- return (x == 3)
-- >   return x
--
-- The advantage of this idiom is that it gives you line number information when the guard fails:
--
-- > *Traced> test2
-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:193:3-6)
-- > Trace:
-- > 0  Left 1
module Network.Transport.Tests.Traced
  ( MonadS(..)
  , return
  , (>>=)
  , (>>)
  , fail
  , ifThenElse
  , Showable(..)
  , Traceable(..)
  , traceShow
  ) where

import Prelude hiding
  ( (>>=)
  , return
  , fail
  , (>>)
#if ! MIN_VERSION_base(4,6,0)
  , catch
#endif
  )
import qualified Prelude
import Control.Exception (catches, Handler(..), SomeException, throwIO, Exception(..), IOException)
import Control.Applicative ((<$>))
import Data.Typeable (Typeable)
import Data.Maybe (catMaybes)
import Data.ByteString (ByteString)
import Data.Int (Int32, Int64)
import Data.Word (Word32, Word64)
import Control.Concurrent.MVar (MVar)

--------------------------------------------------------------------------------
-- MonadS class                                                               --
--------------------------------------------------------------------------------

-- | Like 'Monad' but bind is only defined for 'Trace'able instances
class MonadS m where
  returnS :: a -> m a
  bindS   :: Traceable a => m a -> (a -> m b) -> m b
  failS   :: String -> m a
  seqS    :: m a -> m b -> m b

-- | Redefinition of 'Prelude.>>='
(>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b
>>= :: forall (m :: * -> *) a b.
(MonadS m, Traceable a) =>
m a -> (a -> m b) -> m b
(>>=) = m a -> (a -> m b) -> m b
forall a b. Traceable a => m a -> (a -> m b) -> m b
forall (m :: * -> *) a b.
(MonadS m, Traceable a) =>
m a -> (a -> m b) -> m b
bindS

-- | Redefinition of 'Prelude.>>'
(>>) :: MonadS m => m a -> m b -> m b
>> :: forall (m :: * -> *) a b. MonadS m => m a -> m b -> m b
(>>) = m a -> m b -> m b
forall a b. m a -> m b -> m b
forall (m :: * -> *) a b. MonadS m => m a -> m b -> m b
seqS

-- | Redefinition of 'Prelude.return'
return :: MonadS m => a -> m a
return :: forall (m :: * -> *) a. MonadS m => a -> m a
return = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. MonadS m => a -> m a
returnS

-- | Redefinition of 'Prelude.fail'
fail :: MonadS m => String -> m a
fail :: forall (m :: * -> *) a. MonadS m => String -> m a
fail = String -> m a
forall a. String -> m a
forall (m :: * -> *) a. MonadS m => String -> m a
failS

--------------------------------------------------------------------------------
-- Trace typeclass (for adding elements to a trace                            --
--------------------------------------------------------------------------------

data Showable = forall a. Show a => Showable a

instance Show Showable where
  show :: Showable -> String
show (Showable a
x) = a -> String
forall a. Show a => a -> String
show a
x

mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
mapShowable forall a. Show a => a -> Showable
f (Showable a
x) = a -> Showable
forall a. Show a => a -> Showable
f a
x

traceShow :: Show a => a -> Maybe Showable
traceShow :: forall a. Show a => a -> Maybe Showable
traceShow = Showable -> Maybe Showable
forall a. a -> Maybe a
Just (Showable -> Maybe Showable)
-> (a -> Showable) -> a -> Maybe Showable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Showable
forall a. Show a => a -> Showable
Showable

class Traceable a where
  trace :: a -> Maybe Showable

instance (Traceable a, Traceable b) => Traceable (Either a b) where
  trace :: Either a b -> Maybe Showable
trace (Left a
x)  = ((forall a. Show a => a -> Showable) -> Showable -> Showable
mapShowable ((forall a. Show a => a -> Showable) -> Showable -> Showable)
-> (forall a. Show a => a -> Showable) -> Showable -> Showable
forall a b. (a -> b) -> a -> b
$ Either a () -> Showable
forall a. Show a => a -> Showable
Showable (Either a () -> Showable) -> (a -> Either a ()) -> a -> Showable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> Either c ()
forall {c}. c -> Either c ()
forall a b. a -> Either a b
Left  :: forall c. c -> Either c ())) (Showable -> Showable) -> Maybe Showable -> Maybe Showable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace a
x
  trace (Right b
y) = ((forall a. Show a => a -> Showable) -> Showable -> Showable
mapShowable ((forall a. Show a => a -> Showable) -> Showable -> Showable)
-> (forall a. Show a => a -> Showable) -> Showable -> Showable
forall a b. (a -> b) -> a -> b
$ Either () a -> Showable
forall a. Show a => a -> Showable
Showable (Either () a -> Showable) -> (a -> Either () a) -> a -> Showable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (c -> Either () c
forall {c}. c -> Either () c
forall a b. b -> Either a b
Right :: forall c. c -> Either () c)) (Showable -> Showable) -> Maybe Showable -> Maybe Showable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> b -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace b
y

instance (Traceable a, Traceable b) => Traceable (a, b) where
  trace :: (a, b) -> Maybe Showable
trace (a
x, b
y) = case (a -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace a
x, b -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace b
y) of
    (Maybe Showable
Nothing, Maybe Showable
Nothing) -> Maybe Showable
forall a. Maybe a
Nothing
    (Just Showable
t1, Maybe Showable
Nothing) -> Showable -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow Showable
t1
    (Maybe Showable
Nothing, Just Showable
t2) -> Showable -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow Showable
t2
    (Just Showable
t1, Just Showable
t2) -> (Showable, Showable) -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow (Showable
t1, Showable
t2)

instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where
  trace :: (a, b, c) -> Maybe Showable
trace (a
x, b
y, c
z) = case (a -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace a
x, b -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace b
y, c -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace c
z) of
    (Maybe Showable
Nothing, Maybe Showable
Nothing, Maybe Showable
Nothing) -> Maybe Showable
forall a. Maybe a
Nothing
    (Just Showable
t1, Maybe Showable
Nothing, Maybe Showable
Nothing) -> Showable -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow Showable
t1
    (Maybe Showable
Nothing, Just Showable
t2, Maybe Showable
Nothing) -> Showable -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow Showable
t2
    (Just Showable
t1, Just Showable
t2, Maybe Showable
Nothing) -> (Showable, Showable) -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow (Showable
t1, Showable
t2)
    (Maybe Showable
Nothing, Maybe Showable
Nothing, Just Showable
t3) -> Showable -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow Showable
t3
    (Just Showable
t1, Maybe Showable
Nothing, Just Showable
t3) -> (Showable, Showable) -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow (Showable
t1, Showable
t3)
    (Maybe Showable
Nothing, Just Showable
t2, Just Showable
t3) -> (Showable, Showable) -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow (Showable
t2, Showable
t3)
    (Just Showable
t1, Just Showable
t2, Just Showable
t3) -> (Showable, Showable, Showable) -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow (Showable
t1, Showable
t2, Showable
t3)

instance Traceable a => Traceable (Maybe a) where
  trace :: Maybe a -> Maybe Showable
trace Maybe a
Nothing  = Maybe () -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow (Maybe ()
forall a. Maybe a
Nothing :: Maybe ())
  trace (Just a
x) = (forall a. Show a => a -> Showable) -> Showable -> Showable
mapShowable (Maybe a -> Showable
forall a. Show a => a -> Showable
Showable (Maybe a -> Showable) -> (a -> Maybe a) -> a -> Showable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) (Showable -> Showable) -> Maybe Showable -> Maybe Showable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace a
x

instance Traceable a => Traceable [a] where
  trace :: [a] -> Maybe Showable
trace = [Showable] -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow ([Showable] -> Maybe Showable)
-> ([a] -> [Showable]) -> [a] -> Maybe Showable
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe Showable] -> [Showable]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Showable] -> [Showable])
-> ([a] -> [Maybe Showable]) -> [a] -> [Showable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> Maybe Showable) -> [a] -> [Maybe Showable]
forall a b. (a -> b) -> [a] -> [b]
map a -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace

instance Traceable () where
  trace :: () -> Maybe Showable
trace = Maybe Showable -> () -> Maybe Showable
forall a b. a -> b -> a
const Maybe Showable
forall a. Maybe a
Nothing

instance Traceable Int where
  trace :: Int -> Maybe Showable
trace = Int -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow

instance Traceable Int32 where
  trace :: Int32 -> Maybe Showable
trace = Int32 -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow

instance Traceable Int64 where
  trace :: Int64 -> Maybe Showable
trace = Int64 -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow

instance Traceable Word32 where
  trace :: Word32 -> Maybe Showable
trace = Word32 -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow

instance Traceable Word64 where
  trace :: Word64 -> Maybe Showable
trace = Word64 -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow

instance Traceable Bool where
  trace :: Bool -> Maybe Showable
trace = Maybe Showable -> Bool -> Maybe Showable
forall a b. a -> b -> a
const Maybe Showable
forall a. Maybe a
Nothing

instance Traceable ByteString where
  trace :: ByteString -> Maybe Showable
trace = ByteString -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow

instance Traceable (MVar a) where
  trace :: MVar a -> Maybe Showable
trace = Maybe Showable -> MVar a -> Maybe Showable
forall a b. a -> b -> a
const Maybe Showable
forall a. Maybe a
Nothing

instance Traceable [Char] where
  trace :: String -> Maybe Showable
trace = String -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow

instance Traceable IOException where
  trace :: IOException -> Maybe Showable
trace = IOException -> Maybe Showable
forall a. Show a => a -> Maybe Showable
traceShow

--------------------------------------------------------------------------------
-- IO instance for MonadS                                                     --
--------------------------------------------------------------------------------

data TracedException = TracedException [String] SomeException
  deriving Typeable

instance Exception TracedException

-- | Add tracing to 'IO' (see examples)
instance MonadS IO where
  returnS :: forall a. a -> IO a
returnS = a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
Prelude.return
  bindS :: forall a b. Traceable a => IO a -> (a -> IO b) -> IO b
bindS   = \IO a
x a -> IO b
f -> IO a
x IO a -> (a -> IO b) -> IO b
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
Prelude.>>= \a
a -> IO b -> [Handler b] -> IO b
forall a. IO a -> [Handler a] -> IO a
catches (a -> IO b
f a
a) (a -> [Handler b]
forall a b. Traceable a => a -> [Handler b]
traceHandlers a
a)
  failS :: forall a. String -> IO a
failS   = String -> IO a
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail
  seqS :: forall a b. IO a -> IO b -> IO b
seqS    = IO a -> IO b -> IO b
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
(Prelude.>>)

instance Show TracedException where
  show :: TracedException -> String
show (TracedException [String]
ts SomeException
ex) =
    SomeException -> String
forall a. Show a => a -> String
show SomeException
ex String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\nTrace:\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (((Int, String) -> String) -> [(Int, String)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
t) -> Int -> String
forall a. Show a => a -> String
show Int
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"\t" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
t) ([Int] -> [String] -> [(Int, String)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
10 ([String] -> [String])
-> ([String] -> [String]) -> [String] -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
ts)))

traceHandlers :: Traceable a => a -> [Handler b]
traceHandlers :: forall a b. Traceable a => a -> [Handler b]
traceHandlers a
a =  case a -> Maybe Showable
forall a. Traceable a => a -> Maybe Showable
trace a
a of
  Maybe Showable
Nothing -> [ (SomeException -> IO b) -> Handler b
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO b) -> Handler b)
-> (SomeException -> IO b) -> Handler b
forall a b. (a -> b) -> a -> b
$ \SomeException
ex -> SomeException -> IO b
forall e a. Exception e => e -> IO a
throwIO (SomeException
ex :: SomeException) ]
  Just Showable
t  -> [ (TracedException -> IO b) -> Handler b
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((TracedException -> IO b) -> Handler b)
-> (TracedException -> IO b) -> Handler b
forall a b. (a -> b) -> a -> b
$ \(TracedException [String]
ts SomeException
ex) -> TracedException -> IO b
forall e a. Exception e => e -> IO a
throwIO (TracedException -> IO b) -> TracedException -> IO b
forall a b. (a -> b) -> a -> b
$ [String] -> SomeException -> TracedException
TracedException (Showable -> String
forall a. Show a => a -> String
show Showable
t String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
ts) SomeException
ex
             , (SomeException -> IO b) -> Handler b
forall a e. Exception e => (e -> IO a) -> Handler a
Handler ((SomeException -> IO b) -> Handler b)
-> (SomeException -> IO b) -> Handler b
forall a b. (a -> b) -> a -> b
$ \SomeException
ex -> TracedException -> IO b
forall e a. Exception e => e -> IO a
throwIO (TracedException -> IO b) -> TracedException -> IO b
forall a b. (a -> b) -> a -> b
$ [String] -> SomeException -> TracedException
TracedException [Showable -> String
forall a. Show a => a -> String
show Showable
t] (SomeException
ex :: SomeException)
             ]

-- | Definition of 'ifThenElse' for use with RebindableSyntax
ifThenElse :: Bool -> a -> a -> a
ifThenElse :: forall a. Bool -> a -> a -> a
ifThenElse Bool
True  a
x a
_ = a
x
ifThenElse Bool
False a
_ a
y = a
y