Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

Remove Eq constraint and other large improvements #12

Merged
merged 9 commits into from Apr 12, 2022
Merged

Remove Eq constraint and other large improvements #12

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
9 commits
Select commit Hold shift + click to select a range
bcef58e
Ok that's a big change lol
parsonsmatt Apr 7, 2022
2d943c6
more like derived show instance
parsonsmatt Apr 8, 2022
4a0ce1d
heckin yes
parsonsmatt Apr 8, 2022
95324fa
k
parsonsmatt Apr 8, 2022
c22f152
changelog link
parsonsmatt Apr 8, 2022
cc68087
stylin
parsonsmatt Apr 8, 2022
da40864
syyle
parsonsmatt Apr 8, 2022
baabf6f
clean a few warns
parsonsmatt Apr 8, 2022
3615ec2
docs
parsonsmatt Apr 8, 2022
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Jump to
Jump to file
Failed to load files.
Diff view
Diff view
14 changes: 14 additions & 0 deletions ChangeLog.md
View file
Open in desktop
Expand Up @@ -2,6 +2,20 @@

## Unreleased changes

## 0.2.0.0

- [#12](https://github.com/parsonsmatt/annotated-exception/pull/12)
- Removed the `Eq` instance for `Annotation` as well as the `Eq` constraint
in `AnnC`. These instances were only used for testing, and prevented the
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

These instances were only used for testing,

I wish there were a way to expose something like this for testing without influencing the library interface, other than like CPP.

natural use of `CallStack` in a `[Annotation]`.
- Removed the `Eq` instance for `AnnotatedException` as a consequence of
dropping the `Eq` instance on `Annotation`.
- Removed the `new` function. Use `pure` or `exceptionWithCallStack` instead.
- Fixed a double-annotation bug in `checkpointCallStackWith`.
- `checkpointCallStack` appends to the call-site list.
- Pretty much everything now merges the `CallStack`s together. `throw`
includes a `CallStack`, as do `checkpoint` and `checkpointMany`.

## 0.1.2.1

- [#8](https://github.com/parsonsmatt/annotated-exception/pull/8)
Expand Down
2 changes: 1 addition & 1 deletion annotated-exception.cabal
View file
Open in desktop
Expand Up @@ -5,7 +5,7 @@ cabal-version: 1.12
-- see: https://github.com/sol/hpack

name: annotated-exception
version: 0.1.2.1
version: 0.2.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
Expand Down
2 changes: 1 addition & 1 deletion package.yaml
View file
Open in desktop
@@ -1,5 +1,5 @@
name: annotated-exception
version: 0.1.2.1
version: 0.2.0.0
github: "parsonsmatt/annotated-exception"
license: BSD3
author: "Matt Parsons"
Expand Down
167 changes: 108 additions & 59 deletions src/Control/Exception/Annotated.hs
View file
Open in desktop
Expand Up @@ -28,7 +28,8 @@
module Control.Exception.Annotated
( -- * The Main Type
AnnotatedException(..)
, new
, exceptionWithCallStack
, throw
, throwWithCallStack
-- * Annotating Exceptions
, checkpoint
Expand All @@ -53,7 +54,6 @@ module Control.Exception.Annotated
-- * Re-exports from "Control.Exception.Safe"
, Exception(..)
, Safe.SomeException(..)
, Safe.throw
, Handler (..)
) where

Expand All @@ -62,10 +62,10 @@ import Control.Exception.Safe
import qualified Control.Exception.Safe as Safe
import Data.Annotation
import Data.Maybe
import qualified Data.Set as Set
import Data.Typeable
import GHC.Stack


-- | The 'AnnotatedException' type wraps an @exception@ with
-- a @['Annotation']@. This can provide a sort of a manual stack trace with
-- programmer provided data.
Expand All @@ -76,7 +76,7 @@ data AnnotatedException exception
{ annotations :: [Annotation]
, exception :: exception
}
deriving (Eq, Show, Functor, Foldable, Traversable)
deriving (Show, Functor, Foldable, Traversable)

instance Applicative AnnotatedException where
pure =
Expand Down Expand Up @@ -112,30 +112,40 @@ instance (Exception exception) => Exception (AnnotatedException exception) where
fromException exn
| Just (e :: exception) <- Safe.fromException exn
=
pure $ new e
pure $ pure e
| otherwise
=
Nothing

-- | Attach an empty @['Annotation']@ to an exception.
-- | Annotate the underlying exception with a 'CallStack'.
--
-- @since 0.1.0.0
new :: e -> AnnotatedException e
new = pure
-- @since 0.2.0.0
exceptionWithCallStack :: (Exception e, HasCallStack) => e -> AnnotatedException e
exceptionWithCallStack =
AnnotatedException [callStackAnnotation]

-- | Append the @['Annotation']@ to the 'AnnotatedException'.
--
-- 'CallStack' is a special case - if a 'CallStack' is present in both the
-- 'AnnotatedException' and the @['Annotation']@, then this will append the
-- 'CallStack's in the new list and concatenate them all together.
--
-- @since 0.1.0.0
annotate :: [Annotation] -> AnnotatedException e -> AnnotatedException e
annotate ann (AnnotatedException anns e) = AnnotatedException (ann ++ anns) e
annotate newAnnotations (AnnotatedException oldAnnotations e) =
let
(callStacks, other) =
tryAnnotations (newAnnotations <> oldAnnotations)
in
foldr addCallStackToException (AnnotatedException other e) callStacks
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Wouldn't it make more sense for AnnotatedException to have a Maybe CallStack field, instead of extracting out the callstacks and treating them specially?

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Sorry if this question is kinda obtuse. I know I'm missing a lot of context.

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No, it's a great question, and something I waffled on a bit.

It's nice to have the exposed constructor and just write AnnotatedException annotations blah and then do foldr whatever def annotations. I like that.

It's also nice to have a notion of uniformity for how annotations are handled. It's a list. I, as a library author, don't get any special tricks that you, a library consumer, don't also have access to. So if I want to treat CallStack in a special way, I do so with the same tools and techniques as anyone else would. In that way, the implementation in the library serves as a sort of "how to manual" on using the library as well, if you studied the implementation.

CallStack seems like a reasonable exception. And it would be easy to have:

data Annotations = Annotations { getAnnotations :: [Annotation], annotationsCallStack :: Maybe CallStack }

But now, suppose I write this:

lmao :: HasCallStack => IO a -> IO a
lmao =
  checkpoint (Annotation callStack)

This is going to slam the CallStack into [Annotation], not the Maybe CallStack field. Unless I also do a type-check on all the functions which can add to the [Annotation] to defer to the CallStack instead, if the type works. Possible, sure:

annotate :: [Annotation] -> AnnotatedException e -> AnnotatedException e
annotate anns (AnnotatedException oldAnns e) = AnnotatedException newAnns e
  where
    newAnns = foldr updateAnnotation oldAnns anns
    updateAnnotation ann acc =
        case castAnnotation ann of
            Just callstack ->
                acc { annotationCallStack = mergeCallStack callstack (annotationCallStack acc) }
            Nothing -> 
                acc { getAnnotations = ann : getAnnotations acc }

And this logic had to be duplicated everywhere I modify Annotations, much like how it is done today.

Making it flexible/extensible would be something like, uh,

data TypeMap (xs :: [Type])

data SomeTypeMap where
    SomeTypeMap :: TypeMap xs -> SomeTypeMap

data Annotations = Annotations { regularAnnotations :: [Annotation], specialAnnotations :: SomeTypeMap }

annotate :: Annotation -> Annotations -> Annotations
annotate ann anns = 
    case ann of
        Annotation (a :: a) ->
            case lookupTypeMap @a (specialAnnotations anns) of
                Just existing ->
                    anns { specialAnnotations = mergeAnnotation a (specialAnnotations anns) }
                Nothing ->
                    anns { regularAnnotations = ann : regularAnnotations anns }

But then, the "special handling of annotations" is dependent on the specific value of the annotation in question, so you'd want to define something like:

myThrow = throwIO (AnnotatedException myEmptyAnnotations e)

myEmptyAnnotations = Annotations [] what
  where
    what = SomeTypeMap 
      $ TypeMap.handle @CallStack mergeCallStack
      $ TypeMap.handle @Foobar mergeFooBar

Which also seems weird - seems weird for an exception to know how to handle it's own annotations.

Copy link

@friedbrice friedbrice Apr 8, 2022 •
edited

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I understand your thinking. I guess I disagree in that I'm way more open to the idea of hiding the data constructors, so the lmao scenario couldn't happen. Also informing my opinion is the notion that the callstack is not (or at least should not be) a part of the semantics of the Haskell language, so hiding it to prevent people from branching on it would be an ideal feature (and treating them specially would be justified and would not then suggest a generalization). But I understand that people can have different goals, so thank you for explaining how your design does, in fact, meet your goals quite well.

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I guess I disagree in that I'm way more open to the idea of hiding the data constructors, so the lmao scenario couldn't happen.

Well, supposing I replace Annotation with toAnnotation :: (Typeable a, Show a) => a -> Annotation, that still doesn't help, because Annotation doesn't handle anything specially - AnnotationList would.

Another option would be something like:

class (Typeable a) => ToAnnotation a where
  toAnnotation :: a -> AnnotationList
  default toAnnotation :: (Show a, Typeable a) => a -> AnnotationList
  toAnnotation a = mempty { annotations = [Annotation a] }

instance ToAnnotation CallStack where
  toAnnotation cs = mempty { annotationCallStack = Just cs }

instance Semigroup AnnotationList where
  Annotations anns mcs <> Annotations anns' mcs' =
    Annotations (anns <> anns') (mergeCallStacks mcs mcs')

instance Monoid AnnotationList where
  mempty = AnnotationList mempty Nothing

🤔

But then you have to write a ToAnnotation instance for basically everything, which means you'd need to expose (at least) set/modify on AnnotationList, and you'd need the constructor for Annotation available. Which gets us back to our original problem of Annotation callStack not working how we'd want.


-- | Call 'toException' on the underlying 'Exception'.
-- | Call 'Safe.toException' on the underlying 'Exception'.
--
-- @since 0.1.0.0
hide :: Exception e => AnnotatedException e -> AnnotatedException SomeException
hide = fmap Safe.toException

-- | Call 'fromException' on the underlying 'Exception', attaching the
-- | Call 'Safe.fromException' on the underlying 'Exception', attaching the
-- annotations to the result.
--
-- @since 0.1.0.0
Expand All @@ -160,7 +170,7 @@ check = traverse Safe.fromException
-- > throw TestException `catch` \TestException ->
-- > putStrLn "ok!"
--
-- We can throw an exception and catch it with location.
-- We can throw an exception and catch it with annotations.
--
-- > throw TestException `catch` \(AnnotatedException anns TestException) ->
-- > putStrLn "ok!"
Expand Down Expand Up @@ -224,17 +234,23 @@ try action =
`catch`
(\exn -> pure $ Left exn)

-- | Attaches the 'CallStack' to the 'AnnotatedException' that is thrown.
-- | Throws an 'Exception' and annotates it with the current 'CallStack'.
--
-- The 'CallStack' will *not* be present as a 'CallStack' - it will be
-- a 'CallStackAnnotation'.
-- An alias for 'throwWithCallStack'.
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This looks weird to me. Is there really no difference between throw and throwWithCallStack? Their implementations are different. If they do the same thing in practice, should one actually be an alias of the other, or should we just remove one of them?

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The only difference should be in withFrozenCallStack which prevenst the callstack from having ["throw", "throwWIthCallStack"].

Copy link

@hdgarrood hdgarrood Apr 8, 2022 •
edited

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah right I see - in that case can we get rid of one of them?

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Everyone: "Haskell code has no side effects."

HasCallStack: "Hold my beer."

Copy link
Owner Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I suppose we could drop one of them. I like having the alias around to keep Control.Exception.Annotated (as much as possible) a drop-in replacement for other Control.Exception code.

Really, though, there's a lot that needs to be done there to make the APIs totally compatble.

Kinda wish backpack were easier to use, seems like a natural desire 🤔

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't know that I fully agree with this idea of giving the functions the same name as some functions in some other module as a "drop in" replacement. It's almost like "reassignment by shadowing" or like dynamic scoping of variables ("extreme late binding in all things," right?). It just seems like a very error-prone practice, and all it really saves you from is having to do a regex replace.

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Ah, of course. Keeping it around just to make it slightly easier to switch over makes sense to me, even if it’s not currently a full drop-in replacement.

--
-- @since 0.2.0.0
throw :: (HasCallStack, MonadThrow m, Exception e) => e -> m a
throw = withFrozenCallStack throwWithCallStack

-- | Attaches the 'CallStack' to the 'AnnotatedException' that is thrown.
--
-- @since 0.1.0.0
throwWithCallStack
:: (HasCallStack, MonadThrow m, Exception e)
=> e -> m a
throwWithCallStack e =
Safe.throw (AnnotatedException [callStackAnnotation] e)
withFrozenCallStack $
Safe.throw (AnnotatedException [callStackAnnotation] e)

-- | Concatenate two lists of annotations.
--
Expand All @@ -251,7 +267,8 @@ tryFlatten exn =
exn

-- | Add a single 'Annotation' to any exceptions thrown in the following
-- action.
-- action. The 'CallStack' present on any 'AnnotatedException' will also be
-- updated to include this location.
--
-- Example:
--
Expand All @@ -263,83 +280,115 @@ tryFlatten exn =
-- @"Foo"@.
--
-- @since 0.1.0.0
checkpoint :: MonadCatch m => Annotation -> m a -> m a
checkpoint ann = checkpointMany [ann]
checkpoint :: (HasCallStack, MonadCatch m) => Annotation -> m a -> m a
checkpoint ann = withFrozenCallStack (checkpointMany [ann])

-- | Add the current 'CallStack' to the checkpoint. This function searches any
-- thrown exception for a pre-existing 'CallStack' and will not overwrite or
-- replace the 'CallStack' if one is already present.
-- | Add the current 'CallStack' to the checkpoint, along with the given
-- annotations. This function merges 'CallStack's together, attempting to
-- preserve the call site ordering as GHC does it.
--
-- Primarily useful when you're wrapping a third party library.
-- As of 0.2.0.0, an alias for 'checkpointMany'.
--
-- @since 0.1.0.0
checkpointCallStackWith
:: (MonadCatch m, HasCallStack)
=> [Annotation]
-> m a
-> m a
checkpointCallStackWith ann action =
action `Safe.catch` \(exn :: SomeException) ->
Safe.throw
. annotate ann
. addCallStackToException callStack
$ case Safe.fromException exn of
Just (e' :: AnnotatedException SomeException) ->
case annotatedExceptionCallStack e' of
Nothing ->
annotate ann e'
Just _preexistingCallstack ->
e'
Nothing -> do
annotate ann $ new exn
checkpointCallStackWith anns =
withFrozenCallStack (checkpointMany anns)

-- | Add the current 'CallStack' to the checkpoint. This function searches any
-- thrown exception for a pre-existing 'CallStack' and will not overwrite or
-- replace the 'CallStack' if one is already present.
--
-- Primarily useful when you're wrapping a third party library.
{-# DEPRECATED checkpointCallStackWith "As of 0.2.0.0 this is exactly equivalent to `checkpointMany`." #-}

-- | Adds only the current 'CallStack' to the checkpoint. This function searches
-- any thrown exception for a pre-existing 'CallStack' and will merge the given
-- pre-existing 'CallStack' with the one on this function, in an attempt to
-- preserve the actual call history.
--
-- @since 0.1.0.0
checkpointCallStack
:: (MonadCatch m, HasCallStack)
=> m a
-> m a
checkpointCallStack =
checkpointCallStackWith []
withFrozenCallStack (checkpoint (Annotation callStack))

-- | Add the list of 'Annotation' to any exception thrown in the following
-- action.
--
-- @since 0.1.0.0
checkpointMany :: (MonadCatch m) => [Annotation] -> m a -> m a
checkpointMany ann action =
checkpointMany :: (MonadCatch m, HasCallStack) => [Annotation] -> m a -> m a
checkpointMany anns action =
action `Safe.catch` \(exn :: SomeException) ->
Safe.throw . annotate ann $ case Safe.fromException exn of
Just (e' :: AnnotatedException SomeException) ->
e'
Nothing -> do
new exn
Safe.throw
. addCallStackToException callStack
. annotate anns
$ case Safe.fromException exn of
Just (e' :: AnnotatedException SomeException) ->
e'
Nothing -> do
pure exn

-- | Retrieves the 'CallStack' from an 'AnnotatedException' if one is present.
--
-- The library maintains an internal check that a single 'CallStack' is present
-- in the list, so this only returns the first one found. If you have added
-- a 'CallStack' directly to the @['Annotation']@, then this will likely break.
--
Comment on lines +334 to +337
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Okay, sorry for sounding like a broken record here, but this just corroborates my earlier thinking. Wouldn't it really make more sense for AnnotatedException to have a Maybe CallStack field?

-- @since 0.1.0.0
annotatedExceptionCallStack :: AnnotatedException exception -> Maybe CallStack
annotatedExceptionCallStack exn =
let (stacks, _rest) = callStackInAnnotations (annotations exn)
let (stacks, _rest) = tryAnnotations (annotations exn)
in listToMaybe stacks

-- | Adds a 'CallStack' to the given 'AnnotatedException'. This function will
-- search through the existing annotations, and it will not add a second
-- 'CallStack' to the list.
-- 'CallStack' to the list. Instead, it will append the contents of the given
-- 'CallStack' to the existing one.
--
-- This mirrors the behavior of the way 'HasCallStack' actually works.
--
-- @since 0.1.0.0
addCallStackToException
:: CallStack
-> AnnotatedException exception
-> AnnotatedException exception
addCallStackToException cs exn =
case annotatedExceptionCallStack exn of
Nothing ->
annotate [callStackToAnnotation cs] exn
Just _ ->
exn
addCallStackToException cs (AnnotatedException annotations' e) =
AnnotatedException anns' e
where
anns' = go annotations'
-- not a huge fan of the direct recursion, but it seems easier than trying
-- to finagle a `foldr` or something
Comment on lines +360 to +361
Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

it'd be neat if the compiler could verify that at least one branch/equation doesn't make a recursive call. that still wouldn't guarantee termination, though.

Copy link

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

also wouldn't catch loops in mutual recursion.

go [] =
[Annotation cs]
go (ann : anns) =
case castAnnotation ann of
Just preexistingCallStack ->
mergeCallStack preexistingCallStack cs : anns
Nothing ->
ann : go anns

-- we want to merge callstack but not duplicate entries
mergeCallStack pre new =
Annotation
$ fromCallSiteList
$ fmap (fmap fromSrcLocOrd)
$ ordNub
$ fmap (fmap toSrcLocOrd)
$ getCallStack pre <> getCallStack new

toSrcLocOrd (SrcLoc a b c d e f g) =
(a, b, c, d, e, f, g)
fromSrcLocOrd (a, b, c, d, e, f, g) =
SrcLoc a b c d e f g

-- | Remove duplicates but keep elements in order.
-- O(n * log n)
-- Vendored from GHC
ordNub :: Ord a => [a] -> [a]
ordNub = go Set.empty
where
go _ [] = []
go s (x:xs)
| Set.member x s = go s xs
| otherwise = x : go (Set.insert x s) xs