Fix #4346 (INLINABLE pragma not behaving consistently)
[ghc-hetmet.git] / compiler / main / Annotations.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5
6 \begin{code}
7 module Annotations (
8     -- * Main Annotation data types
9     Annotation(..),
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 Name
20 import Module           ( Module )
21 import Outputable
22 import UniqFM
23 import Serialized
24 import Unique
25
26 import Data.Typeable
27 import Data.Maybe
28 import Data.Word        ( Word8 )
29
30
31 -- | Represents an annotation after it has been sufficiently desugared from
32 -- it's initial form of 'HsDecls.AnnDecl'
33 data Annotation = Annotation {
34         ann_target :: CoreAnnTarget,    -- ^ The target of the annotation
35         ann_value :: Serialized         -- ^ 'Serialized' version of the annotation that 
36                                         --   allows recovery of its value or can
37                                         --   be persisted to an interface file
38     }
39
40 -- | An annotation target
41 data AnnTarget name 
42   = NamedTarget name          -- ^ We are annotating something with a name: 
43                               --      a type or identifier
44   | ModuleTarget Module       -- ^ We are annotating a particular module
45
46 -- | The kind of annotation target found in the middle end of the compiler
47 type CoreAnnTarget = AnnTarget Name
48
49 instance Functor AnnTarget where
50     fmap f (NamedTarget nm) = NamedTarget (f nm)
51     fmap _ (ModuleTarget mod) = ModuleTarget mod
52
53 getAnnTargetName_maybe :: AnnTarget name -> Maybe name
54 getAnnTargetName_maybe (NamedTarget nm) = Just nm
55 getAnnTargetName_maybe _                = Nothing
56
57 instance Uniquable name => Uniquable (AnnTarget name) where
58     getUnique (NamedTarget nm) = getUnique nm
59     getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0
60     -- deriveUnique prevents OccName uniques clashing with NamedTarget
61
62 instance Outputable name => Outputable (AnnTarget name) where
63     ppr (NamedTarget nm) = text "Named target" <+> ppr nm
64     ppr (ModuleTarget mod) = text "Module target" <+> ppr mod
65
66 instance Outputable Annotation where
67     ppr ann = ppr (ann_target ann)
68
69 -- | A collection of annotations
70 newtype AnnEnv = MkAnnEnv (UniqFM [Serialized])
71 -- Can't use a type synonym or we hit bug #2412 due to source import
72
73 emptyAnnEnv :: AnnEnv
74 emptyAnnEnv = MkAnnEnv emptyUFM
75
76 mkAnnEnv :: [Annotation] -> AnnEnv
77 mkAnnEnv = extendAnnEnvList emptyAnnEnv
78
79 extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
80 extendAnnEnvList (MkAnnEnv env) anns 
81   = MkAnnEnv $ addListToUFM_C (++) env $
82     map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns
83
84 plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
85 plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2
86
87 -- | Find the annotations attached to the given target as 'Typeable' 
88 --   values of your choice. If no deserializer is specified, 
89 --   only transient annotations will be returned.
90 findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
91 findAnns deserialize (MkAnnEnv ann_env) 
92   = (mapMaybe (fromSerialized deserialize))
93     . (lookupWithDefaultUFM ann_env [])
94
95 -- | Deserialize all annotations of a given type. This happens lazily, that is
96 --   no deserialization will take place until the [a] is actually demanded and
97 --   the [a] can also be empty (the UniqFM is not filtered).
98 deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
99 deserializeAnns deserialize (MkAnnEnv ann_env)
100   = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env
101 \end{code}