blob: 55e32e5b69f2be2d0f7555abc7c010284b955db6 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
|
{-# LANGUAGE DeriveDataTypeable #-}
module SayAnnNames (plugin, SomeAnn(..)) where
import GhcPlugins
import Control.Monad (unless)
import Data.Data
data SomeAnn = SomeAnn deriving (Data, Typeable)
plugin :: Plugin
plugin = defaultPlugin {
installCoreToDos = install
}
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ todo = do
return (CoreDoPluginPass "Say name" pass : todo)
pass :: ModGuts -> CoreM ModGuts
pass g = do
dflags <- getDynFlags
mapM_ (printAnn dflags g) (mg_binds g) >> return g
where printAnn :: DynFlags -> ModGuts -> CoreBind -> CoreM CoreBind
printAnn dflags guts bndr@(NonRec b _) = do
anns <- annotationsOn guts b :: CoreM [SomeAnn]
unless (null anns) $ putMsgS $
"Annotated binding found: " ++ showSDoc dflags (ppr b)
return bndr
printAnn _ _ bndr = return bndr
annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a]
annotationsOn guts bndr = do
anns <- getAnnotations deserializeWithData guts
return $ lookupWithDefaultUFM anns [] (varUnique bndr)
|
