never executed always true always false
1 -- |
2 -- Support for source code annotation feature of GHC. That is the ANN pragma.
3 --
4 -- (c) The University of Glasgow 2006
5 -- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
6 --
7 {-# LANGUAGE DeriveFunctor #-}
8 module GHC.Types.Annotations (
9 -- * Main Annotation data types
10 Annotation(..), AnnPayload,
11 AnnTarget(..), CoreAnnTarget,
12
13 -- * AnnEnv for collecting and querying Annotations
14 AnnEnv,
15 mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv,
16 findAnns, findAnnsByTypeRep,
17 deserializeAnns
18 ) where
19
20 import GHC.Prelude
21
22 import GHC.Utils.Binary
23 import GHC.Unit.Module ( Module )
24 import GHC.Unit.Module.Env
25 import GHC.Types.Name.Env
26 import GHC.Types.Name
27 import GHC.Utils.Outputable
28 import GHC.Serialized
29
30 import Control.Monad
31 import Data.Maybe
32 import Data.Typeable
33 import Data.Word ( Word8 )
34
35
36 -- | Represents an annotation after it has been sufficiently desugared from
37 -- it's initial form of 'GHC.Hs.Decls.AnnDecl'
38 data Annotation = Annotation {
39 ann_target :: CoreAnnTarget, -- ^ The target of the annotation
40 ann_value :: AnnPayload
41 }
42
43 type AnnPayload = Serialized -- ^ The "payload" of an annotation
44 -- allows recovery of its value at a given type,
45 -- and can be persisted to an interface file
46
47 -- | An annotation target
48 data AnnTarget name
49 = NamedTarget name -- ^ We are annotating something with a name:
50 -- a type or identifier
51 | ModuleTarget Module -- ^ We are annotating a particular module
52 deriving (Functor)
53
54 -- | The kind of annotation target found in the middle end of the compiler
55 type CoreAnnTarget = AnnTarget Name
56
57 instance Outputable name => Outputable (AnnTarget name) where
58 ppr (NamedTarget nm) = text "Named target" <+> ppr nm
59 ppr (ModuleTarget mod) = text "Module target" <+> ppr mod
60
61 instance Binary name => Binary (AnnTarget name) where
62 put_ bh (NamedTarget a) = do
63 putByte bh 0
64 put_ bh a
65 put_ bh (ModuleTarget a) = do
66 putByte bh 1
67 put_ bh a
68 get bh = do
69 h <- getByte bh
70 case h of
71 0 -> liftM NamedTarget $ get bh
72 _ -> liftM ModuleTarget $ get bh
73
74 instance Outputable Annotation where
75 ppr ann = ppr (ann_target ann)
76
77 -- | A collection of annotations
78 data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload])
79 , ann_name_env :: !(NameEnv [AnnPayload])
80 }
81
82 -- | An empty annotation environment.
83 emptyAnnEnv :: AnnEnv
84 emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv
85
86 -- | Construct a new annotation environment that contains the list of
87 -- annotations provided.
88 mkAnnEnv :: [Annotation] -> AnnEnv
89 mkAnnEnv = extendAnnEnvList emptyAnnEnv
90
91 -- | Add the given annotation to the environment.
92 extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
93 extendAnnEnvList env =
94 foldl' extendAnnEnv env
95
96 extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv
97 extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) =
98 case tgt of
99 NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload])
100 ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env
101
102 -- | Union two annotation environments.
103 plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
104 plusAnnEnv a b =
105 MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b)
106 , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b)
107 }
108
109 -- | Find the annotations attached to the given target as 'Typeable'
110 -- values of your choice. If no deserializer is specified,
111 -- only transient annotations will be returned.
112 findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
113 findAnns deserialize env
114 = mapMaybe (fromSerialized deserialize) . findAnnPayloads env
115
116 -- | Find the annotations attached to the given target as 'Typeable'
117 -- values of your choice. If no deserializer is specified,
118 -- only transient annotations will be returned.
119 findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
120 findAnnsByTypeRep env target tyrep
121 = [ ws | Serialized tyrep' ws <- findAnnPayloads env target
122 , tyrep' == tyrep ]
123
124 -- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'.
125 findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload]
126 findAnnPayloads env target =
127 case target of
128 ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod
129 NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name
130
131 -- | Deserialize all annotations of a given type. This happens lazily, that is
132 -- no deserialization will take place until the [a] is actually demanded and
133 -- the [a] can also be empty (the UniqFM is not filtered).
134 deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
135 deserializeAnns deserialize env
136 = ( mapModuleEnv deserAnns (ann_mod_env env)
137 , mapNameEnv deserAnns (ann_name_env env)
138 )
139 where deserAnns = mapMaybe (fromSerialized deserialize)
140