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 Control.Monad
  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
  67 -- | A collection of annotations
  68 newtype AnnEnv = MkAnnEnv (UniqFM [Serialized])
  69 -- Can't use a type synonym or we hit bug #2412 due to source import
  70
  71 emptyAnnEnv :: AnnEnv
  72 emptyAnnEnv = MkAnnEnv emptyUFM
  73
  74 mkAnnEnv :: [Annotation] -> AnnEnv
  75 mkAnnEnv = extendAnnEnvList emptyAnnEnv
  76
  77 extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
  78 extendAnnEnvList (MkAnnEnv env) anns
  79   = MkAnnEnv $ addListToUFM_C (++) env $
  80     map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns
  81
  82 plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
  83 plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2
  84
  85 -- | Find the annotations attached to the given target as 'Typeable'
  86 --   values of your choice. If no deserializer is specified,
  87 --   only transient annotations will be returned.
  88 findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
  89 findAnns deserialize (MkAnnEnv ann_env)
  90   = (mapMaybe (fromSerialized deserialize))
  91     . (lookupWithDefaultUFM ann_env [])
  92 \end{code}