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   ) where
  17
  18 import Name
  19 import Module           ( Module )
  20 import Outputable
  21 import LazyUniqFM
  22 import Serialized
  23 import Unique
  24
  25 import Data.Typeable
  26 import Data.Maybe
  27 import Data.Word        ( Word8 )
  28
  29
  30 -- | Represents an annotation after it has been sufficiently desugared from
  31 -- it's initial form of 'HsDecls.AnnDecl'
  32 data Annotation = Annotation {
  33         ann_target :: CoreAnnTarget,    -- ^ The target of the annotation
  34         ann_value :: Serialized         -- ^ 'Serialized' version of the annotation that
  35                                         --   allows recovery of its value or can
  36                                         --   be persisted to an interface file
  37     }
  38
  39 -- | An annotation target
  40 data AnnTarget name
  41   = NamedTarget name          -- ^ We are annotating something with a name:
  42                               --      a type or identifier
  43   | ModuleTarget Module       -- ^ We are annotating a particular module
  44
  45 -- | The kind of annotation target found in the middle end of the compiler
  46 type CoreAnnTarget = AnnTarget Name
  47
  48 instance Functor AnnTarget where
  49     fmap f (NamedTarget nm) = NamedTarget (f nm)
  50     fmap _ (ModuleTarget mod) = ModuleTarget mod
  51
  52 getAnnTargetName_maybe :: AnnTarget name -> Maybe name
  53 getAnnTargetName_maybe (NamedTarget nm) = Just nm
  54 getAnnTargetName_maybe _                = Nothing
  55
  56 instance Uniquable name => Uniquable (AnnTarget name) where
  57     getUnique (NamedTarget nm) = getUnique nm
  58     getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0
  59     -- deriveUnique prevents OccName uniques clashing with NamedTarget
  60
  61 instance Outputable name => Outputable (AnnTarget name) where
  62     ppr (NamedTarget nm) = text "Named target" <+> ppr nm
  63     ppr (ModuleTarget mod) = text "Module target" <+> ppr mod
  64
  65
  66 -- | A collection of annotations
  67 newtype AnnEnv = MkAnnEnv (UniqFM [Serialized])
  68 -- Can't use a type synonym or we hit bug #2412 due to source import
  69
  70 emptyAnnEnv :: AnnEnv
  71 emptyAnnEnv = MkAnnEnv emptyUFM
  72
  73 mkAnnEnv :: [Annotation] -> AnnEnv
  74 mkAnnEnv = extendAnnEnvList emptyAnnEnv
  75
  76 extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
  77 extendAnnEnvList (MkAnnEnv env) anns
  78   = MkAnnEnv $ addListToUFM_C (++) env $
  79     map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns
  80
  81 plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
  82 plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2
  83
  84 -- | Find the annotations attached to the given target as 'Typeable'
  85 --   values of your choice. If no deserializer is specified,
  86 --   only transient annotations will be returned.
  87 findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
  88 findAnns deserialize (MkAnnEnv ann_env)
  89   = (mapMaybe (fromSerialized deserialize))
  90     . (lookupWithDefaultUFM ann_env [])
  91 \end{code}