@@ -1,161 +1,108 @@
1−{-# LANGUAGE RebindableSyntax #-}
2−-- | Monad to trace all terms that get bound
1+{-# LANGUAGE RebindableSyntax, FlexibleInstances, UndecidableInstances, ScopedTypeVariables, DeriveDataTypeable #-}
2+-- | Add "tracing" to the IO monad (see examples).
33--
4−-- Examples:
5−--
6−-- > test1 :: IO Int
7−-- > test1 = runTraced $ do
8−-- > Left x <- return (Left 1 :: Either Int Int)
9−-- > Left y <- return (Left 2 :: Either Int Int)
10−-- > return (x + y)
11−--
12−-- outputs
13−--
14−-- > 3
4+-- [Usage]
5+--
6+-- > {-# LANGUAGE RebindableSyntax #-}
7+-- > import Prelude hiding (catch, (>>=), (>>), return, fail)
8+-- > import Traced
159--
16−-- as expected. Things get more interesting when we have a pattern match failure:
10+-- [Example]
1711--
18−-- > test2 :: IO Int
19−-- > test2 = runTraced $ do
12+-- > test1 :: IO Int
13+-- > test1 = do
2014-- > Left x <- return (Left 1 :: Either Int Int)
15+-- > putStrLn "Hello world"
2116-- > Right y <- return (Left 2 :: Either Int Int)
2217-- > return (x + y)
2318--
24−-- outputs
25−--
26−-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:96:3-9
27−-- > Trace:
28−-- > Left 1
29−-- > Left 2
30−-- > )
31−--
32−-- The module also exports a 'guard' function which is used in similar fashion
33−-- to the 'guard' from "Control.Monad":
34−--
35−-- > test3 :: IO Int
36−-- > test3 = runTraced $ do
37−-- > Left x <- return (Left 1 :: Either Int Int)
38−-- > Left y <- return (Left 2 :: Either Int Int)
39−-- > guard (x == 3)
40−-- > return (x + y)
41−--
42−-- outputs
19+-- outputs
4320--
44−-- > *** Exception: user error (Guard failed
21+-- > Hello world
22+-- > *** Exception: user error (Pattern match failure in do expression at tests/Traced.hs:107:3-9)
4523-- > Trace:
46−-- > Left 1
47−-- > Left 2
48−-- > )
49−--
50−-- Note that we get no line-number info this way; we can fix this by saying
51−--
52−-- > test4 :: IO Int
53−-- > test4 = runTraced $ do
54−-- > Left x <- return (Left 1 :: Either Int Int)
55−-- > Left y <- return (Left 2 :: Either Int Int)
56−-- > True <- return (x == 3)
57−-- > return (x + y)
58−--
59−-- which outputs
24+-- > 0 Left 2
25+-- > 1 Left 1
6026--
61−-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:110:3-6
62−-- > Trace:
63−-- > Left 1
64−-- > Left 2
65−-- > False
66−-- > )
27+-- [Guards]
6728--
68−-- The module also exports a 'liftIO', and does not trace ignored unit values (from '>>'):
29+-- Use the following idiom instead of using 'Control.Monad.guard':
6930--
70−-- > test5 :: IO Int
71−-- > test5 = runTraced $ do
31+-- > test2 :: IO Int
32+-- > test2 = do
7233-- > Left x <- return (Left 1 :: Either Int Int)
73−-- > liftIO $ putStrLn "hi"
74−-- > Left y <- return (Left 2 :: Either Int Int)
75−-- > True <- return (y == 1)
76−-- > return (x + y)
77−--
78−-- outputs
34+-- > True <- return (x == 3)
35+-- > return x
7936--
80−-- > hi
81−-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:137:3-6
82−-- > Trace:
83−-- > Left 1
84−-- > Left 2
85−-- > False
86−-- > )
37+-- The advantage of this idiom is that it gives you line number information when the guard fails:
8738--
88−-- Every Monad is also a MonadS, but not vice versa.
89−
90−module Traced ( -- Subclass of monads where bind is defined only for showable arguments
91− MonadS(..)
92− , return
93− , (>>=)
94− , (>>)
95− , fail
96− , guard
97− -- MonadS instance that shows a trace of all bound terms when an error occurs
98− , Traced
99− , runTraced
100− , liftIO
101− ) where
39+-- > *Traced> test3
40+-- > *** Exception: user error (Pattern match failure in do expression at tests/Traced.hs:103:3-6)
41+-- > Trace:
42+-- > 0 False
43+-- > 1 Left 1
44+module Traced ( MonadS(..)
45+ , return
46+ , (>>=)
47+ , (>>)
48+ , fail
49+ ) where
10250
10351import Prelude hiding ((>>=), return, fail, catch, (>>))
10452import qualified Prelude
10553import Data.String (fromString)
54+import Control.Exception (catches, Handler(..), SomeException, throw, Exception(..))
55+import Data.Typeable (Typeable)
10656
57+--------------------------------------------------------------------------------
58+-- MonadS class --
59+--------------------------------------------------------------------------------
60+
61+-- | Like 'Monad' but bind is only defined for 'Showable' instances
10762class MonadS m where
10863 returnS :: a -> m a
10964 bindS :: Show a => m a -> (a -> m b) -> m b
11065 failS :: String -> m a
11166 seqS :: m a -> m b -> m b
11267
113−instance MonadS IO where
114− returnS = Prelude.return
115− bindS = (Prelude.>>=)
116− failS = Prelude.fail
117− seqS = (Prelude.>>)
118−
119−newtype Traced a = Traced { unTraced :: IO ([String], Either String a) }
120−
121−instance MonadS Traced where
122− returnS x = Traced $ Prelude.return ([], Right x)
123− x `bindS` f = Traced $ unTraced x Prelude.>>= \(trace, result) ->
124− case result of
125− Left err -> Prelude.return (trace, Left err)
126− Right a -> unTraced (f a) Prelude.>>= \(trace', result') ->
127− Prelude.return (trace ++ show a : trace', result')
128− x `seqS` y = Traced $ unTraced x Prelude.>>= \(trace, result) ->
129− case result of
130− Left err -> Prelude.return (trace, Left err)
131− Right _ -> unTraced y Prelude.>>= \(trace', result') ->
132− Prelude.return (trace ++ trace', result')
133− failS err = Traced $ Prelude.return ([], Left err)
134−
135−runTraced :: Traced a -> IO a
136−runTraced (Traced x) = x Prelude.>>= \(trace, ma) ->
137− case ma of
138− Left err -> Prelude.fail $ err ++ "\nTrace:\n" ++ showTrace trace
139− Right a -> Prelude.return a
140−
141−showTrace :: [String] -> String
142−showTrace = unlines . map (\xs -> ' ' : ' ' : xs)
143−
144−guard :: MonadS m => Bool -> m ()
145−guard True = returnS ()
146−guard False = failS "Guard failed"
147−
68+-- | Redefinition of 'Prelude.>>='
14869(>>=) :: (MonadS m, Show a) => m a -> (a -> m b) -> m b
14970(>>=) = bindS
15071
72+-- | Redefinition of 'Prelude.>>'
15173(>>) :: (MonadS m, Show a) => m a -> m b -> m b
15274(>>) = seqS
15375
76+-- | Redefinition of 'Prelude.return'
15477return :: MonadS m => a -> m a
15578return = returnS
15679
80+-- | Redefinition of 'Prelude.fail'
15781fail :: MonadS m => String -> m a
15882fail = failS
15983
160−liftIO :: IO a -> Traced a
161−liftIO x = Traced $ x Prelude.>>= \a -> Prelude.return ([], Right a)
84+--------------------------------------------------------------------------------
85+-- IO instance for MonadS --
86+--------------------------------------------------------------------------------
87+
88+data TracedException = TracedException [String] SomeException
89+ deriving Typeable
90+
91+instance Exception TracedException
92+
93+-- | Add tracing to 'IO' (see examples)
94+instance MonadS IO where
95+ returnS = Prelude.return
96+ bindS = \x f -> x Prelude.>>= \a -> catches (f a) (traceHandlers a)
97+ failS = Prelude.fail
98+ seqS = (Prelude.>>)
99+
100+instance Show TracedException where
101+ show (TracedException trace ex) =
102+ show ex ++ "\nTrace:\n" ++ unlines (map (\(i, t) -> show i ++ "\t" ++ t) (zip ([0..] :: [Int]) (reverse trace)))
103+
104+traceHandlers :: Show a => a -> [Handler b]
105+traceHandlers a =
106+ [ Handler $ \(TracedException trace ex) -> throw $ TracedException (show a : trace) ex
107+ , Handler $ \(ex :: SomeException) -> throw $ TracedException [show a] ex
108+ ]