Custom displayException (#30)

* hell yeah

* cleanup warns

* yesss

* chagnelog, package

Author: parsonsmatt

ChangeLog.md

@@ -1,5 +1,11 @@
 # Changelog for `annotated-exception`
 
+## 0.3.0.0
+
+- [#30](https://github.com/parsonsmatt/annotated-exception/pull/30)
+    - The `Show` and `displayException` now render the annotated exception in a
+      much nicer way.
+
 ## 0.2.0.5
 
 - [#27](https://github.com/parsonsmatt/annotated-exception/pull/27)

annotated-exception.cabal

@@ -1,11 +1,11 @@
 cabal-version: 1.12
 
--- This file has been generated from package.yaml by hpack version 0.35.2.
+-- This file has been generated from package.yaml by hpack version 0.36.0.
 --
 -- see: https://github.com/sol/hpack
 
 name:           annotated-exception
-version:        0.2.0.5
+version:        0.3.0.0
 synopsis:       Exceptions, with checkpoints and context.
 description:    Please see the README on Github at <https://github.com/parsonsmatt/annotated-exception#readme>
 category:       Control

package.yaml

@@ -1,5 +1,5 @@
 name:                annotated-exception
-version:             0.2.0.5
+version:             0.3.0.0
 github:              "parsonsmatt/annotated-exception"
 license:             BSD3
 author:              "Matt Parsons"

src/Control/Exception/Annotated.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
@@ -77,7 +78,10 @@ data AnnotatedException exception
     { annotations :: [Annotation]
     , exception   :: exception
     }
-    deriving (Show, Functor, Foldable, Traversable)
+    deriving (Functor, Foldable, Traversable)
+
+instance (Exception exception) => Show (AnnotatedException exception) where
+    show = Safe.displayException
 
 instance Applicative AnnotatedException where
     pure =
@@ -118,6 +122,31 @@ instance (Exception exception) => Exception (AnnotatedException exception) where
         =
             Nothing
 
+    displayException (AnnotatedException {..}) =
+        unlines
+            [ "! AnnotatedException !"
+            , "Underlying exception type: " <> show (typeOf exception)
+            , "displayException:"
+            , "\t" <> Safe.displayException exception
+            ]
+        <> annotationsMessage
+        <> callStackMessage
+      where
+        (callStacks, otherAnnotations) = tryAnnotations @CallStack annotations
+        callStackMessage =
+            case listToMaybe callStacks of
+                Nothing ->
+                    "(no callstack available)"
+                Just cs ->
+                    prettyCallStack cs
+        annotationsMessage =
+            case otherAnnotations of
+                [] ->
+                    "\n"
+                anns ->
+                    "Annotations:\n"
+                    <> unlines (map (\ann -> "\t * " <> show ann) anns)
+
 -- | Annotate the underlying exception with a 'CallStack'.
 --
 -- @since 0.2.0.0
@@ -267,13 +296,13 @@ flatten (AnnotatedException a (AnnotatedException b c)) = AnnotatedException (go
                 addCallStackToAnnotations cs bs
             Nothing ->
                 bs
-    go mcallstack (a : as) bs =
-        case castAnnotation a of
+    go mcallstack (ann : anns) bs =
+        case castAnnotation ann of
             Just cs ->
                 let newAcc = fmap (mergeCallStack cs) mcallstack <|> Just cs
-                 in go newAcc as bs
+                 in go newAcc anns bs
             Nothing ->
-                a : go mcallstack as bs
+                ann : go mcallstack anns bs
 
 tryFlatten :: SomeException -> SomeException
 tryFlatten exn =
@@ -374,7 +403,7 @@ addCallStackToException cs (AnnotatedException anns e) =
     AnnotatedException (addCallStackToAnnotations cs anns) e
 
 addCallStackToAnnotations :: CallStack -> [Annotation] -> [Annotation]
-addCallStackToAnnotations cs anns = go anns
+addCallStackToAnnotations cs = go
   where
     -- not a huge fan of the direct recursion, but it seems easier than trying
     -- to finagle a `foldr` or something

test/Control/Exception/AnnotatedSpec.hs

@@ -55,6 +55,29 @@ spec = do
                     SomeException $
                         AnnotatedException ["hello", "goodbye"] (SomeException TestException)
 
+    describe "displayException" $ do
+        it "is reasonably nice to look at" $ do
+            lines (displayException (AnnotatedException [] TestException))
+                `shouldBe`
+                    [ "! AnnotatedException !"
+                    , "Underlying exception type: TestException"
+                    , "displayException:"
+                    , "\tTestException"
+                    , ""
+                    , "(no callstack available)"
+                    ]
+        it "is reasonably nice to look at" $ do
+            lines (displayException (AnnotatedException [Annotation @String "asdf"] TestException))
+                `shouldBe`
+                    [ "! AnnotatedException !"
+                    , "Underlying exception type: TestException"
+                    , "displayException:"
+                    , "\tTestException"
+                    , "Annotations:"
+                    , "\t * Annotation @[Char] \"asdf\""
+                    , "(no callstack available)"
+                    ]
+
     describe "AnnotatedException can fromException a" $ do
         it "different type" $ do
             fromException (toException TestException)