-- | 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
(>>=) = 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
(>>) = 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 = 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 = 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) = 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) = forall a. Show a => a -> Showable
f a
x

traceShow :: Show a => a -> Maybe Showable
traceShow :: forall a. Show a => a -> Maybe Showable
traceShow = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 b. (a -> b) -> a -> b
$ forall a. Show a => a -> Showable
Showable forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. a -> Either a b
Left  :: forall c. c -> Either c ())) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 b. (a -> b) -> a -> b
$ forall a. Show a => a -> Showable
Showable forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. b -> Either a b
Right :: forall c. c -> Either () c)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 (forall a. Traceable a => a -> Maybe Showable
trace a
x, forall a. Traceable a => a -> Maybe Showable
trace b
y) of
    (Maybe Showable
Nothing, Maybe Showable
Nothing) -> forall a. Maybe a
Nothing
    (Just Showable
t1, Maybe Showable
Nothing) -> forall a. Show a => a -> Maybe Showable
traceShow Showable
t1
    (Maybe Showable
Nothing, Just Showable
t2) -> forall a. Show a => a -> Maybe Showable
traceShow Showable
t2
    (Just Showable
t1, Just Showable
t2) -> 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 (forall a. Traceable a => a -> Maybe Showable
trace a
x, forall a. Traceable a => a -> Maybe Showable
trace b
y, forall a. Traceable a => a -> Maybe Showable
trace c
z) of
    (Maybe Showable
Nothing, Maybe Showable
Nothing, Maybe Showable
Nothing) -> forall a. Maybe a
Nothing
    (Just Showable
t1, Maybe Showable
Nothing, Maybe Showable
Nothing) -> forall a. Show a => a -> Maybe Showable
traceShow Showable
t1
    (Maybe Showable
Nothing, Just Showable
t2, Maybe Showable
Nothing) -> forall a. Show a => a -> Maybe Showable
traceShow Showable
t2
    (Just Showable
t1, Just Showable
t2, Maybe Showable
Nothing) -> forall a. Show a => a -> Maybe Showable
traceShow (Showable
t1, Showable
t2)
    (Maybe Showable
Nothing, Maybe Showable
Nothing, Just Showable
t3) -> forall a. Show a => a -> Maybe Showable
traceShow Showable
t3
    (Just Showable
t1, Maybe Showable
Nothing, Just Showable
t3) -> forall a. Show a => a -> Maybe Showable
traceShow (Showable
t1, Showable
t3)
    (Maybe Showable
Nothing, Just Showable
t2, Just Showable
t3) -> forall a. Show a => a -> Maybe Showable
traceShow (Showable
t2, Showable
t3)
    (Just Showable
t1, Just Showable
t2, Just Showable
t3) -> 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  = forall a. Show a => a -> Maybe Showable
traceShow (forall a. Maybe a
Nothing :: Maybe ())
  trace (Just a
x) = (forall a. Show a => a -> Showable) -> Showable -> Showable
mapShowable (forall a. Show a => a -> Showable
Showable forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Traceable a => a -> Maybe Showable
trace a
x

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

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

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

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

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

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

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

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

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

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

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

instance Traceable IOException where
  trace :: IOException -> Maybe Showable
trace = 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 = 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
Prelude.>>= \a
a -> forall a. IO a -> [Handler a] -> IO a
catches (a -> IO b
f a
a) (forall a b. Traceable a => a -> [Handler b]
traceHandlers a
a)
  failS :: forall a. String -> IO a
failS   = forall (m :: * -> *) a. MonadFail m => String -> m a
Prelude.fail
  seqS :: forall a b. IO a -> IO b -> IO b
seqS    = 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) =
    forall a. Show a => a -> String
show SomeException
ex forall a. [a] -> [a] -> [a]
++ String
"\nTrace:\n" forall a. [a] -> [a] -> [a]
++ [String] -> String
unlines (forall a b. (a -> b) -> [a] -> [b]
map (\(Int
i, String
t) -> forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
"\t" forall a. [a] -> [a] -> [a]
++ String
t) (forall a b. [a] -> [b] -> [(a, b)]
zip ([Int
0..] :: [Int]) (forall a. Int -> [a] -> [a]
take Int
10 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse 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 forall a. Traceable a => a -> Maybe Showable
trace a
a of
  Maybe Showable
Nothing -> [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \SomeException
ex -> forall e a. Exception e => e -> IO a
throwIO (SomeException
ex :: SomeException) ]
  Just Showable
t  -> [ forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \(TracedException [String]
ts SomeException
ex) -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [String] -> SomeException -> TracedException
TracedException (forall a. Show a => a -> String
show Showable
t forall a. a -> [a] -> [a]
: [String]
ts) SomeException
ex
             , forall a e. Exception e => (e -> IO a) -> Handler a
Handler forall a b. (a -> b) -> a -> b
$ \SomeException
ex -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ [String] -> SomeException -> TracedException
TracedException [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