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