{-# LANGUAGE CPP #-}
-- | 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
, (>>)
)
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
(>>=) = bindS
-- | Redefinition of 'Prelude.>>'
(>>) :: MonadS m => m a -> m b -> m b
(>>) = seqS
-- | Redefinition of 'Prelude.return'
return :: MonadS m => a -> m a
return = returnS
-- | Redefinition of 'Prelude.fail'
fail :: MonadS m => String -> m a
fail = failS
--------------------------------------------------------------------------------
-- Trace typeclass (for adding elements to a trace --
--------------------------------------------------------------------------------
data Showable = forall a. Show a => Showable a
instance Show Showable where
show (Showable x) = show x
mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
mapShowable f (Showable x) = f x
traceShow :: Show a => a -> Maybe Showable
traceShow = Just . Showable
class Traceable a where
trace :: a -> Maybe Showable
instance (Traceable a, Traceable b) => Traceable (Either a b) where
trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x
trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y
instance (Traceable a, Traceable b) => Traceable (a, b) where
trace (x, y) = case (trace x, trace y) of
(Nothing, Nothing) -> Nothing
(Just t1, Nothing) -> traceShow t1
(Nothing, Just t2) -> traceShow t2
(Just t1, Just t2) -> traceShow (t1, t2)
instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where
trace (x, y, z) = case (trace x, trace y, trace z) of
(Nothing, Nothing, Nothing) -> Nothing
(Just t1, Nothing, Nothing) -> traceShow t1
(Nothing, Just t2, Nothing) -> traceShow t2
(Just t1, Just t2, Nothing) -> traceShow (t1, t2)
(Nothing, Nothing, Just t3) -> traceShow t3
(Just t1, Nothing, Just t3) -> traceShow (t1, t3)
(Nothing, Just t2, Just t3) -> traceShow (t2, t3)
(Just t1, Just t2, Just t3) -> traceShow (t1, t2, t3)
instance Traceable a => Traceable (Maybe a) where
trace Nothing = traceShow (Nothing :: Maybe ())
trace (Just x) = mapShowable (Showable . Just) <$> trace x
instance Traceable a => Traceable [a] where
trace = traceShow . catMaybes . map trace
instance Traceable () where
trace = const Nothing
instance Traceable Int where
trace = traceShow
instance Traceable Int32 where
trace = traceShow
instance Traceable Int64 where
trace = traceShow
instance Traceable Word32 where
trace = traceShow
instance Traceable Word64 where
trace = traceShow
instance Traceable Bool where
trace = const Nothing
instance Traceable ByteString where
trace = traceShow
instance Traceable (MVar a) where
trace = const Nothing
instance Traceable [Char] where
trace = traceShow
instance Traceable IOException where
trace = 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 = Prelude.return
bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a)
failS = Prelude.fail
seqS = (Prelude.>>)
instance Show TracedException where
show (TracedException ts ex) =
show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (take 10 . reverse $ ts)))
traceHandlers :: Traceable a => a -> [Handler b]
traceHandlers a = case trace a of
Nothing -> [ Handler $ \ex -> throwIO (ex :: SomeException) ]
Just t -> [ Handler $ \(TracedException ts ex) -> throwIO $ TracedException (show t : ts) ex
, Handler $ \ex -> throwIO $ TracedException [show t] (ex :: SomeException)
]
-- | Definition of 'ifThenElse' for use with RebindableSyntax
ifThenElse :: Bool -> a -> a -> a
ifThenElse True x _ = x
ifThenElse False _ y = y