{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE CPP #-}


-- | The plugin to make it all work.

module AsyncRattus.Plugin (plugin, AsyncRattus(..)) where
import AsyncRattus.Plugin.StableSolver
import AsyncRattus.Plugin.ScopeCheck
import AsyncRattus.Plugin.Strictify
import AsyncRattus.Plugin.SingleTick
import AsyncRattus.Plugin.CheckClockCompatibility
import AsyncRattus.Plugin.Utils
import AsyncRattus.Plugin.Annotation
import AsyncRattus.Plugin.Transform

import Prelude hiding ((<>))

import Control.Monad
import Data.Maybe
import Data.List
import Data.Data hiding (tyConName)
import qualified Data.Set as Set
import Data.Set (Set)

import qualified GHC.LanguageExtensions as LangExt

import GHC.Plugins
import GHC.Tc.Types

-- | Use this to enable Asynchronous Rattus' plugin, either by supplying the option
-- @-fplugin=AsyncRattus.Plugin@ directly to GHC, or by including the
-- following pragma in each source file:
-- 
-- > {-# OPTIONS -fplugin=AsyncRattus.Plugin #-}
plugin :: Plugin
plugin :: Plugin
plugin = Plugin
defaultPlugin {
  installCoreToDos = install,
  pluginRecompile = purePlugin,
  typeCheckResultAction = typechecked,
  tcPlugin = tcStable,
  driverPlugin = updateEnv
  }


data Options = Options {Options -> Bool
debugMode :: Bool}


-- | Enable the @Strict@ language extension.
updateEnv :: [CommandLineOption] -> HscEnv -> IO HscEnv
updateEnv :: [CommandLineOption] -> HscEnv -> IO HscEnv
updateEnv [CommandLineOption]
_ HscEnv
env = HscEnv -> IO HscEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
env {hsc_dflags = update (hsc_dflags env) } 
  where update :: DynFlags -> DynFlags
update DynFlags
fls = DynFlags -> Extension -> DynFlags
xopt_set DynFlags
fls Extension
LangExt.Strict

typechecked :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typechecked :: [CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv
typechecked [CommandLineOption]
_ ModSummary
_ TcGblEnv
env = TcGblEnv -> TcM ()
checkAll TcGblEnv
env TcM () -> TcM TcGblEnv -> TcM TcGblEnv
forall a b.
IOEnv (Env TcGblEnv TcLclEnv) a
-> IOEnv (Env TcGblEnv TcLclEnv) b
-> IOEnv (Env TcGblEnv TcLclEnv) b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TcGblEnv -> TcM TcGblEnv
forall a. a -> IOEnv (Env TcGblEnv TcLclEnv) a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
env

install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install [CommandLineOption]
opts [CoreToDo]
todo = case (CoreToDo -> Bool) -> [CoreToDo] -> Maybe CoreToDo
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find CoreToDo -> Bool
findSamePass [CoreToDo]
todo of       -- check that we don't run the transformation twice
                      Maybe CoreToDo
Nothing -> [CoreToDo] -> CoreM [CoreToDo]
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreToDo
strPass CoreToDo -> [CoreToDo] -> [CoreToDo]
forall a. a -> [a] -> [a]
: [CoreToDo]
todo) -- (e.g. if the "-fplugin" option is used twice)
                      Maybe CoreToDo
_ -> [CoreToDo] -> CoreM [CoreToDo]
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return [CoreToDo]
todo
    where name :: CommandLineOption
name = CommandLineOption
"Async Rattus strictify"
          strPass :: CoreToDo
strPass = CommandLineOption -> CorePluginPass -> CoreToDo
CoreDoPluginPass CommandLineOption
name (Options -> CorePluginPass
strictifyProgram Options{debugMode :: Bool
debugMode = Bool
dmode})
          dmode :: Bool
dmode = CommandLineOption
"debug" CommandLineOption -> [CommandLineOption] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [CommandLineOption]
opts
          findSamePass :: CoreToDo -> Bool
findSamePass (CoreDoPluginPass CommandLineOption
s CorePluginPass
_) = CommandLineOption
s CommandLineOption -> CommandLineOption -> Bool
forall a. Eq a => a -> a -> Bool
== CommandLineOption
name
          findSamePass CoreToDo
_ = Bool
False
          

-- | Apply the following operations to all Asynchronous Rattus definitions in the
-- program:
--
-- * Transform into single tick form (see SingleTick module)
-- * Check whether lazy data types are used (see Strictify module)
-- * Transform into call-by-value form (see Strictify module)

strictifyProgram :: Options -> ModGuts -> CoreM ModGuts
strictifyProgram :: Options -> CorePluginPass
strictifyProgram Options
opts ModGuts
guts = do
  [CoreBind]
newBinds <- (CoreBind -> CoreM CoreBind) -> [CoreBind] -> CoreM [CoreBind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Options -> ModGuts -> CoreBind -> CoreM CoreBind
strictify Options
opts ModGuts
guts) (ModGuts -> [CoreBind]
mg_binds ModGuts
guts)
  CorePluginPass
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts { mg_binds = newBinds }

strictify :: Options -> ModGuts -> CoreBind -> CoreM CoreBind
strictify :: Options -> ModGuts -> CoreBind -> CoreM CoreBind
strictify Options
opts ModGuts
guts b :: CoreBind
b@(Rec [(Var, CoreExpr)]
bs) = do
  let debug :: Bool
debug = Options -> Bool
debugMode Options
opts
  Bool
tr <- ([Bool] -> Bool) -> CoreM [Bool] -> CoreM Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or (((Var, CoreExpr) -> CoreM Bool)
-> [(Var, CoreExpr)] -> CoreM [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (ModGuts -> Var -> CoreM Bool
shouldProcessCore ModGuts
guts (Var -> CoreM Bool)
-> ((Var, CoreExpr) -> Var) -> (Var, CoreExpr) -> CoreM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst) [(Var, CoreExpr)]
bs)
  if Bool
tr then do
    let vs :: [Var]
vs = ((Var, CoreExpr) -> Var) -> [(Var, CoreExpr)] -> [Var]
forall a b. (a -> b) -> [a] -> [b]
map (Var, CoreExpr) -> Var
forall a b. (a, b) -> a
fst [(Var, CoreExpr)]
bs
    [CoreExpr]
es' <- ((Var, CoreExpr) -> CoreM CoreExpr)
-> [(Var, CoreExpr)] -> CoreM [CoreExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ (Var
v,CoreExpr
e) -> do
      Bool
processCore <- ModGuts -> Var -> CoreM Bool
shouldProcessCore ModGuts
guts Var
v
      if Bool -> Bool
not Bool
processCore
      then do
        Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Skipping binding: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v
        CoreExpr -> CoreM CoreExpr
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreExpr
e
      else ModGuts -> Set Var -> Bool -> Var -> CoreExpr -> CoreM CoreExpr
checkAndTransform ModGuts
guts ([Var] -> Set Var
forall a. Ord a => [a] -> Set a
Set.fromList [Var]
vs) Bool
debug Var
v CoreExpr
e
      ) [(Var, CoreExpr)]
bs
    Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc
"Plugin | result of transformation: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [CoreExpr] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CoreExpr]
es'
    CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Var, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
Rec ([Var] -> [CoreExpr] -> [(Var, CoreExpr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Var]
vs [CoreExpr]
es'))
  else CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreBind
b
strictify Options
opts ModGuts
guts b :: CoreBind
b@(NonRec Var
v CoreExpr
e) = do
    let debug :: Bool
debug = Options -> Bool
debugMode Options
opts
    Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Processing binding: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
" | Non-recursive binding"
    Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Expr: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e
    Bool
processCore <- ModGuts -> Var -> CoreM Bool
shouldProcessCore ModGuts
guts Var
v
    if Bool -> Bool
not Bool
processCore then do
      Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Skipping binding: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v
      CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return CoreBind
b
    else do
      CoreExpr
transformed <- ModGuts -> Set Var -> Bool -> Var -> CoreExpr -> CoreM CoreExpr
checkAndTransform ModGuts
guts Set Var
forall a. Set a
Set.empty Bool
debug Var
v CoreExpr
e
      Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc
"Plugin | result of transformation: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
transformed
      CoreBind -> CoreM CoreBind
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreBind -> CoreM CoreBind) -> CoreBind -> CoreM CoreBind
forall a b. (a -> b) -> a -> b
$ Var -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
NonRec Var
v CoreExpr
transformed

checkAndTransform :: ModGuts -> Set Var -> Bool -> Var -> CoreExpr -> CoreM CoreExpr
checkAndTransform :: ModGuts -> Set Var -> Bool -> Var -> CoreExpr -> CoreM CoreExpr
checkAndTransform ModGuts
guts Set Var
recursiveSet Bool
debug Var
v CoreExpr
e = do
  Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Processing binding: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Var -> SDoc
forall a. Outputable a => a -> SDoc
ppr Var
v
  Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Expr: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
e
  Bool
allowRec <- ModGuts -> Var -> CoreM Bool
allowRecursion ModGuts
guts Var
v
  CoreExpr
singleTick <- CoreExpr -> CoreM CoreExpr
toSingleTick CoreExpr
e
  Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Single-tick: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
singleTick
  Bool
lazy <- ModGuts -> Var -> CoreM Bool
allowLazyData ModGuts
guts Var
v
  Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
lazy) (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SCxt -> CoreExpr -> CoreM ()
checkStrictData (SrcSpan -> SCxt
SCxt (Name -> SrcSpan
nameSrcSpan (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ Var -> Name
forall a. NamedThing a => a -> Name
getName Var
v)) CoreExpr
singleTick
  Bool -> CoreM () -> CoreM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
debug (CoreM () -> CoreM ()) -> CoreM () -> CoreM ()
forall a b. (a -> b) -> a -> b
$ SDoc -> CoreM ()
putMsg (SDoc -> CoreM ()) -> SDoc -> CoreM ()
forall a b. (a -> b) -> a -> b
$ CommandLineOption -> SDoc
forall doc. IsLine doc => CommandLineOption -> doc
text CommandLineOption
"Strict single-tick: " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> CoreExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreExpr
singleTick
  CheckExpr -> CoreExpr -> CoreM ()
checkExpr CheckExpr{ recursiveSet :: Set Var
recursiveSet = Set Var
recursiveSet, oldExpr :: CoreExpr
oldExpr = CoreExpr
e,
                        verbose :: Bool
verbose = Bool
debug,
                        allowRecExp :: Bool
allowRecExp = Bool
allowRec} CoreExpr
singleTick
  CoreExpr -> CoreM CoreExpr
transform CoreExpr
singleTick

getModuleAnnotations :: Data a => ModGuts -> [a]
getModuleAnnotations :: forall a. Data a => ModGuts -> [a]
getModuleAnnotations ModGuts
guts = [a]
anns'
  where anns :: [Annotation]
anns = (Annotation -> Bool) -> [Annotation] -> [Annotation]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Annotation
a-> case Annotation -> CoreAnnTarget
ann_target Annotation
a of
                         ModuleTarget Module
m -> Module
m Module -> Module -> Bool
forall a. Eq a => a -> a -> Bool
== (ModGuts -> Module
mg_module ModGuts
guts)
                         CoreAnnTarget
_ -> Bool
False) (ModGuts -> [Annotation]
mg_anns ModGuts
guts)
        anns' :: [a]
anns' = (Annotation -> Maybe a) -> [Annotation] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (([Word8] -> a) -> Serialized -> Maybe a
forall a. Typeable a => ([Word8] -> a) -> Serialized -> Maybe a
fromSerialized [Word8] -> a
forall a. Data a => [Word8] -> a
deserializeWithData (Serialized -> Maybe a)
-> (Annotation -> Serialized) -> Annotation -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Annotation -> Serialized
ann_value) [Annotation]
anns




allowLazyData :: ModGuts -> CoreBndr -> CoreM Bool
allowLazyData :: ModGuts -> Var -> CoreM Bool
allowLazyData ModGuts
guts Var
bndr = do
  [AsyncRattus]
l <- ModGuts -> Var -> CoreM [AsyncRattus]
forall a. Data a => ModGuts -> Var -> CoreM [a]
annotationsOn ModGuts
guts Var
bndr :: CoreM [AsyncRattus]
  Bool -> CoreM Bool
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AsyncRattus
AllowLazyData AsyncRattus -> [AsyncRattus] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AsyncRattus]
l)

allowRecursion :: ModGuts -> CoreBndr -> CoreM Bool
allowRecursion :: ModGuts -> Var -> CoreM Bool
allowRecursion ModGuts
guts Var
bndr = do
  [AsyncRattus]
l <- ModGuts -> Var -> CoreM [AsyncRattus]
forall a. Data a => ModGuts -> Var -> CoreM [a]
annotationsOn ModGuts
guts Var
bndr :: CoreM [AsyncRattus]
  Bool -> CoreM Bool
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (AsyncRattus
AllowRecursion AsyncRattus -> [AsyncRattus] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [AsyncRattus]
l)

expectError :: ModGuts -> CoreBndr -> CoreM Bool
expectError :: ModGuts -> Var -> CoreM Bool
expectError ModGuts
guts Var
bndr = do
  [InternalAnn]
l <- ModGuts -> Var -> CoreM [InternalAnn]
forall a. Data a => ModGuts -> Var -> CoreM [a]
annotationsOn ModGuts
guts Var
bndr :: CoreM [InternalAnn]
  Bool -> CoreM Bool
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> CoreM Bool) -> Bool -> CoreM Bool
forall a b. (a -> b) -> a -> b
$ InternalAnn
ExpectError InternalAnn -> [InternalAnn] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [InternalAnn]
l


