module Freckle.App.Test.Hspec.AnnotatedException
  ( unwrapAnnotatedHUnitFailure
  , annotateHUnitFailure
  ) where

import Freckle.App.Prelude

import Control.Exception qualified
import Control.Lens (Lens', lens, over)
import Data.Annotation (Annotation, tryAnnotations)
import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty)
import Data.Text qualified as T
import Freckle.App.Exception (AnnotatedException (..))
import GHC.Stack (CallStack, prettyCallStack)
import Test.HUnit.Lang (FailureReason (..), HUnitFailure (..))
import Test.Hspec

-- | An hspec hook that lets hspec catch and pretty-print 'HUnitFailure', the
--   exception that is thrown when a test assertion fails
--
-- Tests for any code that might throw 'AnnotatedException' (which includes anything
-- that uses freckle-app) should add this hook to their test suite. Without it, if
-- you end up with an @'AnnotatedException' 'HUnitFailure'@, hspec doesn't recognize
-- it as an assertion failure and you get ugly output instead of nice output.
unwrapAnnotatedHUnitFailure :: Spec -> Spec
unwrapAnnotatedHUnitFailure :: Spec -> Spec
unwrapAnnotatedHUnitFailure = (IO () -> IO ()) -> Spec -> Spec
forall a. (IO () -> IO ()) -> SpecWith a -> SpecWith a
around_ ((IO () -> IO ()) -> Spec -> Spec)
-> (IO () -> IO ()) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ (AnnotatedException HUnitFailure -> HUnitFailure) -> IO () -> IO ()
forall e e' a.
(Exception e, Exception e') =>
(e -> e') -> IO a -> IO a
mapException AnnotatedException HUnitFailure -> HUnitFailure
annotateHUnitFailure

mapException :: (Exception e, Exception e') => (e -> e') -> IO a -> IO a
mapException :: forall e e' a.
(Exception e, Exception e') =>
(e -> e') -> IO a -> IO a
mapException e -> e'
f = (e -> IO a) -> IO a -> IO a
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
Control.Exception.handle ((e -> IO a) -> IO a -> IO a) -> (e -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ e' -> IO a
forall a e. Exception e => e -> a
Control.Exception.throw (e' -> IO a) -> (e -> e') -> e -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> e'
f

annotateHUnitFailure :: AnnotatedException HUnitFailure -> HUnitFailure
annotateHUnitFailure :: AnnotatedException HUnitFailure -> HUnitFailure
annotateHUnitFailure
  AnnotatedException {HUnitFailure
exception :: HUnitFailure
exception :: forall exception. AnnotatedException exception -> exception
exception, [Annotation]
annotations :: [Annotation]
annotations :: forall exception. AnnotatedException exception -> [Annotation]
annotations} =
    ASetter HUnitFailure HUnitFailure FailureReason FailureReason
-> (FailureReason -> FailureReason) -> HUnitFailure -> HUnitFailure
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter HUnitFailure HUnitFailure FailureReason FailureReason
Lens' HUnitFailure FailureReason
hUnitFailureReason ([Annotation] -> FailureReason -> FailureReason
annotateFailureReason [Annotation]
annotations) HUnitFailure
exception

hUnitFailureReason :: Lens' HUnitFailure FailureReason
hUnitFailureReason :: Lens' HUnitFailure FailureReason
hUnitFailureReason =
  (HUnitFailure -> FailureReason)
-> (HUnitFailure -> FailureReason -> HUnitFailure)
-> Lens' HUnitFailure FailureReason
forall s a b t. (s -> a) -> (s -> b -> t) -> Lens s t a b
lens
    (\(HUnitFailure Maybe SrcLoc
_ FailureReason
x) -> FailureReason
x)
    (\(HUnitFailure Maybe SrcLoc
l FailureReason
_) FailureReason
x -> Maybe SrcLoc -> FailureReason -> HUnitFailure
HUnitFailure Maybe SrcLoc
l FailureReason
x)

-- | Augment a 'FailureReason' with extra information derived from 'Annotation's
annotateFailureReason :: [Annotation] -> FailureReason -> FailureReason
annotateFailureReason :: [Annotation] -> FailureReason -> FailureReason
annotateFailureReason [Annotation]
as =
  \case
    Reason String
m -> String -> FailureReason
Reason (String -> [Annotation] -> String
makeMessage String
m [Annotation]
as)
    ExpectedButGot Maybe String
m String
e String
g -> Maybe String -> String -> String -> FailureReason
ExpectedButGot (Maybe String -> [Annotation] -> Maybe String
makeMessageMaybe Maybe String
m [Annotation]
as) String
e String
g

-- | Construct a message that consists of an introductory paragraph plus
--   some additional paragraphs based on annotations, separated by blank lines
makeMessage :: String -> [Annotation] -> String
makeMessage :: String -> [Annotation] -> String
makeMessage String
m [Annotation]
as =
  NonEmpty Paragraph -> String
forall (t :: * -> *). Foldable t => t Paragraph -> String
combineParagraphs (NonEmpty Paragraph -> String) -> NonEmpty Paragraph -> String
forall a b. (a -> b) -> a -> b
$ String -> Paragraph
stringParagraph String
m Paragraph -> [Paragraph] -> NonEmpty Paragraph
forall a. a -> [a] -> NonEmpty a
:| [Annotation] -> [Paragraph]
annotationParagraphs [Annotation]
as

-- | Like 'makeMessage' but without necessarily having an introductory paragraph present
--
-- If there is neither an introductory paragraph nor any annotations, the result is 'Nothing'.
makeMessageMaybe :: Maybe String -> [Annotation] -> Maybe String
makeMessageMaybe :: Maybe String -> [Annotation] -> Maybe String
makeMessageMaybe Maybe String
mm [Annotation]
as =
  (NonEmpty Paragraph -> String)
-> Maybe (NonEmpty Paragraph) -> Maybe String
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NonEmpty Paragraph -> String
forall (t :: * -> *). Foldable t => t Paragraph -> String
combineParagraphs (Maybe (NonEmpty Paragraph) -> Maybe String)
-> Maybe (NonEmpty Paragraph) -> Maybe String
forall a b. (a -> b) -> a -> b
$
    [Paragraph] -> Maybe (NonEmpty Paragraph)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty ([Paragraph] -> Maybe (NonEmpty Paragraph))
-> [Paragraph] -> Maybe (NonEmpty Paragraph)
forall a b. (a -> b) -> a -> b
$
      (String -> Paragraph) -> [String] -> [Paragraph]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Paragraph
stringParagraph (Maybe String -> [String]
forall a. Maybe a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Maybe String
mm) [Paragraph] -> [Paragraph] -> [Paragraph]
forall a. Semigroup a => a -> a -> a
<> [Annotation] -> [Paragraph]
annotationParagraphs [Annotation]
as

-- | Text that constitutes a paragraph in a potentially lengthy error message
--
-- Construct with 'stringParagraph' or 'textParagraph', which strip the text of
-- surrounding whitespace.
newtype Paragraph = Paragraph {Paragraph -> Text
paragraphText :: Text}

stringParagraph :: String -> Paragraph
stringParagraph :: String -> Paragraph
stringParagraph = Text -> Paragraph
textParagraph (Text -> Paragraph) -> (String -> Text) -> String -> Paragraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

textParagraph :: Text -> Paragraph
textParagraph :: Text -> Paragraph
textParagraph = Text -> Paragraph
Paragraph (Text -> Paragraph) -> (Text -> Text) -> Text -> Paragraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
T.strip

-- | Combine a list of paragraphs into a single string for the final output
combineParagraphs :: Foldable t => t Paragraph -> String
combineParagraphs :: forall (t :: * -> *). Foldable t => t Paragraph -> String
combineParagraphs =
  Text -> String
T.unpack (Text -> String) -> (t Paragraph -> Text) -> t Paragraph -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"\n\n" ([Text] -> Text) -> (t Paragraph -> [Text]) -> t Paragraph -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Paragraph -> Text) -> [Paragraph] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Paragraph -> Text
paragraphText ([Paragraph] -> [Text])
-> (t Paragraph -> [Paragraph]) -> t Paragraph -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Paragraph -> [Paragraph]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Render a list of annotations as a list of paragraphs
--
-- The paragraphs, depending on how much information there is to display, are:
--
-- * a summary of any annotations that aren't call stacks, if any
-- * the first call stack, if there are any call stacks
annotationParagraphs :: [Annotation] -> [Paragraph]
annotationParagraphs :: [Annotation] -> [Paragraph]
annotationParagraphs [Annotation]
annotations =
  [Maybe Paragraph] -> [Paragraph]
forall a. [Maybe a] -> [a]
catMaybes
    [ NonEmpty Annotation -> Paragraph
forall (t :: * -> *). Foldable t => t Annotation -> Paragraph
otherAnnotationsPart (NonEmpty Annotation -> Paragraph)
-> Maybe (NonEmpty Annotation) -> Maybe Paragraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Annotation] -> Maybe (NonEmpty Annotation)
forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [Annotation]
otherAnnotations
    , CallStack -> Paragraph
callStackPart (CallStack -> Paragraph) -> Maybe CallStack -> Maybe Paragraph
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [CallStack] -> Maybe CallStack
forall a. [a] -> Maybe a
listToMaybe [CallStack]
callStacks
    ]
 where
  ([CallStack]
callStacks, [Annotation]
otherAnnotations) = forall a. Typeable a => [Annotation] -> ([a], [Annotation])
tryAnnotations @CallStack [Annotation]
annotations

-- | Construct a paragraph consisting of a bullet list of annotations
otherAnnotationsPart :: Foldable t => t Annotation -> Paragraph
otherAnnotationsPart :: forall (t :: * -> *). Foldable t => t Annotation -> Paragraph
otherAnnotationsPart =
  Text -> Paragraph
textParagraph
    (Text -> Paragraph)
-> (t Annotation -> Text) -> t Annotation -> Paragraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text] -> Text
T.intercalate Text
"\n"
    ([Text] -> Text)
-> (t Annotation -> [Text]) -> t Annotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"Annotations:" :)
    ([Text] -> [Text])
-> (t Annotation -> [Text]) -> t Annotation -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotation -> Text) -> [Annotation] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Text
"\t * " <>) (Text -> Text) -> (Annotation -> Text) -> Annotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (Annotation -> String) -> Annotation -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> String
forall a. Show a => a -> String
show)
    ([Annotation] -> [Text])
-> (t Annotation -> [Annotation]) -> t Annotation -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t Annotation -> [Annotation]
forall a. t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

-- | Construct a paragraph that displays a call stack
callStackPart :: CallStack -> Paragraph
callStackPart :: CallStack -> Paragraph
callStackPart = Text -> Paragraph
textParagraph (Text -> Paragraph)
-> (CallStack -> Text) -> CallStack -> Paragraph
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack (String -> Text) -> (CallStack -> String) -> CallStack -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> String
prettyCallStack