@@ -1,4 +1,4 @@
1−{-# LANGUAGE RebindableSyntax, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, OverlappingInstances #-}
1+{-# LANGUAGE RebindableSyntax, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, OverlappingInstances, ExistentialQuantification, RankNTypes #-}
2-- | Add tracing to the IO monad (see examples).
2-- | Add tracing to the IO monad (see examples).
@@ -46,7 +46,9 @@ module Traced ( MonadS(..)
48 , ifThenElse
48 , ifThenElse
49− , Trace(..)
49+ , Showable(..)
52import Prelude hiding ((>>=), return, fail, catch, (>>))
54import Prelude hiding ((>>=), return, fail, catch, (>>))
@@ -56,7 +58,6 @@ import Control.Exception (catches, Handler(..), SomeException, throw, Exception(
56import Control.Applicative ((<$>))
58import Control.Applicative ((<$>))
57import Data.Typeable (Typeable)
59import Data.Typeable (Typeable)
58import Data.Maybe (catMaybes)
60import Data.Maybe (catMaybes)
59−import Data.List (intersperse)
60import Data.ByteString (ByteString)
61import Data.ByteString (ByteString)
61import Data.Int (Int32)
62import Data.Int (Int32)
62import Control.Concurrent.MVar (MVar)
63import Control.Concurrent.MVar (MVar)
@@ -68,12 +69,12 @@ import Control.Concurrent.MVar (MVar)
68-- | Like 'Monad' but bind is only defined for 'Trace'able instances
69-- | Like 'Monad' but bind is only defined for 'Trace'able instances
69class MonadS m where
70class MonadS m where
70 returnS :: a -> m a
71 returnS :: a -> m a
71− bindS :: Trace a => m a -> (a -> m b) -> m b
72+ bindS :: Traceable a => m a -> (a -> m b) -> m b
72 failS :: String -> m a
73 failS :: String -> m a
73 seqS :: m a -> m b -> m b
74 seqS :: m a -> m b -> m b
75-- | Redefinition of 'Prelude.>>='
76-- | Redefinition of 'Prelude.>>='
76−(>>=) :: (MonadS m, Trace a) => m a -> (a -> m b) -> m b
77+(>>=) :: (MonadS m, Traceable a) => m a -> (a -> m b) -> m b
77(>>=) = bindS
78(>>=) = bindS
79-- | Redefinition of 'Prelude.>>'
80-- | Redefinition of 'Prelude.>>'
@@ -92,59 +93,68 @@ fail = failS
92-- Trace typeclass (for adding elements to a trace --
93-- Trace typeclass (for adding elements to a trace --
93--------------------------------------------------------------------------------
94--------------------------------------------------------------------------------
95−-- | Used to add a term to the trace
96+data Showable = forall a. Show a => Showable a
97− -- | Return 'Nothing' not to add the term to the trace
98− trace :: a -> Maybe String
100−instance (Trace a, Trace b) => Trace (Either a b) where
98+instance Show Showable where
101− trace (Left x) = ("Left " ++) <$> trace x
99+ show (Showable x) = show x
102− trace (Right y) = ("Right " ++) <$> trace y
104−instance Trace a => Trace [a] where
101+mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
105− trace as = Just $ "[" ++ (concat . intersperse "," . catMaybes . map trace $ as) ++ "]"
102+mapShowable f (Showable x) = f x
104+traceShow :: Show a => a -> Maybe Showable
105+traceShow = Just . Showable
107+class Traceable a where
108+ trace :: a -> Maybe Showable
110+instance (Traceable a, Traceable b) => Traceable (Either a b) where
111+ trace (Left x) = (mapShowable $ Showable . (Left :: forall c. c -> Either c ())) <$> trace x
112+ trace (Right y) = (mapShowable $ Showable . (Right :: forall c. c -> Either () c)) <$> trace y
107−instance (Trace a, Trace b) => Trace (a, b) where
114+instance (Traceable a, Traceable b) => Traceable (a, b) where
108 trace (x, y) = case (trace x, trace y) of
115 trace (x, y) = case (trace x, trace y) of
109 (Nothing, Nothing) -> Nothing
116 (Nothing, Nothing) -> Nothing
110− (Just t1, Nothing) -> Just t1
117+ (Just t1, Nothing) -> traceShow t1
111− (Nothing, Just t2) -> Just t2
118+ (Nothing, Just t2) -> traceShow t2
112− (Just t1, Just t2) -> Just $ "(" ++ t1 ++ ", " ++ t2 ++ ")"
119+ (Just t1, Just t2) -> traceShow (t1, t2)
114−instance (Trace a, Trace b, Trace c) => Trace (a, b, c) where
121+instance (Traceable a, Traceable b, Traceable c) => Traceable (a, b, c) where
115 trace (x, y, z) = case (trace x, trace y, trace z) of
122 trace (x, y, z) = case (trace x, trace y, trace z) of
116− (Nothing, Nothing, Nothing) -> Nothing
123+ (Nothing, Nothing, Nothing) -> Nothing
117− (Just t1, Nothing, Nothing) -> Just t1
124+ (Just t1, Nothing, Nothing) -> traceShow t1
118− (Nothing, Just t2, Nothing) -> Just t2
125+ (Nothing, Just t2, Nothing) -> traceShow t2
119− (Nothing, Nothing, Just t3) -> Just t3
120− (Just t1, Just t2, Nothing) -> Just $ "(" ++ t1 ++ "," ++ t2 ++ ")"
126+ (Just t1, Just t2, Nothing) -> traceShow (t1, t2)
127+ (Nothing, Nothing, Just t3) -> traceShow t3
121− (Just t1, Nothing, Just t3) -> Just $ "(" ++ t1 ++ "," ++ t3 ++ ")"
128+ (Just t1, Nothing, Just t3) -> traceShow (t1, t3)
122− (Nothing, Just t2, Just t3) -> Just $ "(" ++ t2 ++ "," ++ t3 ++ ")"
129+ (Nothing, Just t2, Just t3) -> traceShow (t2, t3)
123− (Just t1, Just t2, Just t3) -> Just $ "(" ++ t1 ++ "," ++ t2 ++ "," ++ t2 ++ "," ++ t3 ++ ")"
130+ (Just t1, Just t2, Just t3) -> traceShow (t1, t2, t3)
132+instance Traceable a => Traceable [a] where
133+ trace = traceShow . catMaybes . map trace
125−instance Trace () where
135+instance Traceable () where
126− trace = const Nothing
136+ trace = const Nothing
128−instance Trace Int where
138+instance Traceable Int where
129− trace = Just . show
139+ trace = traceShow
131−instance Trace Int32 where
141+instance Traceable Int32 where
132− trace = Just . show
142+ trace = traceShow
134−instance Trace Bool where
144+instance Traceable Bool where
135− trace = const Nothing
145+ trace = const Nothing
137−instance Trace ByteString where
147+instance Traceable ByteString where
138− trace = Just . show
148+ trace = traceShow
140−instance Trace (MVar a) where
150+instance Traceable (MVar a) where
141 trace = const Nothing
151 trace = const Nothing
143−instance Trace [Char] where
153+instance Traceable [Char] where
144− trace = Just . show
154+ trace = traceShow
146−instance Trace IOException where
156+instance Traceable IOException where
147− trace = Just . show
157+ trace = traceShow
149--------------------------------------------------------------------------------
159--------------------------------------------------------------------------------
150-- IO instance for MonadS --
160-- IO instance for MonadS --
@@ -166,13 +176,13 @@ instance Show TracedException where
166 show (TracedException ts ex) =
176 show (TracedException ts ex) =
167 show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (reverse ts)))
177 show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (reverse ts)))
169−traceHandlers :: Trace a => a -> [Handler b]
179+traceHandlers :: Traceable a => a -> [Handler b]
170traceHandlers a = case trace a of
180traceHandlers a = case trace a of
171 Nothing -> [ Handler $ \(ex :: SomeException) -> throw ex ]
181 Nothing -> [ Handler $ \(ex :: SomeException) -> throw ex ]
172− Just t -> [ Handler $ \(TracedException ts ex) -> throw $ TracedException (t : ts) ex
182+ Just t -> [ Handler $ \(TracedException ts ex) -> throw $ TracedException (show t : ts) ex
173− , Handler $ \(ex :: SomeException) -> throw $ TracedException [t] ex
183+ , Handler $ \(ex :: SomeException) -> throw $ TracedException [show t] ex
176-- | Definition of 'ifThenElse' for use with RebindableSyntax
186-- | Definition of 'ifThenElse' for use with RebindableSyntax
177ifThenElse :: Bool -> a -> a -> a
187ifThenElse :: Bool -> a -> a -> a
178ifThenElse True x _ = x
188ifThenElse True x _ = x