shouldProcessCore :: ModGuts -> CoreBndr -> CoreM Bool
shouldProcessCore :: ModGuts -> Var -> CoreM Bool
shouldProcessCore ModGuts
guts Var
bndr = do
  Bool
expectScopeError <- ModGuts -> Var -> CoreM Bool
expectError ModGuts
guts Var
bndr
  Bool -> CoreM Bool
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Var -> Bool
userFunction Var
bndr Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
expectScopeError)

annotationsOn :: (Data a) => ModGuts -> CoreBndr -> CoreM [a]
annotationsOn :: forall a. Data a => ModGuts -> Var -> CoreM [a]
annotationsOn ModGuts
guts Var
bndr = do
  (ModuleEnv [a]
_,NameEnv [a]
anns)  <- ([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
forall a.
Typeable a =>
([Word8] -> a) -> ModGuts -> CoreM (ModuleEnv [a], NameEnv [a])
getAnnotations [Word8] -> a
forall a. Data a => [Word8] -> a
deserializeWithData ModGuts
guts
  [a] -> CoreM [a]
forall a. a -> CoreM a
forall (m :: * -> *) a. Monad m => a -> m a
return ([a] -> CoreM [a]) -> [a] -> CoreM [a]
forall a b. (a -> b) -> a -> b
$
    NameEnv [a] -> [a] -> Name -> [a]
forall key elt.
Uniquable key =>
UniqFM key elt -> elt -> key -> elt
lookupWithDefaultUFM NameEnv [a]
anns [] (Var -> Name
varName Var
bndr) [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++
    ModGuts -> [a]
forall a. Data a => ModGuts -> [a]
getModuleAnnotations ModGuts
guts