PageRenderTime 52ms CodeModel.GetById 24ms RepoModel.GetById 0ms app.codeStats 0ms

/compiler/main/Annotations.lhs

https://bitbucket.org/khibino/ghc-hack
Haskell | 108 lines | 63 code | 21 blank | 24 comment | 0 complexity | 76a39a7853b7f11891272058ce941943 MD5 | raw file
Possible License(s): BSD-3-Clause, BSD-2-Clause, LGPL-3.0
  1. %
  2. % (c) The University of Glasgow 2006
  3. % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
  4. %
  5. \begin{code}
  6. {-# OPTIONS -fno-warn-tabs #-}
  7. -- The above warning supression flag is a temporary kludge.
  8. -- While working on this module you are encouraged to remove it and
  9. -- detab the module (please do the detabbing in a separate patch). See
  10. -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
  11. -- for details
  12. module Annotations (
  13. -- * Main Annotation data types
  14. Annotation(..),
  15. AnnTarget(..), CoreAnnTarget,
  16. getAnnTargetName_maybe,
  17. -- * AnnEnv for collecting and querying Annotations
  18. AnnEnv,
  19. mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv, findAnns,
  20. deserializeAnns
  21. ) where
  22. import Name
  23. import Module ( Module )
  24. import Outputable
  25. import UniqFM
  26. import Serialized
  27. import Unique
  28. import Data.Typeable
  29. import Data.Maybe
  30. import Data.Word ( Word8 )
  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. -- | 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. -- | The kind of annotation target found in the middle end of the compiler
  45. type CoreAnnTarget = AnnTarget Name
  46. instance Functor AnnTarget where
  47. fmap f (NamedTarget nm) = NamedTarget (f nm)
  48. fmap _ (ModuleTarget mod) = ModuleTarget mod
  49. getAnnTargetName_maybe :: AnnTarget name -> Maybe name
  50. getAnnTargetName_maybe (NamedTarget nm) = Just nm
  51. getAnnTargetName_maybe _ = Nothing
  52. instance Uniquable name => Uniquable (AnnTarget name) where
  53. getUnique (NamedTarget nm) = getUnique nm
  54. getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0
  55. -- deriveUnique prevents OccName uniques clashing with NamedTarget
  56. instance Outputable name => Outputable (AnnTarget name) where
  57. ppr (NamedTarget nm) = text "Named target" <+> ppr nm
  58. ppr (ModuleTarget mod) = text "Module target" <+> ppr mod
  59. instance Outputable Annotation where
  60. ppr ann = ppr (ann_target ann)
  61. -- | A collection of annotations
  62. newtype AnnEnv = MkAnnEnv (UniqFM [Serialized])
  63. -- Can't use a type synonym or we hit bug #2412 due to source import
  64. emptyAnnEnv :: AnnEnv
  65. emptyAnnEnv = MkAnnEnv emptyUFM
  66. mkAnnEnv :: [Annotation] -> AnnEnv
  67. mkAnnEnv = extendAnnEnvList emptyAnnEnv
  68. extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
  69. extendAnnEnvList (MkAnnEnv env) anns
  70. = MkAnnEnv $ addListToUFM_C (++) env $
  71. map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns
  72. plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
  73. plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2
  74. -- | Find the annotations attached to the given target as 'Typeable'
  75. -- values of your choice. If no deserializer is specified,
  76. -- only transient annotations will be returned.
  77. findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
  78. findAnns deserialize (MkAnnEnv ann_env)
  79. = (mapMaybe (fromSerialized deserialize))
  80. . (lookupWithDefaultUFM ann_env [])
  81. -- | Deserialize all annotations of a given type. This happens lazily, that is
  82. -- no deserialization will take place until the [a] is actually demanded and
  83. -- the [a] can also be empty (the UniqFM is not filtered).
  84. deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
  85. deserializeAnns deserialize (MkAnnEnv ann_env)
  86. = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env
  87. \end{code}