1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
|
-- |
-- Support for source code annotation feature of GHC. That is the ANN pragma.
--
-- (c) The University of Glasgow 2006
-- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
--
module Annotations (
-- * Main Annotation data types
Annotation(..), AnnPayload,
AnnTarget(..), CoreAnnTarget,
getAnnTargetName_maybe,
-- * AnnEnv for collecting and querying Annotations
AnnEnv,
mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv,
findAnns, findAnnsByTypeRep,
deserializeAnns
) where
import Binary
import Module ( Module )
import Name
import Outputable
import GHC.Serialized
import UniqFM
import Unique
import Control.Monad
import Data.Maybe
import Data.Typeable
import Data.Word ( Word8 )
-- | Represents an annotation after it has been sufficiently desugared from
-- it's initial form of 'HsDecls.AnnDecl'
data Annotation = Annotation {
ann_target :: CoreAnnTarget, -- ^ The target of the annotation
ann_value :: AnnPayload
}
type AnnPayload = Serialized -- ^ The "payload" of an annotation
-- allows recovery of its value at a given type,
-- and can be persisted to an interface file
-- | An annotation target
data AnnTarget name
= NamedTarget name -- ^ We are annotating something with a name:
-- a type or identifier
| ModuleTarget Module -- ^ We are annotating a particular module
-- | The kind of annotation target found in the middle end of the compiler
type CoreAnnTarget = AnnTarget Name
instance Functor AnnTarget where
fmap f (NamedTarget nm) = NamedTarget (f nm)
fmap _ (ModuleTarget mod) = ModuleTarget mod
-- | Get the 'name' of an annotation target if it exists.
getAnnTargetName_maybe :: AnnTarget name -> Maybe name
getAnnTargetName_maybe (NamedTarget nm) = Just nm
getAnnTargetName_maybe _ = Nothing
instance Uniquable name => Uniquable (AnnTarget name) where
getUnique (NamedTarget nm) = getUnique nm
getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0
-- deriveUnique prevents OccName uniques clashing with NamedTarget
instance Outputable name => Outputable (AnnTarget name) where
ppr (NamedTarget nm) = text "Named target" <+> ppr nm
ppr (ModuleTarget mod) = text "Module target" <+> ppr mod
instance Binary name => Binary (AnnTarget name) where
put_ bh (NamedTarget a) = do
putByte bh 0
put_ bh a
put_ bh (ModuleTarget a) = do
putByte bh 1
put_ bh a
get bh = do
h <- getByte bh
case h of
0 -> liftM NamedTarget $ get bh
_ -> liftM ModuleTarget $ get bh
instance Outputable Annotation where
ppr ann = ppr (ann_target ann)
-- | A collection of annotations
-- Can't use a type synonym or we hit bug #2412 due to source import
newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload])
-- | An empty annotation environment.
emptyAnnEnv :: AnnEnv
emptyAnnEnv = MkAnnEnv emptyUFM
-- | Construct a new annotation environment that contains the list of
-- annotations provided.
mkAnnEnv :: [Annotation] -> AnnEnv
mkAnnEnv = extendAnnEnvList emptyAnnEnv
-- | Add the given annotation to the environment.
extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList (MkAnnEnv env) anns
= MkAnnEnv $ addListToUFM_C (++) env $
map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns
-- | Union two annotation environments.
plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2
-- | Find the annotations attached to the given target as 'Typeable'
-- values of your choice. If no deserializer is specified,
-- only transient annotations will be returned.
findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns deserialize (MkAnnEnv ann_env)
= (mapMaybe (fromSerialized deserialize))
. (lookupWithDefaultUFM ann_env [])
-- | Find the annotations attached to the given target as 'Typeable'
-- values of your choice. If no deserializer is specified,
-- only transient annotations will be returned.
findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep
= [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target
, tyrep' == tyrep ]
-- | Deserialize all annotations of a given type. This happens lazily, that is
-- no deserialization will take place until the [a] is actually demanded and
-- the [a] can also be empty (the UniqFM is not filtered).
deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
deserializeAnns deserialize (MkAnnEnv ann_env)
= mapUFM (mapMaybe (fromSerialized deserialize)) ann_env
|
