{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}

-- | An 'Annotation' is attached to an 'Control.Exception.Annotated.AnnotatedException'. They're
-- essentially a dynamically typed value with a convenient 'IsString'
-- instance.
--
-- When integrating into your own application, you will likely want to do more
-- than just have the 'String' you get from 'show'ing the 'Annotation'. You can
-- do this by creating a special wrapper type that carries a class constraint.
-- This allows you to also pluck out the 'Annotation's from your library or
-- executable independently and treat them differently from unknonwn
-- annotations.
--
-- As an example, here's one that requires a 'Data.Aeson.ToJSON' constraint on the
-- underlying value. This means that you can convert any annotated value to
-- JSON, and then use that JSON in bug reports or logging.
--
-- @
-- data JsonAnnotation where
--   JsonAnnotation :: (ToJSON a, Typeable a) => a -> JsonAnnotation
--
-- instance Show JsonANnotation where
--   show (JsonAnnotation a) = concat
--      [ "(JsonAnnotation ("
--      , show (toJSON a)
--      , "))"
--      ]
--
-- jsonCheckpoint :: (Typeable a, ToJSON a, 'HasCallStack', MonadCatch m) => a -> m a -> m a
-- jsonCheckpoint val = 'withFrozenCallStack' checkpoint (JsonAnnotation val)
-- @
--
-- When handling the @['Annotation']@ carried on the
-- 'Control.Exception.Annotated.AnnotatedException', you can use
-- 'tryAnnotations' to pick out the JSON annotations.
--
-- @
-- jsonAnnotations :: [Annotation] -> ([JsonAnnotation], [Annotation])
-- jsonAnnotations = tryAnnotations
-- @
--
-- and handle them however you please.
--
-- @since 0.1.0.0
module Data.Annotation
    ( module Data.Annotation
    , module Data.Proxy
    ) where

import Data.Either
import Data.Maybe
import Data.Proxy
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String
import qualified Data.Text as Text
import Data.Typeable
import GHC.Stack

-- | The constraints that the value inside an 'Annotation' must have.
--
-- We want 'Typeable' so we can do 'cast' and potentially get more useful
-- information out of it.
--
-- @since 0.1.0.0
type AnnC a = (Typeable a, Show a)

-- | An 'Annotation' is a wrapper around a value that includes a 'Typeable'
-- constraint so we can later unpack it. It is essentially a 'Data.Dynamic.Dynamic', but
-- we also include 'Show' so that you can always fall back to simply 'show'ing
-- the 'Annotation' if it is otherwise unrecognized.
--
-- @since 0.1.0.0
data Annotation where
    Annotation
        :: AnnC a
        => a
        -> Annotation

-- |
--
-- @since 0.1.0.0
instance Show Annotation where
    showsPrec :: Int -> Annotation -> ShowS
showsPrec Int
p (Annotation a
a) =
        Bool -> ShowS -> ShowS
showParen (Int
p Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
10) (ShowS -> ShowS) -> ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$
            String -> ShowS
