{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
module Data.Annotation
( module Data.Annotation
, module Data.Proxy
) where
import GHC.Stack
import Data.Dynamic
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
type AnnC a = (Typeable a, Eq a, Show a)
data Annotation where
Annotation
:: AnnC a
=> a
-> Annotation
instance Eq Annotation where
Annotation (a
a :: a) == :: Annotation -> Annotation -> Bool
== Annotation (a
b :: b) =
case (Typeable a, Typeable a) => Maybe (a :~: a)
forall k (a :: k) (b :: k).
(Typeable a, Typeable b) =>
Maybe (a :~: b)
eqT @a @b of
Just a :~: a
Refl ->
a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
a
b
Maybe (a :~: a)
Nothing ->
Bool
False
instance Show Annotation where
show :: Annotation -> String
show (Annotation a
a) = a -> String
forall a. Show a => a -> String
show a
a
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
toAnnotation :: (AnnC a) => a -> Annotation
toAnnotation :: a -> Annotation
toAnnotation = a -> Annotation
forall a. AnnC a => a -> Annotation
Annotation
castAnnotation
:: forall a. (Typeable a)
=> Annotation
-> Maybe a
castAnnotation :: Annotation -> Maybe a
castAnnotation (Annotation a
ann) =
a -> Maybe a
forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a
ann
tryAnnotation
:: forall a. (Typeable a)
=> Annotation
-> Either a Annotation
tryAnnotation :: 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
tryAnnotations
:: forall a. (Typeable a)
=> [Annotation]
-> ([a], [Annotation])
tryAnnotations :: [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
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)
mapAnnotation
:: ((AnnC a, AnnC b))
=> (a -> b)
-> Annotation
-> Maybe Annotation
mapAnnotation :: (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
mapMaybeAnnotation
:: (AnnC a, AnnC b)
=> (a -> b)
-> Annotation
-> Annotation
mapMaybeAnnotation :: (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)
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
/= :: CallStackAnnotation -> CallStackAnnotation -> Bool
$c/= :: CallStackAnnotation -> CallStackAnnotation -> Bool
== :: CallStackAnnotation -> CallStackAnnotation -> Bool
$c== :: 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
showList :: [CallStackAnnotation] -> ShowS
$cshowList :: [CallStackAnnotation] -> ShowS
show :: CallStackAnnotation -> String
$cshow :: CallStackAnnotation -> String
showsPrec :: Int -> CallStackAnnotation -> ShowS
$cshowsPrec :: Int -> CallStackAnnotation -> ShowS
Show)
callStackAnnotation :: HasCallStack => Annotation
callStackAnnotation :: Annotation
callStackAnnotation = CallStack -> Annotation
callStackToAnnotation CallStack
HasCallStack => CallStack
callStack
callStackToAnnotation :: CallStack -> Annotation
callStackToAnnotation :: CallStack -> Annotation
callStackToAnnotation CallStack
cs = CallStackAnnotation -> Annotation
forall a. AnnC a => a -> Annotation
Annotation (CallStackAnnotation -> Annotation)
-> CallStackAnnotation -> Annotation
forall a b. (a -> b) -> a -> b
$ [(String, SrcLoc)] -> CallStackAnnotation
CallStackAnnotation ([(String, SrcLoc)] -> CallStackAnnotation)
-> [(String, SrcLoc)] -> CallStackAnnotation
forall a b. (a -> b) -> a -> b
$ CallStack -> [(String, SrcLoc)]
getCallStack CallStack
cs
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
callStackInAnnotations :: [Annotation] -> ([CallStack], [Annotation])
callStackInAnnotations :: [Annotation] -> ([CallStack], [Annotation])
callStackInAnnotations [Annotation]
anns =
let ([CallStackAnnotation]
callStacks, [Annotation]
rest) =
[Annotation] -> ([CallStackAnnotation], [Annotation])
forall a. Typeable a => [Annotation] -> ([a], [Annotation])
tryAnnotations [Annotation]
anns
in
((CallStackAnnotation -> CallStack)
-> [CallStackAnnotation] -> [CallStack]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CallStackAnnotation -> CallStack
callStackFromAnnotation [CallStackAnnotation]
callStacks, [Annotation]
rest)