@@ -1,161 +1,108 @@
1−{-# LANGUAGE RebindableSyntax #-}
1+{-# LANGUAGE RebindableSyntax, FlexibleInstances, UndecidableInstances, ScopedTypeVariables, DeriveDataTypeable #-}
2−-- | Monad to trace all terms that get bound
2+-- | Add "tracing" to the IO monad (see examples).
4−-- Examples:
4+-- [Usage]
6−-- > test1 :: IO Int
6+-- > {-# LANGUAGE RebindableSyntax #-}
7−-- > test1 = runTraced $ do
7+-- > import Prelude hiding (catch, (>>=), (>>), return, fail)
8−-- > Left x <- return (Left 1 :: Either Int Int)
8+-- > import Traced
9−-- > Left y <- return (Left 2 :: Either Int Int)
16−-- as expected. Things get more interesting when we have a pattern match failure:
10+-- [Example]
18−-- > test2 :: IO Int
12+-- > test1 :: IO Int
19−-- > test2 = runTraced $ do
13+-- > test1 = do
20-- > Left x <- return (Left 1 :: Either Int Int)
14-- > Left x <- return (Left 1 :: Either Int Int)
15+-- > putStrLn "Hello world"
21-- > Right y <- return (Left 2 :: Either Int Int)
16-- > Right y <- return (Left 2 :: Either Int Int)
22-- > return (x + y)
17-- > return (x + y)
24−-- outputs
19+-- outputs
26−-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:96:3-9
32−-- The module also exports a 'guard' function which is used in similar fashion
33−-- to the 'guard' from "Control.Monad":
36−-- > test3 = runTraced $ do
37−-- > Left x <- return (Left 1 :: Either Int Int)
38−-- > Left y <- return (Left 2 :: Either Int Int)
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)
45-- > Trace:
23-- > Trace:
47−-- > Left 2
24+-- > 0 Left 2
48−-- > )
25+-- > 1 Left 1
50−-- Note that we get no line-number info this way; we can fix this by saying
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)
61−-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:110:3-6
27+-- [Guards]
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':
70−-- > test5 :: IO Int
31+-- > test2 :: IO Int
71−-- > test5 = runTraced $ do
32+-- > test2 = do
72-- > Left x <- return (Left 1 :: Either Int Int)
33-- > 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)
34+-- > True <- return (x == 3)
76−-- > return (x + y)
35+-- > return x
80−-- > hi
37+-- The advantage of this idiom is that it gives you line number information when the guard fails:
81−-- > *** Exception: user error (Pattern match failure in do expression at Traced.hs:137:3-6
88−-- Every Monad is also a MonadS, but not vice versa.
39+-- > *Traced> test3
89−
40+-- > *** Exception: user error (Pattern match failure in do expression at tests/Traced.hs:103:3-6)
90−module Traced ( -- Subclass of monads where bind is defined only for showable arguments
41+-- > Trace:
91− MonadS(..)
44+module Traced ( MonadS(..)
97− -- MonadS instance that shows a trace of all bound terms when an error occurs
103import Prelude hiding ((>>=), return, fail, catch, (>>))
51import Prelude hiding ((>>=), return, fail, catch, (>>))
104import qualified Prelude
52import qualified Prelude
105import Data.String (fromString)
53import Data.String (fromString)
54+import Control.Exception (catches, Handler(..), SomeException, throw, Exception(..))
55+import Data.Typeable (Typeable)
57+--------------------------------------------------------------------------------
59+--------------------------------------------------------------------------------
61+-- | Like 'Monad' but bind is only defined for 'Showable' instances
107class MonadS m where
62class MonadS m where
108 returnS :: a -> m a
63 returnS :: a -> m a
109 bindS :: Show a => m a -> (a -> m b) -> m b
64 bindS :: Show a => m a -> (a -> m b) -> m b
110 failS :: String -> m a
65 failS :: String -> m a
111 seqS :: m a -> m b -> m b
66 seqS :: m a -> m b -> m b
113−instance MonadS IO where
68+-- | Redefinition of 'Prelude.>>='
114− returnS = Prelude.return
115− bindS = (Prelude.>>=)
116− failS = Prelude.fail
119−newtype Traced a = Traced { unTraced :: IO ([String], Either String a) }
121−instance MonadS Traced where
122− returnS x = Traced $ Prelude.return ([], Right x)
123− x `bindS` f = Traced $ unTraced x Prelude.>>= \(trace, result) ->
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) ->
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)
135−runTraced :: Traced a -> IO a
136−runTraced (Traced x) = x Prelude.>>= \(trace, ma) ->
138− Left err -> Prelude.fail $ err ++ "\nTrace:\n" ++ showTrace trace
139− Right a -> Prelude.return a
141−showTrace :: [String] -> String
142−showTrace = unlines . map (\xs -> ' ' : ' ' : xs)
144−guard :: MonadS m => Bool -> m ()
145−guard True = returnS ()
146−guard False = failS "Guard failed"
148(>>=) :: (MonadS m, Show a) => m a -> (a -> m b) -> m b
69(>>=) :: (MonadS m, Show a) => m a -> (a -> m b) -> m b
149(>>=) = bindS
70(>>=) = bindS
72+-- | Redefinition of 'Prelude.>>'
151(>>) :: (MonadS m, Show a) => m a -> m b -> m b
73(>>) :: (MonadS m, Show a) => m a -> m b -> m b
152(>>) = seqS
74(>>) = seqS
76+-- | Redefinition of 'Prelude.return'
154return :: MonadS m => a -> m a
77return :: MonadS m => a -> m a
155return = returnS
78return = returnS
80+-- | Redefinition of 'Prelude.fail'
157fail :: MonadS m => String -> m a
81fail :: MonadS m => String -> m a
158fail = failS
82fail = failS
160−liftIO :: IO a -> Traced a
84+--------------------------------------------------------------------------------
161−liftIO x = Traced $ x Prelude.>>= \a -> Prelude.return ([], Right a)
85+-- IO instance for MonadS --
86+--------------------------------------------------------------------------------
88+data TracedException = TracedException [String] SomeException
91+instance Exception TracedException
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)
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)))
104+traceHandlers :: Show a => a -> [Handler b]
106+ [ Handler $ \(TracedException trace ex) -> throw $ TracedException (show a : trace) ex
107+ , Handler $ \(ex :: SomeException) -> throw $ TracedException [show a] ex