diff --git a/Control/Monad/Conc/SCT.hs b/Control/Monad/Conc/SCT.hs
index 2fe693d..05a5e94 100644
--- a/Control/Monad/Conc/SCT.hs
+++ b/Control/Monad/Conc/SCT.hs
@@ -88,13 +88,3 @@ preEmpCount :: [Decision] -> Int
 preEmpCount (SwitchTo _:ss) = 1 + preEmpCount ss
 preEmpCount (_:ss) = preEmpCount ss
 preEmpCount [] = 0
-
--- | Pretty-print a scheduler trace.
-showTrace :: SchedTrace -> String
-showTrace = trace "" 0 . map fst where
-  trace prefix num (Start tid:ds)    = thread prefix num ++ trace ("S" ++ show tid) 1 ds
-  trace prefix num (SwitchTo tid:ds) = thread prefix num ++ trace ("P" ++ show tid) 1 ds
-  trace prefix num (Continue:ds)     = trace prefix (num + 1) ds
-  trace prefix num []                = thread prefix num
-
-  thread prefix num = prefix ++ replicate num '-'
diff --git a/Control/Monad/Conc/SCT/Internal.hs b/Control/Monad/Conc/SCT/Internal.hs
index 1c35469..c9518ac 100755
--- a/Control/Monad/Conc/SCT/Internal.hs
+++ b/Control/Monad/Conc/SCT/Internal.hs
@@ -116,7 +116,7 @@ runSCTIO' sched initial term step c = unfoldrM go initial where
 
       res `seq` return (Just ((res, trace), sg'))
 
--- * Schedulers
+-- * Schedulers and Traces
 
 -- | Convert a 'Scheduler' to an 'SCTScheduler' by recording the
 -- trace.
@@ -136,6 +136,16 @@ makeSCT sched (s, trace) prior threads = (tid, (s', (decision, alters) : trace))
 
   threads' = toList threads
 
+-- | Pretty-print a scheduler trace.
+showTrace :: SchedTrace -> String
+showTrace = trace "" 0 . map fst where
+  trace prefix num (Start tid:ds)    = thread prefix num ++ trace ("S" ++ show tid) 1 ds
+  trace prefix num (SwitchTo tid:ds) = thread prefix num ++ trace ("P" ++ show tid) 1 ds
+  trace prefix num (Continue:ds)     = trace prefix (num + 1) ds
+  trace prefix num []                = thread prefix num
+
+  thread prefix num = prefix ++ replicate num '-'
+
 -- * Utils (Internal)
 
 -- | Zip a list of 'SchedTrace's and a 'Trace' together into an
diff --git a/Control/Monad/Conc/SCT/Tests.hs b/Control/Monad/Conc/SCT/Tests.hs
index bd7eef6..acc95cd 100644
--- a/Control/Monad/Conc/SCT/Tests.hs
+++ b/Control/Monad/Conc/SCT/Tests.hs
@@ -4,6 +4,7 @@
 -- computations.
 module Control.Monad.Conc.SCT.Tests
   ( doTests
+  , doTests'
   -- * Test cases
   , Result(..)
   , runTest
@@ -41,33 +42,76 @@ import qualified Control.Monad.Conc.Fixed.IO as CIO
 
 -- | Run a collection of tests (with a pb of 2), printing results to
 -- stdout, and returning 'True' iff all tests pass.
-doTests :: Show a =>
-        Bool
+doTests :: Show a
+        => Bool
         -- ^ Whether to print test passes.
         -> [(String, Result a)]
         -- ^ The test cases
         -> IO Bool
-doTests verbose tests = do
-  results <- mapM (doTest verbose) tests
+doTests = doTests' show
+
+-- | Variant of 'doTests' which takes a result printing function.
+doTests' :: (a -> String) -> Bool -> [(String, Result a)] -> IO Bool
+doTests' showf verbose tests = do
+  results <- mapM (doTest showf verbose) tests
   return $ and results
 
 -- | Run a test and print to stdout
-doTest :: Show a => Bool -> (String, Result a) -> IO Bool
-doTest verbose (name, result) = do
+doTest :: (a -> String) -> Bool -> (String, Result a) -> IO Bool
+doTest showf verbose (name, result) = do
   if _pass result
   then
     -- If verbose, display a pass message.
     when verbose $
       putStrLn $ "\27[32m[pass]\27[0m " ++ name ++ " (checked: " ++ show (_casesChecked result) ++ ")"
   else do
-    -- Display a failure message, and the first 3 failed traces
+    -- Display a failure message, and the first 5 (simplified) failed traces
     putStrLn ("\27[31m[fail]\27[0m " ++ name ++ " (checked: " ++ show (_casesChecked result) ++ ")")
-    mapM_ (\fail -> putStrLn $ "\t" ++ show fail) . take 3 $ _failures result
-    when (length (_failures result) > 3) $
+    let traces = let (rs, ts) = unzip . take 5 $ _failures result in rs `zip` simplify ts
+    mapM_ (\(r, t) -> putStrLn $ "\t" ++ maybe "[deadlock]" showf r ++ " " ++ showtrc t) traces
+    when (length (_failures result) > 5) $
       putStrLn "\t..."
 
   return $ _pass result
 
+-- | Simplify a collection of traces, by attempting to factor out
+-- common prefixes and suffixes.
+simplify :: [SCTTrace] -> [(SCTTrace, SCTTrace, SCTTrace)]
+simplify [t] = [([], t, [])]
+simplify ts = map (\t -> (pref, drop plen $ take (length t - slen) t, suff)) ts where
+  pref = commonPrefix ts
+  plen = length pref
+  suff = commonSuffix ts
+  slen = length suff
+
+  -- | Common prefix of a bunch of lists
+  commonPrefix = foldl1 commonPrefix2
+
+  -- | Common suffix of a bunch of lists
+  commonSuffix = reverse . commonPrefix . map reverse
+
+  -- | Common prefix of two lists
+  commonPrefix2 [] _ = []
+  commonPrefix2 _ [] = []
+  commonPrefix2 (x:xs) (y:ys)
+    | x == y     = x : commonPrefix2 xs ys
+    | otherwise = []
+
+-- | Pretty-print a simplified trace
+showtrc :: (SCTTrace, SCTTrace, SCTTrace) -> String
+showtrc (p, t, s) = case (p, s) of
+  ([], []) -> hilight ++ showtrc' t ++ reset
+  ([], _)  -> hilight ++ showtrc' t ++ reset ++ s'
+  (_, [])  -> p' ++ hilight ++ showtrc' t ++ reset
+  (_, _)   -> p' ++ hilight ++ showtrc' t ++ reset ++ s'
+
+  where
+    showtrc' = showTrace . map (\(d,as,_) -> (d,as))
+    hilight = "\27[33m"
+    reset   = "\27[0m"
+    p' = (if length p > 25 then ("..." ++) . reverse . take 25 . reverse else id) $ showtrc' p
+    s' = (if length s > 25 then (++ "...") . take 25 else id) $ showtrc' s
+
 -- * Test cases
 
 -- | The results of a test, including information on the number of
diff --git a/tests/Tests.hs b/tests/Tests.hs
index a472659..56b403b 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -1,10 +1,10 @@
 module Main (main) where
 
-import Control.Monad.Conc.SCT.Tests (doTests)
+import Control.Monad.Conc.SCT.Tests (doTests')
 import Tests.Cases
 import System.Exit (exitFailure, exitSuccess)
 
 main :: IO ()
 main = do
-  success <- doTests True testCases
+  success <- doTests' id True testCases
   if success then exitSuccess else exitFailure