{-# LANGUAGE DeriveFunctor #-}
module GHC.Types.Annotations (
Annotation(..), AnnPayload,
AnnTarget(..), CoreAnnTarget,
AnnEnv,
mkAnnEnv, extendAnnEnvList, plusAnnEnv, emptyAnnEnv,
findAnns, findAnnsByTypeRep,
deserializeAnns
) where
import GHC.Prelude
import GHC.Utils.Binary
import GHC.Unit.Module ( Module )
import GHC.Unit.Module.Env
import GHC.Types.Name.Env
import GHC.Types.Name
import GHC.Utils.Outputable
import GHC.Serialized
import Control.Monad
import Data.Maybe
import Data.Typeable
import Data.Word ( Word8 )
data Annotation = Annotation {
Annotation -> CoreAnnTarget
ann_target :: CoreAnnTarget,
Annotation -> AnnPayload
ann_value :: AnnPayload
}
type AnnPayload = Serialized
data AnnTarget name
= NamedTarget name
| ModuleTarget Module
deriving (forall a b. a -> AnnTarget b -> AnnTarget a
forall a b. (a -> b) -> AnnTarget a -> AnnTarget b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AnnTarget b -> AnnTarget a
$c<$ :: forall a b. a -> AnnTarget b -> AnnTarget a
fmap :: forall a b. (a -> b) -> AnnTarget a -> AnnTarget b
$cfmap :: forall a b. (a -> b) -> AnnTarget a -> AnnTarget b
Functor)
type CoreAnnTarget = AnnTarget Name
instance Outputable name => Outputable (AnnTarget name) where
ppr :: AnnTarget name -> SDoc
ppr (NamedTarget name
nm) = String -> SDoc
text String
"Named target" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr name
nm
ppr (ModuleTarget Module
mod) = String -> SDoc
text String
"Module target" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
mod
instance Binary name => Binary (AnnTarget name) where
put_ :: BinHandle -> AnnTarget name -> IO ()
put_ BinHandle
bh (NamedTarget name
a) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
0
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh name
a
put_ BinHandle
bh (ModuleTarget Module
a) = do
BinHandle -> Word8 -> IO ()
putByte BinHandle
bh Word8
1
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Module
a
get :: BinHandle -> IO (AnnTarget name)
get BinHandle
bh = do
Word8
h <- BinHandle -> IO Word8
getByte BinHandle
bh
case Word8
h of
Word8
0 -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall name. name -> AnnTarget name
NamedTarget forall a b. (a -> b) -> a -> b
$ forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
Word8
_ -> forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall name. Module -> AnnTarget name
ModuleTarget forall a b. (a -> b) -> a -> b
$ forall a. Binary a => BinHandle -> IO a
get BinHandle
bh
instance Outputable Annotation where
ppr :: Annotation -> SDoc
ppr Annotation
ann = forall a. Outputable a => a -> SDoc
ppr (Annotation -> CoreAnnTarget
ann_target Annotation
ann)
data AnnEnv = MkAnnEnv { AnnEnv -> ModuleEnv [AnnPayload]
ann_mod_env :: !(ModuleEnv [AnnPayload])
, AnnEnv -> NameEnv [AnnPayload]
ann_name_env :: !(NameEnv [AnnPayload])
}
emptyAnnEnv :: AnnEnv
emptyAnnEnv :: AnnEnv
emptyAnnEnv = ModuleEnv [AnnPayload] -> NameEnv [AnnPayload] -> AnnEnv
MkAnnEnv forall a. ModuleEnv a
emptyModuleEnv forall a. NameEnv a
emptyNameEnv
mkAnnEnv :: [Annotation] -> AnnEnv
mkAnnEnv :: [Annotation] -> AnnEnv
mkAnnEnv = AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList AnnEnv
emptyAnnEnv
extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
extendAnnEnvList AnnEnv
env =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' AnnEnv -> Annotation -> AnnEnv
extendAnnEnv AnnEnv
env
extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv
extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv
extendAnnEnv (MkAnnEnv ModuleEnv [AnnPayload]
mod_env NameEnv [AnnPayload]
name_env) (Annotation CoreAnnTarget
tgt AnnPayload
payload) =
case CoreAnnTarget
tgt of
NamedTarget Name
name -> ModuleEnv [AnnPayload] -> NameEnv [AnnPayload] -> AnnEnv
MkAnnEnv ModuleEnv [AnnPayload]
mod_env (forall a. (a -> a -> a) -> NameEnv a -> Name -> a -> NameEnv a
extendNameEnv_C forall a. [a] -> [a] -> [a]
(++) NameEnv [AnnPayload]
name_env Name
name [AnnPayload
payload])
ModuleTarget Module
mod -> ModuleEnv [AnnPayload] -> NameEnv [AnnPayload] -> AnnEnv
MkAnnEnv (forall a.
(a -> a -> a) -> ModuleEnv a -> Module -> a -> ModuleEnv a
extendModuleEnvWith forall a. [a] -> [a] -> [a]
(++) ModuleEnv [AnnPayload]
mod_env Module
mod [AnnPayload
payload]) NameEnv [AnnPayload]
name_env
plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
plusAnnEnv AnnEnv
a AnnEnv
b =
MkAnnEnv { ann_mod_env :: ModuleEnv [AnnPayload]
ann_mod_env = forall a.
(a -> a -> a) -> ModuleEnv a -> ModuleEnv a -> ModuleEnv a
plusModuleEnv_C forall a. [a] -> [a] -> [a]
(++) (AnnEnv -> ModuleEnv [AnnPayload]
ann_mod_env AnnEnv
a) (AnnEnv -> ModuleEnv [AnnPayload]
ann_mod_env AnnEnv
b)
, ann_name_env :: NameEnv [AnnPayload]
ann_name_env = forall a. (a -> a -> a) -> NameEnv a -> NameEnv a -> NameEnv a
plusNameEnv_C forall a. [a] -> [a] -> [a]
(++) (AnnEnv -> NameEnv [AnnPayload]
ann_name_env AnnEnv
a) (AnnEnv -> NameEnv [AnnPayload]
ann_name_env AnnEnv
b)
}
findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns :: forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
findAnns [Word8] -> a
deserialize AnnEnv
env
= forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. Typeable a => ([Word8] -> a) -> AnnPayload -> Maybe a
fromSerialized [Word8] -> a
deserialize) forall b c a. (b -> c) -> (a -> b) -> a -> c
. AnnEnv -> CoreAnnTarget -> [AnnPayload]
findAnnPayloads AnnEnv
env
findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
findAnnsByTypeRep AnnEnv
env CoreAnnTarget
target TypeRep
tyrep
= [ [Word8]
ws | Serialized TypeRep
tyrep' [Word8]
ws <- AnnEnv -> CoreAnnTarget -> [AnnPayload]
findAnnPayloads AnnEnv
env CoreAnnTarget
target
, TypeRep
tyrep' forall a. Eq a => a -> a -> Bool
== TypeRep
tyrep ]
findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload]
findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload]
findAnnPayloads AnnEnv
env CoreAnnTarget
target =
case CoreAnnTarget
target of
ModuleTarget Module
mod -> forall a. ModuleEnv a -> a -> Module -> a
lookupWithDefaultModuleEnv (AnnEnv -> ModuleEnv [AnnPayload]
ann_mod_env AnnEnv
env) [] Module
mod
NamedTarget Name
name -> forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall a. NameEnv a -> Name -> Maybe a
lookupNameEnv (AnnEnv -> NameEnv [AnnPayload]
ann_name_env AnnEnv
env) Name
name
deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
deserializeAnns :: forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
deserializeAnns [Word8] -> a
deserialize AnnEnv
env
= ( forall a b. (a -> b) -> ModuleEnv a -> ModuleEnv b
mapModuleEnv [AnnPayload] -> [a]
deserAnns (AnnEnv -> ModuleEnv [AnnPayload]
ann_mod_env AnnEnv
env)
, forall elt1 elt2. (elt1 -> elt2) -> NameEnv elt1 -> NameEnv elt2
mapNameEnv [AnnPayload] -> [a]
deserAnns (AnnEnv -> NameEnv [AnnPayload]
ann_name_env AnnEnv
env)
)
where deserAnns :: [AnnPayload] -> [a]
deserAnns = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a. Typeable a => ([Word8] -> a) -> AnnPayload -> Maybe a
fromSerialized [Word8] -> a
deserialize)