@@ -1,4 +1,4 @@
1−{-# LANGUAGE RebindableSyntax, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, OverlappingInstances #-}
1+{-# LANGUAGE RebindableSyntax, ScopedTypeVariables, DeriveDataTypeable, FlexibleInstances, OverlappingInstances, ExistentialQuantification, RankNTypes #-}
22-- | Add tracing to the IO monad (see examples).
33--
44-- [Usage]
@@ -46,7 +46,9 @@ module Traced ( MonadS(..)
4646 , (>>)
4747 , fail
4848 , ifThenElse
49− , Trace(..)
49+ , Showable(..)
50+ , Traceable(..)
51+ , traceShow
5052 ) where
5153
5254import Prelude hiding ((>>=), return, fail, catch, (>>))
@@ -56,7 +58,6 @@ import Control.Exception (catches, Handler(..), SomeException, throw, Exception(
5658import Control.Applicative ((<$>))
5759import Data.Typeable (Typeable)
5860import Data.Maybe (catMaybes)
59−import Data.List (intersperse)
6061import Data.ByteString (ByteString)
6162import Data.Int (Int32)
6263import Control.Concurrent.MVar (MVar)
@@ -68,12 +69,12 @@ import Control.Concurrent.MVar (MVar)
6869-- | Like 'Monad' but bind is only defined for 'Trace'able instances
6970class MonadS m where
7071 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
7273 failS :: String -> m a
7374 seqS :: m a -> m b -> m b
7475
7576-- | 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
7778(>>=) = bindS
7879
7980-- | Redefinition of 'Prelude.>>'
@@ -92,59 +93,68 @@ fail = failS
9293-- Trace typeclass (for adding elements to a trace --
9394--------------------------------------------------------------------------------
9495
95−-- | Used to add a term to the trace
96−class Trace a where
97− -- | Return 'Nothing' not to add the term to the trace
98− trace :: a -> Maybe String
96+data Showable = forall a. Show a => Showable a
9997
100−instance (Trace a, Trace b) => Trace (Either a b) where
101− trace (Left x) = ("Left " ++) <$> trace x
102− trace (Right y) = ("Right " ++) <$> trace y
98+instance Show Showable where
99+ show (Showable x) = show x
103100
104−instance Trace a => Trace [a] where
105− trace as = Just $ "[" ++ (concat . intersperse "," . catMaybes . map trace $ as) ++ "]"
101+mapShowable :: (forall a. Show a => a -> Showable) -> Showable -> Showable
102+mapShowable f (Showable x) = f x
106103
107−instance (Trace a, Trace b) => Trace (a, b) where
104+traceShow :: Show a => a -> Maybe Showable
105+traceShow = Just . Showable
106+
107+class Traceable a where
108+ trace :: a -> Maybe Showable
109+
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
113+
114+instance (Traceable a, Traceable b) => Traceable (a, b) where
108115 trace (x, y) = case (trace x, trace y) of
109116 (Nothing, Nothing) -> Nothing
110− (Just t1, Nothing) -> Just t1
111− (Nothing, Just t2) -> Just t2
112− (Just t1, Just t2) -> Just $ "(" ++ t1 ++ ", " ++ t2 ++ ")"
117+ (Just t1, Nothing) -> traceShow t1
118+ (Nothing, Just t2) -> traceShow t2
119+ (Just t1, Just t2) -> traceShow (t1, t2)
113120
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
115122 trace (x, y, z) = case (trace x, trace y, trace z) of
116− (Nothing, Nothing, Nothing) -> Nothing
117− (Just t1, Nothing, Nothing) -> Just t1
118− (Nothing, Just t2, Nothing) -> Just t2
119− (Nothing, Nothing, Just t3) -> Just t3
120− (Just t1, Just t2, Nothing) -> Just $ "(" ++ t1 ++ "," ++ t2 ++ ")"
121− (Just t1, Nothing, Just t3) -> Just $ "(" ++ t1 ++ "," ++ t3 ++ ")"
122− (Nothing, Just t2, Just t3) -> Just $ "(" ++ t2 ++ "," ++ t3 ++ ")"
123− (Just t1, Just t2, Just t3) -> Just $ "(" ++ t1 ++ "," ++ t2 ++ "," ++ t2 ++ "," ++ t3 ++ ")"
124−
125−instance Trace () where
126− trace = const Nothing
123+ (Nothing, Nothing, Nothing) -> Nothing
124+ (Just t1, Nothing, Nothing) -> traceShow t1
125+ (Nothing, Just t2, Nothing) -> traceShow t2
126+ (Just t1, Just t2, Nothing) -> traceShow (t1, t2)
127+ (Nothing, Nothing, Just t3) -> traceShow t3
128+ (Just t1, Nothing, Just t3) -> traceShow (t1, t3)
129+ (Nothing, Just t2, Just t3) -> traceShow (t2, t3)
130+ (Just t1, Just t2, Just t3) -> traceShow (t1, t2, t3)
131+
132+instance Traceable a => Traceable [a] where
133+ trace = traceShow . catMaybes . map trace
134+
135+instance Traceable () where
136+ trace = const Nothing
127137
128−instance Trace Int where
129− trace = Just . show
138+instance Traceable Int where
139+ trace = traceShow
130140
131−instance Trace Int32 where
132− trace = Just . show
141+instance Traceable Int32 where
142+ trace = traceShow
133143
134−instance Trace Bool where
135− trace = const Nothing
144+instance Traceable Bool where
145+ trace = const Nothing
136146
137−instance Trace ByteString where
138− trace = Just . show
147+instance Traceable ByteString where
148+ trace = traceShow
139149
140−instance Trace (MVar a) where
150+instance Traceable (MVar a) where
141151 trace = const Nothing
142152
143−instance Trace [Char] where
144− trace = Just . show
153+instance Traceable [Char] where
154+ trace = traceShow
145155
146−instance Trace IOException where
147− trace = Just . show
156+instance Traceable IOException where
157+ trace = traceShow
148158
149159--------------------------------------------------------------------------------
150160-- IO instance for MonadS --
@@ -166,13 +176,13 @@ instance Show TracedException where
166176 show (TracedException ts ex) =
167177 show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (reverse ts)))
168178
169−traceHandlers :: Trace a => a -> [Handler b]
179+traceHandlers :: Traceable a => a -> [Handler b]
170180traceHandlers a = case trace a of
171181 Nothing -> [ Handler $ \(ex :: SomeException) -> throw ex ]
172− Just t -> [ Handler $ \(TracedException ts ex) -> throw $ TracedException (t : ts) ex
173− , Handler $ \(ex :: SomeException) -> throw $ TracedException [t] ex
182+ Just t -> [ Handler $ \(TracedException ts ex) -> throw $ TracedException (show t : ts) ex
183+ , Handler $ \(ex :: SomeException) -> throw $ TracedException [show t] ex
174184 ]
175−
185+
176186-- | Definition of 'ifThenElse' for use with RebindableSyntax
177187ifThenElse :: Bool -> a -> a -> a
178188ifThenElse True x _ = x