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}