-- | The recommended interface, because it is safer (guaranteed not to crash as long
-- as modules have not been mis-installed somehow), is 'loadDynamic'. For
-- versatility's sake, 'unsafeLoad' is provided as well, but caveat codor!
module System.Plugins (unsafeLoad, loadDynamic) where
import Data.Dynamic
import Data.IORef
import Data.List
import Data.Maybe
import Data.Typeable
import Unsafe.Coerce
import qualified BasicTypes
import qualified DynFlags
import qualified Encoding
import qualified Exception
import qualified FastString
import qualified GHC
import qualified GHC.Exts
import qualified GHC.Paths (libdir)
import qualified HscTypes
import qualified IfaceSyn
import qualified IfaceType
import qualified IOEnv
import qualified Linker
import qualified LoadIface
import qualified Maybes
import qualified Module
import MonadUtils (liftIO)
import qualified Name
import qualified ObjLink
import qualified OccName
import qualified Outputable
import qualified PackageConfig
import qualified Packages
import qualified TcRnTypes
import qualified SrcLoc
import qualified UniqSupply
import qualified Unique
-- | Resolves the specified symbol to any given type. This means linking the package
-- containing it if it is not already linked, extracting the value of that symbol,
-- and returning that value. Because a call is made to 'unsafeCoerce', the behavior
-- is unpredictable (most likely an immediate crash) if the symbol is not actually of
-- the expected type. Because 'load' has no a priori way to know the type, you must
-- be certain to provide adequate type information in the caller, ie by giving a
-- type signature.
--
-- Three error conditions are detected and handled nicely, returning
-- 'Nothing': The package does not exist; the package does not contain the given
-- module; or the module does not contain a symbol by the given name.
--
-- As a limitation which may be relaxed in a future version, note that re-exports
-- are not chased; thus for example it is not possible to find the symbol
-- @base:Prelude.sum@, because that symbol is actually defined in @base:Data.List@.
unsafeLoad
:: (String, String, String)
-- ^ A tuple (@packageName@, @moduleName@, @symbolName@), specifying a symbol in
-- a package installed somewhere in ghc's database.
--
-- @packageName@ is a full package name including a version,
-- ie @\"hello-1.0\"@; you can inspect these package names through
-- @ghc-pkg@.
--
-- @moduleName@ is a fully-qualified module name, ie @\"Hello\"@ or
-- @\"Data.Dynamic\"@.
--
-- @symbolName@ is an unqualified symbol name, ie @\"hello\"@.
-> IO (Maybe a)
-- ^ If the specified symbol is found, 'Just' its
-- value. Otherwise, 'Nothing'.
unsafeLoad symbol@(packageName, moduleName, symbolName)
= GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
GHC.runGhc (Just GHC.Paths.libdir) $ do
flags <- GHC.getSessionDynFlags
GHC.setSessionDynFlags flags
(flags, _) <- liftIO $ Packages.initPackages flags
liftIO $ Linker.initDynLinker flags
let packageId = Module.fsToPackageId (FastString.mkFastString packageName)
Exception.ghandle
(\(GHC.CmdLineError _) -> do
liftIO $ putStrLn $ "Unknown package " ++ packageName ++ "."
return Nothing)
(do
liftIO $ Linker.linkPackages flags [packageId]
Exception.ghandle
(\(GHC.ProgramError string) -> do
if (hasPrefix string "Failed to load interface ")
then liftIO $ putStrLn $ "Unknown module " ++ moduleName
++ " in package " ++ packageName
++ "."
else liftIO $ putStrLn $ "Unknown symbol " ++ symbolName
++ " in module " ++ moduleName
++ " in package " ++ packageName
++ "."
return Nothing)
(do
session <- GHC.getSession
let name = Name.mkExternalName
(Unique.mkBuiltinUnique 0)
(Module.mkModule packageId
(Module.mkModuleName moduleName))
(OccName.mkVarOcc symbolName)
SrcLoc.noSrcSpan
result <- liftIO $ Linker.getHValue session name
return $ Just $ unsafeCoerce result))
-- | Resolves the specified symbol to a Dynamic. This means first parsing the installed
-- .hi file for the package containing the symbol to verify that the symbol is in fact
-- a Dynamic, then, if it is, linking the package if it is not already linked,
-- extracting the value of that symbol, and returning that value. Unlike 'load', this
-- function should be \"perfectly safe\", not crashing even if the symbol is not
-- actually of the expected type.
--
-- Four error conditions are detected and handled nicely, returning
-- 'Nothing': The package does not exist; the package does not contain the given
-- module; the module does not contain a symbol by the given name; or the symbol's type
-- is not 'Dynamic'.
--
-- As a limitation which may be relaxed in a future version, note that re-exports are
-- not chased; thus for example it is not possible to find the symbol
-- @base:Prelude.sum@, because that symbol is actually defined in @base:Data.List@.
-- (Also because that symbol is not a 'Dynamic'.)
loadDynamic
:: (String, String, String)
-- ^ A tuple (@packageName@, @moduleName@, @symbolName@), specifying a symbol in
-- a package installed somewhere in ghc's database.
--
-- @packageName@ is a full package name including a version,
-- ie @\"hello-1.0\"@; you can inspect these package names through
-- @ghc-pkg@.
--
-- @moduleName@ is a fully-qualified module name, ie @\"Hello\"@ or
-- @\"Data.Dynamic\"@.
--
-- @symbolName@ is an unqualified symbol name, ie @\"hello\"@.
-> IO (Maybe Dynamic)
-- ^ If the specified symbol is found and of an appropriate type, 'Just' its
-- value. Otherwise, 'Nothing'.
loadDynamic symbol = do
maybeInterfaceType <- symbolInterfaceType symbol
case maybeInterfaceType of
Nothing -> return Nothing
Just interfaceType -> do
let isDynamic = interfaceTypeIsDynamic interfaceType
case isDynamic of
False -> return Nothing
True -> unsafeLoad symbol
symbolInterfaceType :: (String, String, String) -> IO (Maybe IfaceType.IfaceType)
symbolInterfaceType (packageName, moduleName, symbolName)
= GHC.defaultErrorHandler DynFlags.defaultDynFlags $ do
GHC.runGhc (Just GHC.Paths.libdir) $ do
flags <- GHC.getSessionDynFlags
GHC.setSessionDynFlags flags
(flags, _) <- liftIO $ Packages.initPackages flags
uniqueSupply <- liftIO $ UniqSupply.mkSplitUniqSupply 'a'
uniqueSupplyIORef <- liftIO $ newIORef uniqueSupply
hscEnv <- GHC.getSession
let packageState = DynFlags.pkgState flags
packageId = Module.fsToPackageId (FastString.mkFastString packageName)
case Packages.lookupPackage (Packages.pkgIdMap packageState) packageId of
Nothing -> do
liftIO $ putStrLn $ "Unknown package " ++ packageName ++ "."
return Nothing
Just packageConfig -> do
let installedPackageInfo
= PackageConfig.packageConfigToInstalledPackageInfo packageConfig
module' = Module.mkModule packageId $ Module.mkModuleName moduleName
libraryDirs = PackageConfig.libraryDirs installedPackageInfo
interfacePathWithinLibraryDir = moduleNameToInterfacePath moduleName
visitLibraryDir (libraryDir : moreLibraryDirs) = (do
let interfacePath = libraryDir ++ "/" ++ interfacePathWithinLibraryDir
environment = TcRnTypes.Env {
TcRnTypes.env_top = hscEnv,
TcRnTypes.env_us = uniqueSupplyIORef,
TcRnTypes.env_gbl = (),
TcRnTypes.env_lcl = ()
}
errorOrModuleInterface
<- liftIO $ IOEnv.runIOEnv environment
$ LoadIface.readIface module' interfacePath False
case errorOrModuleInterface of
Maybes.Failed message -> visitLibraryDir moreLibraryDirs
Maybes.Succeeded moduleInterface -> do
let variableName = OccName.mkVarOcc symbolName
declarations = HscTypes.mi_decls moduleInterface
visitDeclaration ((_, declaration) : moreDeclarations) = (do
case declaration of
IfaceSyn.IfaceId { } -> do
if IfaceSyn.ifName declaration == variableName
then return $ Just $ IfaceSyn.ifType declaration
else visitDeclaration moreDeclarations
_ -> visitDeclaration moreDeclarations)
visitDeclaration [] = do
liftIO $ putStrLn $ "Unknown symbol " ++ symbolName
++ " in module " ++ moduleName
++ " in package " ++ packageName
++ "."
return Nothing
visitDeclaration declarations)
visitLibraryDir [] = do
liftIO $ putStrLn $ "Unknown module " ++ moduleName
++ " in package " ++ packageName
++ "."
return Nothing
visitLibraryDir libraryDirs
interfaceTypeToString :: IfaceType.IfaceType -> String
interfaceTypeToString ifaceType
= Outputable.showSDoc $ IfaceType.pprIfaceType ifaceType
interfaceTypeIsDynamic :: IfaceType.IfaceType -> Bool
interfaceTypeIsDynamic (IfaceType.IfaceTyConApp constructor arguments)
= let interfaceTypeConstructorIsDynamic (IfaceType.IfaceTc name)
= let occName = Name.nameOccName name
typeName = OccName.occNameString occName
module' = Name.nameModule name
packageId = Module.modulePackageId module'
packageName = Module.packageIdString packageId
moduleName = Module.moduleNameString $ Module.moduleName module'
in (packageName == "base")
&& (moduleName == "Data.Dynamic")
&& (typeName == "Dynamic")
interfaceTypeConstructorIsDynamic _ = False
in (length arguments == 0) && (interfaceTypeConstructorIsDynamic constructor)
interfaceTypeIsDynamic _ = False
encodeSymbol :: (String, String, String) -> String
encodeSymbol (packageName, moduleName, symbolName)
= (Encoding.zEncodeString packageName)
++ "_"
++ (Encoding.zEncodeString moduleName)
++ "_"
++ (Encoding.zEncodeString symbolName)
++ "_closure"
moduleNameToInterfacePath :: String -> String
moduleNameToInterfacePath moduleName =
let translateCharacter '.' = '/'
translateCharacter c = c
in (map translateCharacter moduleName) ++ ".hi"
hasPrefix :: String -> String -> Bool
hasPrefix string prefix = take (length prefix) string == prefix