showString String
"Annotation @"
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TypeRep -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 (a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString String
" "
            ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> a -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
a

-- |
--
-- @since 0.1.0.0
instance IsString Annotation where
    fromString :: String -> Annotation
fromString = Text -> Annotation
forall a. AnnC a => a -> Annotation
Annotation (Text -> Annotation) -> (String -> Text) -> String -> Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack

-- | Wrap a value in an 'Annotation'.
--
-- @since 0.1.0.0
toAnnotation :: (AnnC a) => a -> Annotation
toAnnotation :: forall a. AnnC a => a -> Annotation
toAnnotation = a -> Annotation
forall a. AnnC a => a -> Annotation
Annotation

-- | Attempt to 'cast' the underlying value out of an 'Annotation'.
--
-- @since 0.1.0.0
castAnnotation
    :: forall a. (Typeable a)
    => Annotation
    -> Maybe a
castAnnotation :: forall a. Typeable a => Annotation -> Maybe a
castAnnotation (Annotation a
ann) =
    a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
ann

-- | Attempt to 'cast' the underlying value out of an 'Annotation'.
-- Returns the original 'Annotation' if the cast isn't right.
--
-- @since 0.1.0.0
tryAnnotation
    :: forall a. (Typeable a)
    => Annotation
    -> Either a Annotation
tryAnnotation :: forall a. Typeable a => Annotation -> Either a Annotation
tryAnnotation a :: Annotation
a@(Annotation a
val) =
    case a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
val of
        Just a
x ->
            a -> Either a Annotation
forall a b. a -> Either a b
Left a
x
        Maybe a
Nothing ->
            Annotation -> Either a Annotation
forall a b. b -> Either a b
Right Annotation
a

-- | Attempt to 'cast' list of 'Annotation' into the given type. Any
-- 'Annotation' that is not in that form is left untouched.
--
-- @since 0.1.0.0
tryAnnotations
    :: forall a. (Typeable a)
    => [Annotation]
    -> ([a], [Annotation])
tryAnnotations :: forall a. Typeable a => [Annotation] -> ([a], [Annotation])
tryAnnotations = [Either a Annotation] -> ([a], [Annotation])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either a Annotation] -> ([a], [Annotation]))
-> ([Annotation] -> [Either a Annotation])
-> [Annotation]
-> ([a], [Annotation])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotation -> Either a Annotation)
-> [Annotation] -> [Either a Annotation]
forall a b. (a -> b) -> [a] -> [b]
map Annotation -> Either a Annotation
forall a. Typeable a => Annotation -> Either a Annotation
tryAnnotation

-- | Returns the 'Set' of types that are in the given annotations.
--
-- @since 0.1.0.0
annotationTypes
    :: [Annotation]
    -> Set TypeRep
annotationTypes :: [Annotation] -> Set TypeRep
annotationTypes = [TypeRep] -> Set TypeRep
forall a. Ord a => [a] -> Set a
Set.fromList ([TypeRep] -> Set TypeRep)
-> ([Annotation] -> [TypeRep]) -> [Annotation] -> Set TypeRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Annotation -> TypeRep) -> [Annotation] -> [TypeRep]
forall a b. (a -> b) -> [a] -> [b]
map (\(Annotation a
a) -> a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a
a)

-- | Map a function over the given 'Annotation'. If the types don't match
-- up, then the whole thing returns 'Nothing'.
--
-- @since 0.1.0.0
mapAnnotation
    :: ((AnnC a, AnnC b))
    => (a -> b)
    -> Annotation
    -> Maybe Annotation
mapAnnotation :: forall a b.
(AnnC a, AnnC b) =>
(a -> b) -> Annotation -> Maybe Annotation
mapAnnotation a -> b
f (Annotation a
ann) =
    b -> Annotation
forall a. AnnC a => a -> Annotation
Annotation (b -> Annotation) -> (a -> b) -> a -> Annotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f (a -> Annotation) -> Maybe a -> Maybe Annotation
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
ann

-- | Map a function over the 'Annotation', leaving it unchanged if the
-- types don't match.
--
-- @since 0.1.0.0
mapMaybeAnnotation
    :: (AnnC a, AnnC b)
    => (a -> b)
    -> Annotation
    -> Annotation
mapMaybeAnnotation :: forall a b.
(AnnC a, AnnC b) =>
(a -> b) -> Annotation -> Annotation
mapMaybeAnnotation a -> b
f Annotation
ann =
    Annotation -> Maybe Annotation -> Annotation
forall a. a -> Maybe a -> a
fromMaybe Annotation
ann ((a -> b) -> Annotation -> Maybe Annotation
forall a b.
(AnnC a, AnnC b) =>
(a -> b) -> Annotation -> Maybe Annotation
mapAnnotation a -> b
f Annotation
ann)

