--- | Loads the given files and turns it into a core module
-loadModules ::
- FilePath -- ^ The GHC Library directory
- -> [String] -- ^ The files that need to be loaded
- -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The TopEntity finder
- -> (HscTypes.CoreModule -> Ghc (Maybe CoreBndr)) -- ^ The InitState finder
- -> (HscTypes.CoreModule -> Ghc (Maybe CoreExpr)) -- ^ The TestInput finder
- -> IO ( [HscTypes.CoreModule] -- The loaded modules
- , [Maybe CoreBndr] -- The TopEntity
- , [Maybe CoreBndr] -- The InitState
- , [Maybe CoreExpr] -- The TestInput
- , HscTypes.HscEnv -- The Environment corresponding ot the loaded modules
- )
-loadModules libdir filenames topEntLoc initSLoc testLoc =
- defaultErrorHandler defaultDynFlags $ do
- runGhc (Just libdir) $ do
- dflags <- getSessionDynFlags
- setSessionDynFlags dflags
- cores <- mapM GHC.compileToCoreModule filenames
- env <- GHC.getSession
- top_entity <- mapM topEntLoc cores
- init_state <- mapM initSLoc cores
- test_input <- mapM testLoc cores
- return (cores, top_entity, init_state, test_input, env)
-
-findBindAnn ::
- GhcMonad m =>
- (Var.Var -> m Bool)
- -> HscTypes.CoreModule
- -> m (Maybe CoreBndr)
-findBindAnn annotation core = do
- let binds = CoreSyn.flattenBinds $ cm_binds core
- annbinds <- Monad.filterM (annotation . fst) binds
- let bndr = case annbinds of [] -> Nothing ; xs -> Just $ head $ fst (unzip annbinds)
- return bndr
-
-findExprAnn ::
- GhcMonad m =>
- (Var.Var -> m Bool)
- -> HscTypes.CoreModule
- -> m (Maybe CoreExpr)
-findExprAnn annotation core = do
- let binds = CoreSyn.flattenBinds $ cm_binds core
- annbinds <- Monad.filterM (annotation . fst) binds
- let exprs = case annbinds of [] -> Nothing ; xs -> Just $ head $ snd (unzip annbinds)
- return exprs
-
-hasCLasHAnnotation ::
- GhcMonad m =>
- (CLasHAnn -> Bool)
- -> Var.Var
- -> m Bool
-hasCLasHAnnotation clashAnn var = do
- let deserializer = Serialized.deserializeWithData
- let target = Annotations.NamedTarget (Var.varName var)
- (anns :: [CLasHAnn]) <- GHC.findGlobalAnns deserializer target
- let top_ents = filter clashAnn anns
- case top_ents of
- [] -> return False
- xs -> return True
-
--- | Extracts the named binder from the given module.
-findBind ::
- GhcMonad m =>
- String -- ^ The Name of the Binder
- -> HscTypes.CoreModule -- ^ The Module to look in
- -> m (Maybe CoreBndr) -- ^ The resulting binder
-findBind name core =
- case (findBinder (CoreSyn.flattenBinds $ cm_binds core)) name of
- Nothing -> return Nothing
- Just bndr -> return $ Just $ fst bndr
-
--- | Extracts the named expression from the given module.
-findExpr ::
- GhcMonad m =>
- String -- ^ The Name of the Binder
- -> HscTypes.CoreModule -- ^ The Module to look in
- -> m (Maybe CoreExpr) -- ^ The resulting expression
-findExpr name core =
- case (findBinder (CoreSyn.flattenBinds $ cm_binds core)) name of
- Nothing -> return Nothing
- Just bndr -> return $ Just $ snd bndr
-
--- | Extract a named bind from the given list of binds
-findBinder :: [(CoreBndr, CoreExpr)] -> String -> Maybe (CoreBndr, CoreExpr)
-findBinder binds lookfor =
- -- This ignores Recs and compares the name of the bind with lookfor,
- -- disregarding any namespaces in OccName and extra attributes in Name and
- -- Var.
- find (\(var, _) -> lookfor == (occNameString $ nameOccName $ getName var)) binds
-