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