-- | A wrapper type for putting a 'CallStack' into an 'Annotation'. We need
-- this because 'CallStack' does not have an 'Eq' instance.
--
-- Deprecated in 0.2.0.0 since you can just put a 'CallStack' directly in an
-- 'Annotation' now that we have no need for an 'Eq' constraint on it.
--
-- @since 0.1.0.0
newtype CallStackAnnotation = CallStackAnnotation
    { CallStackAnnotation -> [(String, SrcLoc)]
unCallStackAnnotation :: [(String, SrcLoc)]
    }
    deriving (CallStackAnnotation -> CallStackAnnotation -> Bool
(CallStackAnnotation -> CallStackAnnotation -> Bool)
-> (CallStackAnnotation -> CallStackAnnotation -> Bool)
-> Eq CallStackAnnotation
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CallStackAnnotation -> CallStackAnnotation -> Bool
== :: CallStackAnnotation -> CallStackAnnotation -> Bool
$c/= :: CallStackAnnotation -> CallStackAnnotation -> Bool
/= :: CallStackAnnotation -> CallStackAnnotation -> Bool
Eq, Int -> CallStackAnnotation -> ShowS
[CallStackAnnotation] -> ShowS
CallStackAnnotation -> String
(Int -> CallStackAnnotation -> ShowS)
-> (CallStackAnnotation -> String)
-> ([CallStackAnnotation] -> ShowS)
-> Show CallStackAnnotation
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CallStackAnnotation -> ShowS
showsPrec :: Int -> CallStackAnnotation -> ShowS
$cshow :: CallStackAnnotation -> String
show :: CallStackAnnotation -> String
$cshowList :: [CallStackAnnotation] -> ShowS
showList :: [CallStackAnnotation] -> ShowS
Show)

{-# DEPRECATED CallStackAnnotation "You can just use `CallStack` directly now." #-}

-- | Grab an 'Annotation' corresponding to the 'CallStack' that is
-- currently in scope.
--
-- @since 0.1.0.0
callStackAnnotation :: HasCallStack => Annotation
callStackAnnotation :: HasCallStack => Annotation
callStackAnnotation = CallStack -> Annotation
forall a. AnnC a => a -> Annotation
Annotation CallStack
HasCallStack => CallStack
callStack

-- | Stuff a 'CallStack' into an 'Annotation' via the 'CallStackAnnotation'
-- newtype wrapper.
--
-- @since 0.1.0.0
callStackToAnnotation :: CallStack -> Annotation
callStackToAnnotation :: CallStack -> Annotation
callStackToAnnotation = CallStack -> Annotation
forall a. AnnC a => a -> Annotation
Annotation

-- | Convert the legacy 'CallStackAnnotation' into a 'CallStack'.
--
-- Deprecated in 0.2.0.0 since you can use 'CallStack' directly.
--
-- @since 0.1.0.0
callStackFromAnnotation :: CallStackAnnotation -> CallStack
callStackFromAnnotation :: CallStackAnnotation -> CallStack
callStackFromAnnotation CallStackAnnotation
ann =
    [(String, SrcLoc)] -> CallStack
fromCallSiteList ([(String, SrcLoc)] -> CallStack)
-> [(String, SrcLoc)] -> CallStack
forall a b. (a -> b) -> a -> b
$ CallStackAnnotation -> [(String, SrcLoc)]
unCallStackAnnotation CallStackAnnotation
ann

{-# DEPRECATED callStackFromAnnotation "You can use 'CallStack' directly in annotations as of 0.2.0.0." #-}

-- | Extract the 'CallStack's from the @['Annotation']@. Any 'Annotation'
-- not corresponding to a 'CallStack' will be in the second element of the
-- tuple.
--
-- @since 0.1.0.0
callStackInAnnotations :: [Annotation] -> ([CallStack], [Annotation])
callStackInAnnotations :: [Annotation] -> ([CallStack], [Annotation])
callStackInAnnotations =
    [Annotation] -> ([CallStack], [Annotation])
forall a. Typeable a => [Annotation] -> ([a], [Annotation])
tryAnnotations

{-# DEPRECATED callStackInAnnotations "You can just use 'tryAnnotations' directly as of 0.2.0.0." #-}